[ { "path": ".Rbuildignore", "content": "^docs$\n^.gitignore$\n^appveyor\\.yml$\n^_pkgdown\\.yml$\n^Makefile$\n^\\.circleci$\n^susieR\\.Rproj$\n^\\.Rproj\\.user$\n^\\.travis\\.yml$\n^.*\\.Rproj$\n^tests/testthat/full_data_1_sim_gaussian_null_1\\.rds$\n^inst/datafiles$\n^inst/code/compute_ss_data\\.RData$\n^inst/code/susie_data\\.RData$\n^inst/code/susie_rss_data\\.RData$\n^LICENSE\\.md$\n^NOTES\\.txt$\n^\\.Renviron$\n^pixi\\.toml$\n^pixi\\.lock$\n^\\.pixi/.*\n^\\.github$\n" }, { "path": ".github/dependabot.yml", "content": "version: 2\nupdates:\n - package-ecosystem: \"github-actions\"\n directory: \"/\"\n schedule:\n interval: \"weekly\"" }, { "path": ".github/rattler-build_container.df", "content": "FROM ghcr.io/prefix-dev/pixi:latest\n\nSHELL [\"/bin/bash\", \"-c\"]\nRUN apt-get update\nRUN apt-get install -y libgl1 ca-certificates\nRUN groupadd -g 118 github\nRUN useradd -m -u 1001 -g 118 -s /bin/bash runner\nUSER runner\nRUN pixi global install rattler-build git patch\nENV PATH=/home/runner/.pixi/bin:${PATH}\n" }, { "path": ".github/recipe/recipe.yaml", "content": "context:\n version: VERSION_PLACEHOLDER\n\npackage:\n name: r-susier\n version: ${{ version }}\n\nsource:\n path: susieR-${{ version }}.tar.gz\n sha256: SHA256SUM_PLACEHOLDER\n\nbuild:\n number: BUILD_PLACEHOLDER\n dynamic_linking:\n rpaths:\n - lib/R/lib/\n - lib/\n script: R CMD INSTALL --build .\n\nrequirements:\n build:\n - ${{ compiler('c') }}\n - ${{ stdlib('c') }}\n - ${{ compiler('cxx') }}\n host:\n - r-base\n - r-cowplot\n - r-crayon\n - r-curl\n - r-ggplot2\n - r-knitr\n - r-l0learn\n - r-matrix\n - r-matrixstats\n - r-microbenchmark\n - r-mixsqp\n - r-cpp11\n - r-cpp11armadillo\n - r-reshape\n - r-rfast\n - r-rmarkdown\n - r-survival\n - r-testthat\n run:\n - r-base\n - r-cowplot\n - r-crayon\n - r-curl\n - r-ggplot2\n - r-knitr\n - r-l0learn\n - r-matrix\n - r-matrixstats\n - r-microbenchmark\n - r-mixsqp\n - r-cpp11\n - r-cpp11armadillo\n - r-reshape\n - r-rfast\n - r-rmarkdown\n - r-survival\n - r-testthat\n\ntests:\n - script:\n - R -e \"library('susieR')\"\n\nabout:\n license: BSD-3-Clause\n license_file: LICENSE\n summary: Implements methods for variable selection in linear regression based on the Sum of Single Effects (SuSiE) model.\n homepage: https://github.com/stephenslab/susieR\n\nextra:\n recipe-maintainers:\n - danielnachun\n" }, { "path": ".github/recipe/variant_r44.yaml", "content": "MACOSX_DEPLOYMENT_TARGET:\n - '11.0'\nc_stdlib_version:\n - if: linux\n then: 2.17\n - if: osx\n then: 11.0\nc_stdlib:\n - if: linux\n then: sysroot\n - if: osx\n then: macosx_deployment_target\nr_base:\n - 4.4\n" }, { "path": ".github/recipe/variant_r45.yaml", "content": "MACOSX_DEPLOYMENT_TARGET:\n - '11.0'\nc_stdlib_version:\n - if: linux\n then: 2.17\n - if: osx\n then: 11.0\nc_stdlib:\n - if: linux\n then: sysroot\n - if: osx\n then: macosx_deployment_target\nr_base:\n - 4.5\n" }, { "path": ".github/workflows/ci.yml", "content": "name: Continuous Integration\n\non:\n push:\n branches: master\n pull_request:\n paths-ignore:\n - .github/*\n - .gitignore\n - README.md\n\njobs:\n ci_linux-64:\n name: linux-64 CI\n runs-on: ubuntu-latest\n env:\n CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }}\n strategy:\n fail-fast: false\n matrix:\n environment: [\"r44\", \"r45\"]\n\n steps:\n - name: Checkout pull request branch\n uses: actions/checkout@v4\n with:\n fetch-depth: 0\n\n - name: Copy TOML\n run: |\n mkdir /tmp/pixi\n cp ${GITHUB_WORKSPACE}/pixi.toml /tmp/pixi\n\n - name: Setup pixi\n uses: prefix-dev/setup-pixi@v0.9.4\n with:\n run-install: false\n\n - name: Run unit tests\n run: pixi run --environment ${{ matrix.environment }} --manifest-path /tmp/pixi/pixi.toml devtools_test\n\n - name: Run R CMD CHECK\n run: |\n pixi run --environment ${{ matrix.environment }} --manifest-path /tmp/pixi/pixi.toml build\n pixi run --environment ${{ matrix.environment }} --manifest-path /tmp/pixi/pixi.toml rcmdcheck\n\n - name: Check unit test code coverage\n if: ${{ matrix.environment == 'r44' }}\n run: pixi run --environment ${{ matrix.environment }} --manifest-path /tmp/pixi/pixi.toml codecov\n\n ci_osx-arm64:\n name: osx-arm64 CI\n runs-on: macos-latest\n strategy:\n fail-fast: false\n matrix:\n environment: [\"r44\", \"r45\"]\n \n steps:\n - name: Checkout pull request branch\n uses: actions/checkout@v4\n with:\n fetch-depth: 0\n\n - name: Copy TOML\n run: |\n mkdir /tmp/pixi\n cp ${GITHUB_WORKSPACE}/pixi.toml /tmp/pixi\n\n - name: Setup pixi\n uses: prefix-dev/setup-pixi@v0.9.4\n with:\n run-install: false\n\n - name: Run unit tests\n run: pixi run --environment ${{ matrix.environment }} --manifest-path /tmp/pixi/pixi.toml devtools_test\n\n - name: Run R CMD CHECK\n run: |\n pixi run --environment ${{ matrix.environment }} --manifest-path /tmp/pixi/pixi.toml build\n pixi run --environment ${{ matrix.environment }} --manifest-path /tmp/pixi/pixi.toml rcmdcheck\n" }, { "path": ".github/workflows/conda_build.yml", "content": "name: Build conda package\n\non:\n release:\n types: [published]\n workflow_dispatch:\n inputs:\n version:\n description: Version to package\n required: true\n default: 'latest'\n build:\n description: \"Build revision of package (default: 0)\"\n required: false\n default: '0'\n\njobs:\n build_package_linux-64:\n name: Build conda package for linux-64\n runs-on: ubuntu-latest\n strategy:\n fail-fast: false\n matrix:\n variant: [\"r44\", \"r45\"]\n\n env:\n ANACONDA_API_KEY: ${{ secrets.ANACONDA_API_TOKEN }}\n ANACONDA_OWNER: ${{ vars.ANACONDA_OWNER }}\n\n steps:\n - name: Checkout repository\n uses: actions/checkout@v6\n with:\n fetch-depth: 0\n\n - name: Get latest version\n id: latest-version\n if: github.event_name == 'workflow_dispatch' && github.event.inputs.version == 'latest'\n uses: pozetroninc/github-action-get-latest-release@v0.8.0\n with:\n repository: ${{ github.repository }}\n token: ${{ secrets.CI_TOKEN }}\n\n - name: Set version\n id: set-version\n run: |\n if [[ \"${{ github.event_name }}\" == \"release\" ]]; then\n version=\"${{ github.event.release.tag_name }}\"\n elif [[ \"${{ github.event.inputs.version }}\" != \"latest\" ]]; then\n version=\"${{ github.event.inputs.version }}\"\n else\n version=\"${{ steps.latest-version.outputs.release }}\"\n fi\n echo \"version=${version}\" >> \"$GITHUB_OUTPUT\"\n\n - name: Set build number\n id: set-build\n run: |\n if [[ \"${{ github.event_name }}\" == \"release\" ]]; then\n echo \"build=0\" >> \"$GITHUB_OUTPUT\"\n else\n echo \"build=${{ github.event.inputs.build }}\" >> \"$GITHUB_OUTPUT\"\n fi\n\n - name: Download release\n uses: robinraju/release-downloader@v1\n with:\n tag: ${{ steps.set-version.outputs.version }}\n token: ${{ secrets.CI_TOKEN }}\n out-file-path: /tmp/recipe\n tarBall: true\n\n - name: Setup pixi\n uses: prefix-dev/setup-pixi@v0.9.4\n with:\n run-install: false\n\n - name: Create recipe from template\n shell: pixi exec --spec sed --spec coreutils --spec wget -- bash -e {0}\n run: |\n cp .github/recipe/recipe.yaml /tmp/recipe/recipe.yaml\n cp .github/recipe/variant_${{ matrix.variant }}.yaml /tmp/recipe/variants.yaml\n repository=${{ github.repository }}\n build=${{ steps.set-build.outputs.build }}\n version=${{ steps.set-version.outputs.version }}\n sha256sum=$(sha256sum /tmp/recipe/${repository//*\\//}-${version}.tar.gz | cut -d ' ' -f 1)\n sed -i \"s/VERSION_PLACEHOLDER/${version}/g\" /tmp/recipe/recipe.yaml\n sed -i \"s/SHA256SUM_PLACEHOLDER/${sha256sum}/g\" /tmp/recipe/recipe.yaml\n sed -i \"s/BUILD_PLACEHOLDER/${build}/g\" /tmp/recipe/recipe.yaml\n\n - name: Setup up docker buildx\n uses: docker/setup-buildx-action@v4\n\n - name: Build and export docker containers\n uses: docker/build-push-action@v7\n with:\n load: true\n file: .github/rattler-build_container.df\n tags: rattler-build:latest\n\n - name: Build conda packages\n run: |\n docker run --rm --volume /tmp:/tmp \\\n --volume /etc/passwd:/etc/passwd:ro \\\n --volume /etc/group:/etc/group:ro \\\n --volume $(pwd) --workdir $(pwd) \\\n --user $(id -u) rattler-build \\\n rattler-build build -c dnachun -c conda-forge -c bioconda \\\n --output-dir /tmp/rattler-build --recipe-dir /tmp/recipe\n\n - name: Upload package\n shell: pixi exec --spec rattler-build -- bash -e {0}\n run: rattler-build upload anaconda --force /tmp/rattler-build/linux-64/*.conda\n\n build_package_osx-arm64:\n name: Build conda package for osx-arm64\n runs-on: macos-14\n strategy:\n fail-fast: false\n matrix:\n variant: [\"r44\", \"r45\"]\n env:\n ANACONDA_API_KEY: ${{ secrets.ANACONDA_API_TOKEN }}\n ANACONDA_OWNER: ${{ vars.ANACONDA_OWNER }}\n\n steps:\n - name: Checkout repository\n uses: actions/checkout@v6\n with:\n fetch-depth: 0\n\n - name: Get latest version\n id: latest-version\n if: github.event_name == 'workflow_dispatch' && github.event.inputs.version == 'latest'\n uses: pozetroninc/github-action-get-latest-release@v0.8.0\n with:\n repository: ${{ github.repository }}\n token: ${{ secrets.CI_TOKEN }}\n\n - name: Set version\n id: set-version\n run: |\n if [[ \"${{ github.event_name }}\" == \"release\" ]]; then\n version=\"${{ github.event.release.tag_name }}\"\n elif [[ \"${{ github.event.inputs.version }}\" != \"latest\" ]]; then\n version=\"${{ github.event.inputs.version }}\"\n else\n version=\"${{ steps.latest-version.outputs.release }}\"\n fi\n echo \"version=${version}\" >> \"$GITHUB_OUTPUT\"\n\n - name: Set build number\n id: set-build\n run: |\n if [[ \"${{ github.event_name }}\" == \"release\" ]]; then\n echo \"build=0\" >> \"$GITHUB_OUTPUT\"\n else\n echo \"build=${{ github.event.inputs.build }}\" >> \"$GITHUB_OUTPUT\"\n fi\n\n - name: Download release\n uses: robinraju/release-downloader@v1\n with:\n tag: ${{ steps.set-version.outputs.version }}\n token: ${{ secrets.CI_TOKEN }}\n out-file-path: /tmp/recipe\n tarBall: true\n\n - name: Setup pixi\n uses: prefix-dev/setup-pixi@v0.9.4\n with:\n run-install: false\n\n - name: Create recipe from template\n shell: pixi exec --spec sed --spec coreutils --spec wget -- bash -e {0}\n run: |\n cp .github/recipe/recipe.yaml /tmp/recipe/recipe.yaml\n cp .github/recipe/variant_${{ matrix.variant }}.yaml /tmp/recipe/variants.yaml\n repository=${{ github.repository }}\n build=${{ steps.set-build.outputs.build }}\n version=${{ steps.set-version.outputs.version }}\n sha256sum=$(sha256sum /tmp/recipe/${repository//*\\//}-${version}.tar.gz | cut -d ' ' -f 1)\n sed -i \"s/VERSION_PLACEHOLDER/${version}/g\" /tmp/recipe/recipe.yaml\n sed -i \"s/SHA256SUM_PLACEHOLDER/${sha256sum}/g\" /tmp/recipe/recipe.yaml\n sed -i \"s/BUILD_PLACEHOLDER/${build}/g\" /tmp/recipe/recipe.yaml\n\n - name: Build conda package\n shell: pixi exec --spec rattler-build -- bash -e {0}\n run: rattler-build build -c dnachun -c conda-forge -c bioconda --output-dir /tmp/rattler-build --recipe-dir /tmp/recipe\n\n - name: Upload package\n shell: pixi exec --spec rattler-build -- bash -e {0}\n run: rattler-build upload anaconda --force /tmp/rattler-build/osx-arm64/*.conda\n" }, { "path": ".github/workflows/dispatch_pkgdown_build.yml", "content": "name: Deploy website\non:\n push:\n branches: [\"master\"]\n workflow_dispatch:\n\nenv:\n GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}\n\n\npermissions:\n contents: read\n pages: write\n id-token: write\n\nconcurrency:\n group: \"pages\"\n cancel-in-progress: false\n\njobs:\n build:\n runs-on: ubuntu-latest\n steps:\n - name: Checkout master\n uses: actions/checkout@v5\n with:\n ref: master\n\n - name: Setup pixi\n uses: prefix-dev/setup-pixi@v0.9.4\n\n - name: Update pkgdown site\n run: pixi run -e r44 pkgdown_build\n\n - name: Setup Pages\n uses: actions/configure-pages@v5\n\n - name: Upload artifact\n uses: actions/upload-pages-artifact@v5\n with:\n path: ./docs\n\n deploy:\n environment:\n name: github-pages\n url: ${{ steps.deployment.outputs.page_url }}\n runs-on: ubuntu-latest\n needs: build\n steps:\n - name: Deploy to GitHub Pages\n id: deployment\n uses: actions/deploy-pages@v4\n" }, { "path": ".github/workflows/release.yml", "content": "name: Upload new release\n\non:\n push:\n branches: [master]\n paths: [DESCRIPTION]\n workflow_dispatch:\n inputs:\n tag:\n description: Version to use for release tag\n default: auto\n required: true\n commit:\n description: Commit to use for tag\n default: auto\n required: true\n increment_major_version:\n description: Increment major version\n default: false\n required: true\n increment_minor_version:\n description: Increment minor version\n default: false\n required: true\n increment_patch_version:\n description: Increment patch version\n default: true\n required: true\n\n# Prevent duplicate releases when manual dispatch pushes a version commit\nconcurrency:\n group: release\n cancel-in-progress: false\n\njobs:\n # Only runs on manual dispatch to bump version in DESCRIPTION\n update_version:\n outputs:\n commit: ${{ steps.commit-changes.outputs.commit_long_sha }}\n runs-on: ubuntu-latest\n if: github.event_name == 'workflow_dispatch' && github.event.inputs.commit == 'auto'\n steps:\n - name: Checkout repository\n uses: actions/checkout@v6\n with:\n token: ${{ secrets.CI_TOKEN }}\n fetch-depth: 0\n repository: ${{ github.repository }}\n ref: master\n\n - name: Setup pixi\n uses: prefix-dev/setup-pixi@v0.9.4\n\n - name: Update version\n run: |\n if [[ \"${{ github.event.inputs.tag }}\" != \"auto\" ]]; then\n sed -i 's/Version: .*$/Version: ${{ github.event.inputs.tag }}/' DESCRIPTION\n elif [[ \"${{ github.event.inputs.increment_major_version }}\" == \"true\" ]]; then\n pixi run use_major_version\n elif [[ \"${{ github.event.inputs.increment_minor_version }}\" == \"true\" ]]; then\n pixi run use_minor_version\n elif [[ \"${{ github.event.inputs.increment_patch_version }}\" == \"true\" ]]; then\n pixi run use_patch_version\n fi\n\n - name: Commit changes to version\n id: commit-changes\n uses: EndBug/add-and-commit@v10\n with:\n push: true\n message: Update version\n\n # Creates tag + GitHub release — runs for both push and manual triggers\n create_release:\n needs: update_version\n # Run when update_version succeeds (manual) or is skipped (push trigger)\n if: always() && (needs.update_version.result == 'success' || needs.update_version.result == 'skipped')\n runs-on: ubuntu-latest\n permissions:\n contents: write\n steps:\n - name: Determine commit\n id: determine-commit\n run: |\n if [[ \"${{ github.event_name }}\" == \"push\" ]]; then\n echo \"commit=${{ github.sha }}\" >> \"$GITHUB_OUTPUT\"\n elif [[ \"${{ github.event.inputs.commit }}\" != \"auto\" ]]; then\n echo \"commit=${{ github.event.inputs.commit }}\" >> \"$GITHUB_OUTPUT\"\n else\n echo \"commit=${{ needs.update_version.outputs.commit }}\" >> \"$GITHUB_OUTPUT\"\n fi\n\n - name: Checkout\n uses: actions/checkout@v6\n with:\n ref: ${{ steps.determine-commit.outputs.commit }}\n fetch-depth: 0\n\n - name: Set tag from DESCRIPTION\n id: set-tag\n run: |\n if [[ \"${{ github.event_name }}\" == \"workflow_dispatch\" && \"${{ github.event.inputs.tag }}\" != \"auto\" ]]; then\n tag=\"${{ github.event.inputs.tag }}\"\n else\n tag=$(grep \"^Version:\" DESCRIPTION | sed 's/Version: *//')\n fi\n echo \"tag=${tag}\" >> \"$GITHUB_OUTPUT\"\n\n - name: Check if tag already exists\n id: check-tag\n run: |\n if git rev-parse \"refs/tags/${{ steps.set-tag.outputs.tag }}\" >/dev/null 2>&1; then\n echo \"exists=true\" >> \"$GITHUB_OUTPUT\"\n echo \"::notice::Tag ${{ steps.set-tag.outputs.tag }} already exists — skipping release\"\n else\n echo \"exists=false\" >> \"$GITHUB_OUTPUT\"\n fi\n\n - name: Check if major or minor version changed\n id: check-version-change\n run: |\n # Strip optional v prefix so legacy v-prefixed tags compare correctly\n new_version=\"${{ steps.set-tag.outputs.tag }}\"\n new_version=\"${new_version#v}\"\n new_major_minor=$(echo \"$new_version\" | cut -d. -f1,2)\n\n # Normalize all tags (strip v) before version-sorting, otherwise\n # git's v:refname sort ranks v-prefixed tags ahead of plain ones.\n latest_tag=$(git tag | sed 's/^v//' | sort -V | tail -n1 || echo \"\")\n\n if [[ -z \"$latest_tag\" ]]; then\n echo \"No existing tags found — treating as new release\"\n echo \"is_major_minor=true\" >> \"$GITHUB_OUTPUT\"\n else\n latest_major_minor=$(echo \"$latest_tag\" | cut -d. -f1,2)\n if [[ \"$new_major_minor\" != \"$latest_major_minor\" ]]; then\n echo \"Major/minor version changed: $latest_major_minor -> $new_major_minor\"\n echo \"is_major_minor=true\" >> \"$GITHUB_OUTPUT\"\n else\n echo \"::notice::Only patch version changed ($latest_tag -> $new_version) — skipping release\"\n echo \"is_major_minor=false\" >> \"$GITHUB_OUTPUT\"\n fi\n fi\n\n - name: Create new tag\n if: steps.check-tag.outputs.exists == 'false' && steps.check-version-change.outputs.is_major_minor == 'true'\n id: tag-version\n uses: mathieudutour/github-tag-action@v6.2\n with:\n default_bump: false\n default_prerelease_bump: false\n github_token: ${{ secrets.GITHUB_TOKEN }}\n custom_tag: ${{ steps.set-tag.outputs.tag }}\n commit_sha: ${{ steps.determine-commit.outputs.commit }}\n tag_prefix: \"\"\n\n - name: Create a GitHub release\n if: steps.check-tag.outputs.exists == 'false' && steps.check-version-change.outputs.is_major_minor == 'true'\n uses: ncipollo/release-action@v1\n with:\n tag: ${{ steps.set-tag.outputs.tag }}\n name: Release ${{ steps.set-tag.outputs.tag }}\n generateReleaseNotes: true\n" }, { "path": ".gitignore", "content": "**/.Rhistory\n**/.DS_Store\n**/.Rapp.history\n**/.ipynb_checkpoints\n**/.virtual_documents\nsusieR.Rproj\n.Rproj.user\n.RData\n.Ruserdata\n.pixi/\nRplots.pdf\ndocs\npixi.lock\n**/*.html\n**/*.so\n**/*.o\nsusieR.Rcheck\n**/.*.swp\n**/.*.swo\n" }, { "path": "DESCRIPTION", "content": "Encoding: UTF-8\nType: Package\nPackage: susieR\nTitle: Sum of Single Effects Linear Regression\nDescription: Implements methods for variable selection in linear\n regression based on the \"Sum of Single Effects\" (SuSiE) model, as\n described in Wang et al (2020) and Zou et al\n (2021) . These methods provide\n simple summaries, called \"Credible Sets\", for accurately\n quantifying uncertainty in which variables should be selected.\n The methods are motivated by genetic fine-mapping applications,\n and are particularly well-suited to settings where variables are\n highly correlated and detectable effects are sparse. The fitting\n algorithm, a Bayesian analogue of stepwise selection methods\n called \"Iterative Bayesian Stepwise Selection\" (IBSS), is simple\n and fast, allowing the SuSiE model be fit to large data sets\n (thousands of samples and hundreds of thousands of variables).\nDate: 2026-04-24\nVersion: 0.16.1\nAuthors@R: c(person(\"Gao\",\"Wang\",role=\"aut\",email=\"wang.gao@columbia.edu\"),\n person(\"Yuxin\",\"Zou\",role=\"aut\"),\n person(\"Alexander\",\"McCreight\",role=\"aut\"),\n person(\"Kaiqian\",\"Zhang\",role=\"aut\"),\n person(\"William\",\"R.P. Denault\",role=\"aut\"),\n person(\"Peter\",\"Carbonetto\",role=c(\"aut\",\"cre\"),\n email=\"peter.carbonetto@gmail.com\"),\n\t person(\"Matthew\",\"Stephens\",role=\"aut\"))\nURL: https://github.com/stephenslab/susieR\nBugReports: https://github.com/stephenslab/susieR/issues\nLicense: BSD_3_clause + file LICENSE\nDepends: R (>= 3.0.2)\nImports:\n methods,\n graphics,\n grDevices,\n stats,\n Matrix,\n matrixStats,\n mixsqp,\n reshape,\n crayon,\n ggplot2\nLinkingTo:\n cpp11,\n cpp11armadillo\nSuggests:\n curl,\n pkgload,\n rprojroot,\n testthat,\n microbenchmark,\n knitr,\n rmarkdown,\n Rfast,\n cowplot,\n L0Learn\nLazyData: yes\nLazyDataCompression: xz\nNeedsCompilation: yes\nRoxygenNote: 7.3.3\nVignetteBuilder: knitr\n" }, { "path": "LICENSE", "content": "YEAR: 2017-2022\nCOPYRIGHT HOLDER: Gao Wang, Peter Carbonetto, Yuxin Zou, Kaiqian Zhang, Matthew Stephens\nORGANIZATION: Gao Wang, Peter Carbonetto, Yuxin Zou, Kaiqian Zhang, Matthew Stephens" }, { "path": "LICENSE.md", "content": "Copyright (c) 2017-2022, Gao Wang, Peter Carbonetto, Yuxin Zou, Kaiqian Zhang, \nMatthew Stephens. \nAll rights reserved. \n\nRedistribution and use in source and binary forms, with or without \nmodification, are permitted provided that the following conditions are met: \n\n * Redistributions of source code must retain the above copyright notice, \n this list of conditions and the following disclaimer. \n * Redistributions in binary form must reproduce the above copyright \n notice, this list of conditions and the following disclaimer in the \n documentation and/or other materials provided with the distribution. \n * Neither the name of Gao Wang, Peter Carbonetto, Yuxin Zou, Kaiqian \n Zhang, Matthew Stephens, nor the names of its contributors may be used \n to endorse or promote products derived from this software without \n specific prior written permission. \n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS \"AS IS\" \nAND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE \nIMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE \nARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE \nLIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR \nCONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF \nSUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS \nINTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN \nCONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) \nARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE \nPOSSIBILITY OF SUCH DAMAGE.\n" }, { "path": "Makefile", "content": "# Makefile for susieR package\n.PHONY: all install document test test-coverage pkgdown lint style clean deep-clean check check-cran\n\n# Default target\nall: document install\n\n## Install the package\ninstall: document\n\t@echo \"Installing package...\"\n\t@Rscript -e \"devtools::install('.', quiet = TRUE, upgrade = FALSE, build = FALSE)\"\n\n## Document the package (properly handling Rcpp compilation)\ndocument:\n\t@echo \"Ensuring DESCRIPTION has final newline...\"\n\t@Rscript -e \"lines <- readLines('DESCRIPTION'); writeLines(lines, 'DESCRIPTION')\"\n\t@echo \"Creating minimal NAMESPACE if missing...\"\n\t@test -f NAMESPACE || ( echo \"# Generated by roxygen2: do not edit by hand\" > NAMESPACE && \\\n\t\techo \"\" >> NAMESPACE ) \n\t@echo \"Regenerating Rcpp exports...\"\n\t@Rscript -e \"Rcpp::compileAttributes('.')\"\n\t@echo \"Compiling shared library...\"\n\t@Rscript -e \"pkgbuild::compile_dll('.')\"\n\t@echo \"Documenting with roxygen2...\"\n\t@Rscript -e \"roxygen2::roxygenise('.', clean = TRUE)\"\n\n## Run tests\ntest:\n\t@echo \"Running tests...\"\n\t@Rscript -e \"devtools::test('.')\"\n\n## Test with coverage\ntest-coverage:\n\t@echo \"Running tests with coverage...\"\n\t@Rscript -e \"covr::package_coverage('.')\"\n\n## Build pkgdown site\npkgdown: document\n\t@echo \"Building pkgdown site...\"\n\t@Rscript -e \"pkgdown::clean_site('.')\"\n\t@Rscript -e \"pkgdown::init_site('.')\"\n\t@Rscript -e \"pkgdown::build_site('.', lazy = FALSE)\"\n\npkgdown-lazy: document\n\t@echo \"Building pkgdown site (lazy mode - only changed pages)...\"\n\t@Rscript -e \"pkgdown::build_site('.', lazy = TRUE)\"\n\n## Run lintr\nlint:\n\t@echo \"Running lintr...\"\n\t@Rscript -e \"lintr::lint_package('.')\"\n\n## Format code with styler\nstyle:\n\t@echo \"Styling code...\"\n\t@Rscript -e \"styler::style_pkg('.')\"\n\n## Basic check\ncheck: document\n\t@echo \"Running basic checks...\"\n\t@Rscript -e \"devtools::check('.', document = FALSE)\"\n\n## Run CRAN check\ncheck-cran: document\n\t@echo \"Running CRAN checks...\"\n\t@Rscript -e \"devtools::check('.', cran = TRUE, document = FALSE)\"\n\n## Clean generated files (KEEP NAMESPACE to avoid issues)\nclean:\n\t@echo \"Cleaning generated files...\"\n\t@rm -f src/*.o src/*.so src/*.dll\n\t@rm -f src/RcppExports.cpp R/RcppExports.R\n\t@rm -rf man\n\t@rm -f src/symbols.rds\n\t@rm -rf *.tar.gz *.Rcheck\n\t@echo \"Clean complete (NAMESPACE preserved)\"\n\n## Deep clean (removes everything including NAMESPACE)\ndeep-clean:\n\t@echo \"Deep cleaning all generated files...\"\n\t@rm -f src/*.o src/*.so src/*.dll\n\t@rm -f src/RcppExports.cpp R/RcppExports.R\n\t@rm -rf man\n\t@rm -f NAMESPACE\n\t@rm -f src/symbols.rds\n\t@rm -rf *.tar.gz *.Rcheck\n\t@rm -rf .Rhistory .RData .Rproj.user\n\t@rm -rf docs\n\t@rm -rf inst/doc vignettes/*.html vignettes/*.R\n\t@echo \"Deep clean complete\"\n\n## Quick development workflow (when NAMESPACE exists)\nquick: \n\t@echo \"Quick rebuild (assumes NAMESPACE exists)...\"\n\t@Rscript -e \"Rcpp::compileAttributes('.')\"\n\t@Rscript -e \"devtools::install('.', quick = TRUE, upgrade = FALSE)\"\n\n## Load package for interactive use\nload:\n\t@echo \"Loading package...\"\n\t@Rscript -e \"devtools::load_all('.')\"\n\n## Help\nhelp:\n\t@echo \"susieR Makefile\"\n\t@echo \"\"\n\t@echo \"Main targets:\"\n\t@echo \" make - Document and install (default)\"\n\t@echo \" make document - Generate documentation (creates NAMESPACE if needed)\"\n\t@echo \" make install - Install package\"\n\t@echo \" make test - Run tests\"\n\t@echo \" make test-coverage - Test coverage report\"\n\t@echo \" make pkgdown - Build pkgdown site\"\n\t@echo \" make lint - Run lintr\"\n\t@echo \" make style - Format code with styler\"\n\t@echo \" make check - Run R CMD check\"\n\t@echo \" make check-cran - Run CRAN check\"\n\t@echo \"\"\n\t@echo \"Maintenance:\"\n\t@echo \" make clean - Remove generated files (keeps NAMESPACE)\"\n\t@echo \" make deep-clean - Remove ALL generated files\"\n\t@echo \"\"\n\t@echo \"Quick targets:\"\n\t@echo \" make quick - Quick rebuild (when NAMESPACE exists)\"\n\t@echo \" make load - Load package for interactive use\"\n" }, { "path": "NAMESPACE", "content": "# Generated by roxygen2: do not edit by hand\n\nS3method(coef,mr.ash)\nS3method(coef,susie)\nS3method(get_objective,default)\nS3method(ibss_initialize,default)\nS3method(post_loglik_prior_hook,default)\nS3method(pre_loglik_prior_hook,default)\nS3method(predict,mr.ash)\nS3method(predict,susie)\nS3method(print,slot_prior)\nS3method(print,summary.susie)\nS3method(print,summary.susie_post_outcome_configuration)\nS3method(summary,susie)\nS3method(summary,susie_post_outcome_configuration)\nexport(absolute.order)\nexport(block_coordinate_ascent)\nexport(calc_z)\nexport(coef.mr.ash)\nexport(coef.susie)\nexport(compute_marginal_bhat_shat)\nexport(compute_suff_stat)\nexport(estimate_s_rss)\nexport(get.full.posterior)\nexport(get_cs_correlation)\nexport(get_objective)\nexport(ibss_finalize)\nexport(ibss_initialize)\nexport(is_symmetric_matrix)\nexport(kriging_rss)\nexport(mr.ash)\nexport(mr.ash.rss)\nexport(path.order)\nexport(post_loglik_prior_hook)\nexport(pre_loglik_prior_hook)\nexport(predict.mr.ash)\nexport(predict.susie)\nexport(print.summary.susie)\nexport(print.summary.susie_post_outcome_configuration)\nexport(slot_prior_betabinom)\nexport(slot_prior_poisson)\nexport(summary.susie)\nexport(summary.susie_post_outcome_configuration)\nexport(susie)\nexport(susie_auto)\nexport(susie_get_cs)\nexport(susie_get_lfsr)\nexport(susie_get_niter)\nexport(susie_get_objective)\nexport(susie_get_pip)\nexport(susie_get_posterior_mean)\nexport(susie_get_posterior_samples)\nexport(susie_get_posterior_sd)\nexport(susie_get_prior_variance)\nexport(susie_get_residual_variance)\nexport(susie_init_coef)\nexport(susie_plot)\nexport(susie_plot_changepoint)\nexport(susie_plot_iteration)\nexport(susie_post_outcome_configuration)\nexport(susie_rss)\nexport(susie_rss_lambda)\nexport(susie_ss)\nexport(susie_trendfilter)\nexport(susie_workhorse)\nexport(univar.order)\nexport(univariate_regression)\nimportFrom(Matrix,colMeans)\nimportFrom(Matrix,colSums)\nimportFrom(Matrix,crossprod)\nimportFrom(Matrix,forceSymmetric)\nimportFrom(Matrix,rowSums)\nimportFrom(Matrix,sparseMatrix)\nimportFrom(Matrix,summary)\nimportFrom(Matrix,t)\nimportFrom(Matrix,tcrossprod)\nimportFrom(Rfast,colVars)\nimportFrom(crayon,blue)\nimportFrom(crayon,bold)\nimportFrom(crayon,combine_styles)\nimportFrom(crayon,cyan)\nimportFrom(crayon,green)\nimportFrom(crayon,has_color)\nimportFrom(crayon,magenta)\nimportFrom(crayon,silver)\nimportFrom(crayon,yellow)\nimportFrom(ggplot2,.data)\nimportFrom(ggplot2,aes)\nimportFrom(ggplot2,aes_string)\nimportFrom(ggplot2,annotate)\nimportFrom(ggplot2,geom_abline)\nimportFrom(ggplot2,geom_col)\nimportFrom(ggplot2,geom_line)\nimportFrom(ggplot2,geom_point)\nimportFrom(ggplot2,ggplot)\nimportFrom(ggplot2,ggtitle)\nimportFrom(ggplot2,labs)\nimportFrom(ggplot2,theme_bw)\nimportFrom(ggplot2,theme_classic)\nimportFrom(grDevices,dev.off)\nimportFrom(grDevices,pdf)\nimportFrom(graphics,legend)\nimportFrom(graphics,par)\nimportFrom(graphics,plot)\nimportFrom(graphics,points)\nimportFrom(graphics,segments)\nimportFrom(matrixStats,colSds)\nimportFrom(methods,as)\nimportFrom(mixsqp,mixsqp)\nimportFrom(reshape,melt)\nimportFrom(stats,.lm.fit)\nimportFrom(stats,coef)\nimportFrom(stats,cor)\nimportFrom(stats,dnorm)\nimportFrom(stats,lm)\nimportFrom(stats,median)\nimportFrom(stats,optim)\nimportFrom(stats,optimize)\nimportFrom(stats,pnorm)\nimportFrom(stats,predict)\nimportFrom(stats,rmultinom)\nimportFrom(stats,rnorm)\nimportFrom(stats,sd)\nimportFrom(stats,summary.lm)\nimportFrom(stats,var)\nimportFrom(utils,head)\nimportFrom(utils,modifyList)\nuseDynLib(susieR, .registration = TRUE)\n" }, { "path": "R/cpp11.R", "content": "# Generated by cpp11: do not edit by hand\n\nrandom_order <- function(p, numiter) {\n .Call(`_susieR_random_order`, p, numiter)\n}\n\ncaisa_cpp <- function(X, w, sa2, pi_init, beta_init, r_init, sigma2, o_r, maxiter, miniter, convtol, epstol, method_q, updatepi, updatesigma, verbose) {\n .Call(`_susieR_caisa_cpp`, X, w, sa2, pi_init, beta_init, r_init, sigma2, o_r, maxiter, miniter, convtol, epstol, method_q, updatepi, updatesigma, verbose)\n}\n\nmr_ash_rss_cpp <- function(bhat, shat, z, R, var_y, n, sigma2_e, s0, w0, mu1_init, tol, max_iter, update_w0, update_sigma, compute_ELBO, standardize) {\n .Call(`_susieR_mr_ash_rss_cpp`, bhat, shat, z, R, var_y, n, sigma2_e, s0, w0, mu1_init, tol, max_iter, update_w0, update_sigma, compute_ELBO, standardize)\n}\n" }, { "path": "R/diagnosis_reports.R", "content": "# Diagnostic functions for SuSiE-ash filter\n#\n# Per-iteration functions (called from susie_utils.R, return data.frame):\n# diagnose_bb_ash_iter() - BB+ash code path\n# diagnose_ash_filter_archived_iter() - V0 code path\n#\n# Post-run helpers (called via susieR:::):\n# collect_ash_diag(fit) - rbind all iterations into ML table\n# label_diag_truth(df, fit, causal) - add TP/FP labels\n# add_delta_features(df) - add per-slot change-over-iteration features\n# extract_bb_ash_features(fit, X, causal) - quick feature extraction from converged fit\n# compare_ash_methods(df1, df2) - side-by-side comparison\n#\n# Usage example:\n# fit <- susie(X, y, L=10, slot_prior=slot_prior_betabinom(),\n# unmappable_effects=\"ash\", max_iter=50)\n# df <- susieR:::collect_ash_diag(fit)\n# df <- susieR:::label_diag_truth(df, fit, causal)\n# df <- susieR:::add_delta_features(df)\n#\n# # ML analysis: per-slot, per-iteration features with TP/FP labels\n# # Key columns: iter, slot, c_hat, lbf, purity, V, max_alpha,\n# # alpha_entropy, mask_tier, collision, ever_uncertain, ...\n# # Delta columns: delta_c_hat, delta_V, delta_lbf, delta_max_alpha, ...\n# # (change from previous iteration for the same slot)\n# #\n# # For 4-way comparison (BB+ash/V0 x mrash/no-mrash):\n# # options(susie.skip_mrash = TRUE) # toggle mr.ash off\n# # fit_nomrash <- susie(...)\n# # options(susie.skip_mrash = FALSE) # restore\n#\n# Data.frames accumulated on fit$.diag_env$history during the run.\n# Debug flag .ash_debug in susie_utils.R (TRUE = on, never turn off).\n\n\n#' BB+ash per-iteration diagnostic\n#'\n#' @return data.frame with one row per slot, all features\n#' @keywords internal\ndiagnose_bb_ash_iter <- function(model, Xcorr, mask, b_confident,\n sentinels, sentinel_collision,\n is_confident_now, is_trusted,\n emerging_slots, active_slots, c_hat,\n ash_result, p,\n high_chat = NULL, low_chat = NULL,\n # Tunable parameters (captured for reproducibility)\n collision_threshold = 0.9,\n purity_threshold = 0.5,\n masking_threshold = 0.5,\n nPIP_threshold = 0.05,\n c_hat_excess_threshold = 0.2,\n alpha_entropy_threshold = log(5),\n slot_prior = NULL,\n mask_smoothness = NULL,\n mask_amount = NULL,\n mask_concentration = NULL,\n mask_burnin = NULL,\n mask_spread_pip_at_sent = NULL,\n mask_pip_prot_at_sent = NULL) {\n L <- nrow(model$alpha)\n theta_raw <- ash_result$beta\n theta_masked <- theta_raw\n theta_masked[mask] <- 0\n cs_coverage <- 0.9\n iter <- model$ash_iter\n\n rows <- list()\n for (l in seq_len(L)) {\n sent <- sentinels[l]\n alpha_l <- model$alpha[l, ]\n max_a <- max(alpha_l)\n\n # Purity and CS size\n cs_order <- order(alpha_l, decreasing = TRUE)\n cs_size <- min(which(cumsum(alpha_l[cs_order]) >= cs_coverage))\n if (cs_size > 1 && l %in% active_slots) {\n cs_idx <- cs_order[1:cs_size]\n pur <- min(abs(Xcorr[cs_idx, cs_idx]))\n } else if (cs_size == 1) {\n pur <- 1.0\n } else {\n pur <- 0.0\n }\n\n # Status\n status <- if (is_trusted[l]) \"trusted\"\n else if (is_confident_now[l] && model$ever_uncertain[l]) \"conf_unc\"\n else if (is_confident_now[l]) \"confident\"\n else if (sentinel_collision[l]) \"collide\"\n else if (model$V[l] == 0) \"null\"\n else \"emerging\"\n\n # Mask tier (key c_hat feature)\n mask_tier <- if (is_trusted[l]) \"trusted\"\n else if (!is.null(high_chat) && l %in% high_chat) \"high_chat\"\n else if (!is.null(low_chat) && l %in% low_chat) \"low_chat\"\n else \"unknown\"\n\n # Max cross-sentinel |r| (collision strength)\n max_cross_r <- 0\n if (sent > 0 && length(active_slots) > 1) {\n other_sents <- sentinels[setdiff(active_slots, l)]\n other_sents <- other_sents[other_sents > 0]\n if (length(other_sents) > 0)\n max_cross_r <- max(abs(Xcorr[sent, other_sents]))\n }\n\n # Sentinel change\n prev_sent_l <- if (!is.null(model$prev_sentinel)) model$prev_sentinel[l] else 0L\n sent_changed <- (prev_sent_l > 0) && (sent != prev_sent_l)\n\n # Theta at sentinel\n theta_at_sent <- if (sent > 0) theta_masked[sent] else 0\n theta_raw_at_sent <- if (sent > 0) theta_raw[sent] else 0\n\n # Alpha entropy (low = concentrated, possibly FP)\n alpha_nz <- alpha_l[alpha_l > 1e-10]\n alpha_entropy <- -sum(alpha_nz * log(alpha_nz))\n\n # Number of colliding partners\n n_colliding <- 0\n if (sent > 0 && length(active_slots) > 1) {\n other_sents <- sentinels[setdiff(active_slots, l)]\n other_sents <- other_sents[other_sents > 0]\n if (length(other_sents) > 0)\n n_colliding <- sum(abs(Xcorr[sent, other_sents]) > 0.9)\n }\n\n # Per-slot mu properties\n mu_l <- model$mu[l, ]\n mu_at_sent <- if (sent > 0) mu_l[sent] else 0\n max_abs_mu <- max(abs(mu_l))\n\n # c_hat relative to prior: how much evidence beyond the prior expectation\n # For BB: prior_log_odds = log(a + k_others) - log(b + L-1 - k_others)\n # c_hat_null = sigmoid(prior_log_odds), c_hat_excess = c_hat - c_hat_null\n # Prior params read from model$slot_prior (set during susie init)\n c_hat_null_l <- NA\n c_hat_excess_l <- NA\n if (!is.null(model$slot_weights) && !is.null(slot_prior) &&\n !is.null(slot_prior$a_beta)) {\n sw <- model$slot_weights\n k_others <- sum(sw[-l])\n prior_lo <- log(slot_prior$a_beta + k_others) -\n log(slot_prior$b_beta + L - 1 - k_others)\n c_hat_null_l <- 1 / (1 + exp(-prior_lo))\n c_hat_excess_l <- c_hat[l] - c_hat_null_l\n }\n\n rows[[l]] <- data.frame(\n method = \"bb_ash\", iter = iter, slot = l,\n sentinel = sent, purity = pur, V = model$V[l],\n c_hat = c_hat[l], c_hat_null = c_hat_null_l, c_hat_excess = c_hat_excess_l,\n lbf = if (!is.null(model$lbf)) model$lbf[l] else NA,\n max_alpha = max_a, cs_size = cs_size,\n alpha_entropy = alpha_entropy,\n is_confident = is_confident_now[l],\n is_trusted = is_trusted[l],\n status = status, mask_tier = mask_tier,\n was_low_chat = if (!is.null(model$was_low_chat)) model$was_low_chat[l] else FALSE,\n was_exposed = if (!is.null(model$was_exposed)) model$was_exposed[l] else FALSE,\n collision = sentinel_collision[l],\n ever_uncertain = model$ever_uncertain[l],\n n_colliding = n_colliding,\n max_cross_r = max_cross_r,\n sent_changed = sent_changed,\n prev_sentinel = prev_sent_l,\n mu_at_sent = mu_at_sent,\n max_abs_mu = max_abs_mu,\n theta_at_sent = theta_at_sent,\n theta_raw_at_sent = theta_raw_at_sent,\n mask_size = sum(mask), mask_frac = round(sum(mask) / p, 3),\n n_active = length(active_slots),\n n_trusted = sum(is_trusted),\n n_high_chat = if (!is.null(high_chat)) length(high_chat) else NA,\n n_low_chat = if (!is.null(low_chat)) length(low_chat) else NA,\n C_hat = round(sum(c_hat), 1),\n sigma2 = ash_result$sigma2,\n pi0 = if (!is.null(ash_result$pi)) ash_result$pi[1] else NA,\n theta_ss = sum(theta_masked^2),\n theta_raw_ss = sum(theta_raw^2),\n b_conf_ss = sum(b_confident^2),\n b_conf_max = max(abs(b_confident)),\n sent_masked = if (sent > 0) mask[sent] else FALSE,\n skip_mrash = getOption(\"susie.skip_mrash\", FALSE),\n # Rule activation: which decision rules kicked in for this slot\n rule_active_gate = (l %in% active_slots),\n rule_collision = sentinel_collision[l],\n rule_jump = model$ever_uncertain[l] && !sentinel_collision[l],\n rule_trusted = is_trusted[l],\n rule_low_chat = if (!is.null(model$was_low_chat)) model$was_low_chat[l] else FALSE,\n rule_high_chat_pip = (!is.null(high_chat) && l %in% high_chat),\n rule_low_chat_sentinel = (!is.null(low_chat) && l %in% low_chat &&\n !(if (!is.null(model$was_exposed)) model$was_exposed[l] else FALSE)),\n rule_exposed = if (!is.null(model$was_exposed)) model$was_exposed[l] else FALSE,\n # Tunable parameter values\n param_collision_threshold = collision_threshold,\n param_purity_threshold = purity_threshold,\n param_masking_threshold = masking_threshold,\n param_nPIP_threshold = nPIP_threshold,\n param_c_hat_excess_threshold = c_hat_excess_threshold,\n param_alpha_entropy_threshold = alpha_entropy_threshold,\n # Unified mask diagnostics\n smoothness = if (!is.null(mask_smoothness)) mask_smoothness[l] else NA,\n amount = if (!is.null(mask_amount)) mask_amount[l] else NA,\n concentration = if (!is.null(mask_concentration)) mask_concentration[l] else NA,\n burnin = if (!is.null(mask_burnin)) mask_burnin[l] else NA,\n spread_pip_at_sent = if (!is.null(mask_spread_pip_at_sent) && sent > 0) mask_spread_pip_at_sent[l] else NA,\n pip_prot_at_sent = if (!is.null(mask_pip_prot_at_sent) && sent > 0) mask_pip_prot_at_sent[l] else NA,\n stringsAsFactors = FALSE\n )\n }\n do.call(rbind, rows)\n}\n\n\n#' V0 archived filter per-iteration diagnostic\n#'\n#' @return data.frame with one row per slot, all features\n#' @keywords internal\ndiagnose_ash_filter_archived_iter <- function(model, Xcorr, masked,\n b_confident, sentinels,\n effect_purity, current_case,\n current_collision,\n mrash_output) {\n L <- nrow(model$alpha)\n p <- ncol(model$alpha)\n theta_raw <- mrash_output$beta\n theta_masked <- theta_raw\n theta_masked[masked] <- 0\n cs_coverage <- 0.9\n iter <- model$ash_iter\n\n is_active <- sapply(seq_len(L), function(l) {\n max(model$alpha[l, ]) - min(model$alpha[l, ]) >= 5e-5\n })\n\n rows <- list()\n for (l in seq_len(L)) {\n sent <- sentinels[l]\n alpha_l <- model$alpha[l, ]\n max_a <- max(alpha_l)\n cs_order <- order(alpha_l, decreasing = TRUE)\n cs_size <- min(which(cumsum(alpha_l[cs_order]) >= cs_coverage))\n case_str <- if (!is.na(current_case[l])) paste0(\"C\", current_case[l]) else \"inactive\"\n\n # Max cross-sentinel |r|\n max_cross_r <- 0\n active_idx <- which(is_active)\n if (sent > 0 && length(active_idx) > 1) {\n other_sents <- sentinels[setdiff(active_idx, l)]\n other_sents <- other_sents[other_sents > 0]\n if (length(other_sents) > 0)\n max_cross_r <- max(abs(Xcorr[sent, other_sents]))\n }\n\n # Sentinel change\n prev_sent_l <- if (!is.null(model$prev_sentinel)) model$prev_sentinel[l] else 0L\n sent_changed <- (prev_sent_l > 0) && (sent != prev_sent_l)\n\n # Theta at sentinel\n theta_at_sent <- if (sent > 0) theta_masked[sent] else 0\n theta_raw_at_sent <- if (sent > 0) theta_raw[sent] else 0\n\n # Alpha entropy\n alpha_nz <- alpha_l[alpha_l > 1e-10]\n alpha_entropy <- -sum(alpha_nz * log(alpha_nz))\n\n # Number of colliding partners\n n_colliding <- 0\n if (sent > 0 && length(active_idx) > 1) {\n other_sents <- sentinels[setdiff(active_idx, l)]\n other_sents <- other_sents[other_sents > 0]\n if (length(other_sents) > 0)\n n_colliding <- sum(abs(Xcorr[sent, other_sents]) > 0.9)\n }\n\n # Per-slot mu properties\n mu_l <- model$mu[l, ]\n mu_at_sent <- if (sent > 0) mu_l[sent] else 0\n max_abs_mu <- max(abs(mu_l))\n\n rows[[l]] <- data.frame(\n method = \"v0\", iter = iter, slot = l,\n sentinel = sent, purity = effect_purity[l], V = model$V[l],\n lbf = model$lbf[l], max_alpha = max_a, cs_size = cs_size,\n alpha_entropy = alpha_entropy,\n status = case_str,\n current_collision = current_collision[l],\n ever_diffuse = model$ever_diffuse[l],\n diffuse_iter_count = if (!is.null(model$diffuse_iter_count)) model$diffuse_iter_count[l] else 0L,\n prev_case = if (!is.null(model$prev_case)) model$prev_case[l] else 0L,\n n_colliding = n_colliding,\n max_cross_r = max_cross_r,\n sent_changed = sent_changed,\n prev_sentinel = prev_sent_l,\n mu_at_sent = mu_at_sent,\n max_abs_mu = max_abs_mu,\n theta_at_sent = theta_at_sent,\n theta_raw_at_sent = theta_raw_at_sent,\n mask_size = sum(masked), mask_frac = round(sum(masked) / p, 3),\n n_active = sum(is_active),\n sigma2 = mrash_output$sigma2,\n pi0 = if (!is.null(mrash_output$pi)) mrash_output$pi[1] else NA,\n theta_ss = sum(theta_masked^2),\n theta_raw_ss = sum(theta_raw^2),\n b_conf_ss = sum(b_confident^2),\n b_conf_max = max(abs(b_confident)),\n sent_masked = if (sent > 0) masked[sent] else FALSE,\n skip_mrash = getOption(\"susie.skip_mrash\", FALSE),\n # Rule activation: which V0 decision rules kicked in\n rule_collision = current_collision[l],\n rule_ever_diffuse = (model$ever_diffuse[l] > 0),\n rule_case1 = (!is.na(current_case[l]) && current_case[l] == 1),\n rule_case2 = (!is.na(current_case[l]) && current_case[l] == 2),\n rule_case3 = (!is.na(current_case[l]) && current_case[l] == 3),\n rule_exposure = (if (!is.null(model$diffuse_iter_count)) model$diffuse_iter_count[l] else 0) >= 2,\n rule_second_chance = if (!is.null(model$second_chance_used)) model$second_chance_used[sent] else FALSE,\n stringsAsFactors = FALSE\n )\n }\n do.call(rbind, rows)\n}\n\n\n# ---- Helper functions for ML analysis ----\n\n#' Collect diagnostic data.frames across iterations\n#'\n#' Call this after running susie() to rbind all per-iteration diagnostics\n#' into a single ML-ready data.frame.\n#'\n#' @param fit SuSiE fit object (must have been run with .ash_debug = TRUE)\n#' @return data.frame with nrow = L * n_ash_iters, or NULL if no diagnostics\n#'\n#' @examples\n#' \\dontrun{\n#' # Full ML pipeline:\n#' data(unmappable_data)\n#' X <- unmappable_data$X; y <- as.vector(unmappable_data$y)\n#' causal <- which(unmappable_data$beta != 0)\n#'\n#' fit <- susie(X, y, L=10, slot_prior=slot_prior_betabinom(),\n#' unmappable_effects=\"ash\", max_iter=50)\n#'\n#' df <- susieR:::collect_ash_diag(fit) # all iterations\n#' df <- susieR:::label_diag_truth(df, fit, causal) # TP/FP labels\n#' df <- susieR:::add_delta_features(df) # temporal features\n#'\n#' # Inspect FP slot across iterations:\n#' subset(df, cs_label == \"FP\", select = c(iter, slot, sentinel,\n#' c_hat, lbf, max_alpha, alpha_entropy, mask_tier, delta_c_hat))\n#'\n#' # 4-way comparison (BB+ash vs V0, with/without mr.ash):\n#' options(susie.skip_mrash = TRUE)\n#' fit_nomrash <- susie(X, y, L=10, slot_prior=slot_prior_betabinom(),\n#' unmappable_effects=\"ash\", max_iter=50)\n#' options(susie.skip_mrash = FALSE)\n#' df_nomrash <- susieR:::collect_ash_diag(fit_nomrash)\n#'\n#' # Decision tree analysis:\n#' # library(rpart)\n#' # last_iter <- df[df$iter == max(df$iter) & df$V > 0, ]\n#' # tree <- rpart(cs_label ~ c_hat + lbf + max_alpha + alpha_entropy +\n#' # purity + mask_tier + delta_c_hat, data = last_iter)\n#' }\n#'\n#' @keywords internal\ncollect_ash_diag <- function(fit) {\n if (!is.null(fit$.diag_env) && !is.null(fit$.diag_env$history)) {\n return(do.call(rbind, fit$.diag_env$history))\n }\n # Fallback to old .diag_history list\n if (!is.null(fit$.diag_history)) {\n return(do.call(rbind, fit$.diag_history))\n }\n return(NULL)\n}\n\n\n#' Label diagnostic table with ground truth TP/FP\n#'\n#' For each slot at the final iteration, check if its CS (if any) contains\n#' a causal variant.\n#'\n#' @param df Diagnostic data.frame (from collect_ash_diag or single iter)\n#' @param fit SuSiE fit object\n#' @param causal Integer vector of causal variant indices\n#' @return df with added 'cs_label' column: \"TP\", \"FP\", or \"-\" (no CS)\n#' @keywords internal\nlabel_diag_truth <- function(df, fit, causal) {\n cs <- fit$sets$cs\n L <- max(df$slot)\n # Map each CS to its owning slot\n cs_slot_map <- rep(NA, L)\n cs_tp_map <- rep(NA, L)\n if (length(cs) > 0) {\n for (i in seq_along(cs)) {\n sent <- cs[[i]][which.max(fit$pip[cs[[i]]])]\n owner <- which.max(fit$alpha[, sent])\n cs_slot_map[owner] <- i\n cs_tp_map[owner] <- any(cs[[i]] %in% causal)\n }\n }\n df$cs_label <- sapply(df$slot, function(l) {\n if (is.na(cs_slot_map[l])) \"-\"\n else if (cs_tp_map[l]) \"TP\"\n else \"FP\"\n })\n df\n}\n\n\n#' Add per-slot delta features (change from previous iteration)\n#'\n#' Computes delta_c_hat, delta_V, delta_lbf, delta_max_alpha,\n#' delta_alpha_entropy, delta_purity for each slot across iterations.\n#' Also adds lag1 features (previous iteration values) and\n#' cumulative features (max c_hat ever, min alpha_entropy ever).\n#' These temporal features help ML models detect trajectories\n#' (e.g., a slot that was strong then weakened = collapse signal).\n#'\n#' @param df data.frame from collect_ash_diag + label_diag_truth\n#' @return df with added delta_, lag1_, and cum_ columns\n#'\n#' @examples\n#' \\dontrun{\n#' df <- susieR:::collect_ash_diag(fit)\n#' df <- susieR:::label_diag_truth(df, fit, causal)\n#' df <- susieR:::add_delta_features(df)\n#' # Now df has delta_c_hat, lag1_c_hat, cum_max_c_hat, etc.\n#' # Use for decision tree: rpart::rpart(cs_label ~ ., data = df_last_iter)\n#' }\n#'\n#' @keywords internal\nadd_delta_features <- function(df) {\n iters <- sort(unique(df$iter))\n slots <- sort(unique(df$slot))\n\n # Features to compute deltas/lags for\n feat_cols <- c(\"c_hat\", \"V\", \"lbf\", \"max_alpha\", \"alpha_entropy\", \"purity\",\n \"mask_size\", \"theta_ss\")\n\n # Initialize new columns\n for (f in feat_cols) {\n df[[paste0(\"delta_\", f)]] <- NA_real_\n df[[paste0(\"lag1_\", f)]] <- NA_real_\n }\n df$cum_max_c_hat <- NA_real_\n df$cum_min_entropy <- NA_real_\n df$cum_max_lbf <- NA_real_\n\n for (s in slots) {\n idx <- which(df$slot == s)\n if (length(idx) < 2) next\n\n slot_df <- df[idx, ]\n for (f in feat_cols) {\n vals <- slot_df[[f]]\n if (all(is.na(vals))) next\n # Delta: current - previous\n delta <- c(NA, diff(vals))\n df[[paste0(\"delta_\", f)]][idx] <- delta\n # Lag1: previous value\n lag1 <- c(NA, vals[-length(vals)])\n df[[paste0(\"lag1_\", f)]][idx] <- lag1\n }\n\n # Cumulative features\n if (\"c_hat\" %in% names(slot_df)) {\n df$cum_max_c_hat[idx] <- cummax(ifelse(is.na(slot_df$c_hat), 0, slot_df$c_hat))\n }\n if (\"alpha_entropy\" %in% names(slot_df)) {\n df$cum_min_entropy[idx] <- cummin(ifelse(is.na(slot_df$alpha_entropy), Inf, slot_df$alpha_entropy))\n }\n if (\"lbf\" %in% names(slot_df)) {\n df$cum_max_lbf[idx] <- cummax(ifelse(is.na(slot_df$lbf), 0, slot_df$lbf))\n }\n }\n\n df\n}\n\n\n#' Compare two diagnostic runs side by side\n#'\n#' Takes two data.frames (from diagnose_bb_ash_iter or\n#' diagnose_ash_filter_archived_iter) at the same iteration\n#' and prints a side-by-side comparison.\n#'\n#' @param df1 First diagnostic data.frame\n#' @param df2 Second diagnostic data.frame\n#' @param label1 Label for first run (e.g., \"BB+ash\")\n#' @param label2 Label for second run (e.g., \"V0\")\n#' @keywords internal\ncompare_ash_methods <- function(df1, df2, label1 = \"Method1\", label2 = \"Method2\") {\n cat(sprintf(\"\\n===== %s vs %s (iter %d) =====\\n\", label1, label2,\n df1$iter[1]))\n cat(sprintf(\" %-20s %12s %12s\\n\", \"Feature\", label1, label2))\n cat(sprintf(\" %s\\n\", strrep(\"-\", 46)))\n cat(sprintf(\" %-20s %12d %12d\\n\", \"mask_size\", df1$mask_size[1], df2$mask_size[1]))\n cat(sprintf(\" %-20s %12d %12d\\n\", \"n_active\", df1$n_active[1], df2$n_active[1]))\n cat(sprintf(\" %-20s %12.4f %12.4f\\n\", \"sigma2\", df1$sigma2[1], df2$sigma2[1]))\n cat(sprintf(\" %-20s %12.2e %12.2e\\n\", \"theta_ss\", df1$theta_ss[1], df2$theta_ss[1]))\n cat(sprintf(\" %-20s %12.2e %12.2e\\n\", \"b_conf_ss\", df1$b_conf_ss[1], df2$b_conf_ss[1]))\n\n # Per-slot comparison for active slots\n active1 <- df1[df1$V > 0 | df1$status != \"null\", ]\n active2 <- df2[df2$V > 0 | df2$status != \"inactive\", ]\n n_show <- max(nrow(active1), nrow(active2))\n\n cat(sprintf(\"\\n Per-slot:\\n\"))\n cat(sprintf(\" %2s | %-5s %5s %6s %5s | %-5s %5s %6s %5s\\n\",\n \"L\", \"Sent1\", \"Pur1\", \"V1\", \"Sta1\", \"Sent2\", \"Pur2\", \"V2\", \"Sta2\"))\n cat(sprintf(\" %s\\n\", strrep(\"-\", 60)))\n\n for (i in seq_len(n_show)) {\n r1 <- if (i <= nrow(active1)) active1[i, ] else NULL\n r2 <- if (i <= nrow(active2)) active2[i, ] else NULL\n l <- if (!is.null(r1)) r1$slot else r2$slot\n cat(sprintf(\" %2d |\", l))\n if (!is.null(r1))\n cat(sprintf(\" %5d %5.3f %6.4f %5s |\", r1$sentinel, r1$purity, r1$V,\n substr(r1$status, 1, 5)))\n else\n cat(sprintf(\" %5s %5s %6s %5s |\", \"-\", \"-\", \"-\", \"-\"))\n if (!is.null(r2))\n cat(sprintf(\" %5d %5.3f %6.4f %5s\", r2$sentinel, r2$purity, r2$V,\n substr(r2$status, 1, 5)))\n else\n cat(sprintf(\" %5s %5s %6s %5s\", \"-\", \"-\", \"-\", \"-\"))\n cat(\"\\n\")\n }\n cat(sprintf(\"==========================================\\n\"))\n}\n\n\n#' Extract ML feature table from a completed BB+ash fit\n#'\n#' Computes per-slot features from the converged model. Call with\n#' susieR:::extract_bb_ash_features(fit, X_or_Xcorr, causal).\n#'\n#' @param fit Completed susie fit (with slot_prior + ash)\n#' @param X Design matrix (used to compute Xcorr if needed)\n#' @param causal Integer vector of true causal indices (for labeling)\n#' @return data.frame with one row per slot, all features + TP/FP label\n#' @keywords internal\nextract_bb_ash_features <- function(fit, X, causal = NULL) {\n L <- nrow(fit$alpha)\n p <- ncol(fit$alpha)\n Xcorr <- cor(X)\n cs_coverage <- 0.9\n\n c_hat <- if (!is.null(fit$c_hat)) fit$c_hat else\n if (!is.null(fit$slot_weights)) fit$slot_weights else rep(1, L)\n\n # Map CS to slots\n cs <- fit$sets$cs\n cs_owner <- rep(NA, L)\n cs_is_tp <- rep(NA, L)\n if (length(cs) > 0) {\n for (i in seq_along(cs)) {\n sent <- cs[[i]][which.max(fit$pip[cs[[i]]])]\n owner <- which.max(fit$alpha[, sent])\n cs_owner[owner] <- i\n if (!is.null(causal))\n cs_is_tp[owner] <- any(cs[[i]] %in% causal)\n }\n }\n\n rows <- list()\n for (l in seq_len(L)) {\n alpha_l <- fit$alpha[l, ]\n sent <- which.max(alpha_l)\n max_a <- max(alpha_l)\n\n # Purity\n cs_order <- order(alpha_l, decreasing = TRUE)\n cs_size <- min(which(cumsum(alpha_l[cs_order]) >= cs_coverage))\n if (cs_size > 1 && fit$V[l] > 0) {\n cs_idx <- cs_order[1:cs_size]\n pur <- min(abs(Xcorr[cs_idx, cs_idx]))\n } else if (cs_size == 1) {\n pur <- 1.0\n } else {\n pur <- 0.0\n }\n\n # Alpha entropy\n alpha_nz <- alpha_l[alpha_l > 1e-10]\n alpha_entropy <- -sum(alpha_nz * log(alpha_nz))\n\n # Max cross-sentinel |r|\n max_cross_r <- 0\n n_colliding <- 0\n active <- which(fit$V > 0)\n if (sent > 0 && length(active) > 1) {\n other_sents <- sapply(setdiff(active, l), function(ll) which.max(fit$alpha[ll, ]))\n other_sents <- other_sents[other_sents > 0]\n if (length(other_sents) > 0) {\n cross_r <- abs(Xcorr[sent, other_sents])\n max_cross_r <- max(cross_r)\n n_colliding <- sum(cross_r > 0.9)\n }\n }\n\n # Theta at sentinel\n theta_at_sent <- if (!is.null(fit$theta) && sent > 0) fit$theta[sent] else 0\n\n # CS label\n cs_label <- if (is.na(cs_owner[l])) \"-\"\n else if (!is.null(causal) && cs_is_tp[l]) \"TP\"\n else if (!is.null(causal)) \"FP\"\n else paste0(\"CS\", cs_owner[l])\n\n rows[[l]] <- data.frame(\n slot = l, sentinel = sent, purity = pur, V = fit$V[l],\n c_hat = c_hat[l],\n lbf = if (!is.null(fit$lbf)) fit$lbf[l] else NA,\n max_alpha = max_a, cs_size = cs_size,\n alpha_entropy = alpha_entropy,\n max_cross_r = max_cross_r, n_colliding = n_colliding,\n theta_at_sent = theta_at_sent,\n n_active = length(active),\n cs_label = cs_label,\n stringsAsFactors = FALSE\n )\n }\n do.call(rbind, rows)\n}\n" }, { "path": "R/example_dataset.R", "content": "#' @name N2finemapping\n#'\n#' @title Simulated Fine-mapping Data with Two Effect Variables\n#'\n#' @docType data\n#'\n#' @description This data set contains a genotype matrix for 574\n#' individuals and 1,002 variables. The variables are genotypes after\n#' centering and scaling, and therefore retain the correlation\n#' structure of the original genotype data. Two of the variables have\n#' non-zero effects on the multivariate response. The response data\n#' are generated under a multivariate linear regression model. See\n#' Wang \\emph{et al} (2020) for details.\n#'\n#' @format \\code{N2finemapping} is a list with the following elements:\n#'\n#' \\describe{\n#'\n#' \\item{X}{Centered and scaled genotype data.}\n#'\n#' \\item{chrom}{Chromomsome of the original data, in hg38 coordinates.}\n#'\n#' \\item{pos}{Chromomosomal position of the original data, in hg38\n#' coordinates. The information can be used to compare impact of using\n#' other genotype references of the same variables in \\code{susie_rss}\n#' application.}\n#'\n#' \\item{true_coef}{Simulated effect sizes.}\n#'\n#' \\item{residual_variance}{Simulated residual covariance matrix.}\n#'\n#' \\item{Y}{Simulated multivariate response.}\n#'\n#' \\item{allele_freq}{Allele frequencies based on the original\n#' genotype data.}\n#'\n#' \\item{V}{Suggested prior covariance matrix for effect sizes of\n#' the two non-zero effect variables.}\n#' }\n#'\n#' @keywords data\n#'\n#' @references\n#' G. Wang, A. Sarkar, P. Carbonetto and M. Stephens (2020). A simple\n#' new approach to variable selection in regression, with application\n#' to genetic fine-mapping. \\emph{Journal of the Royal Statistical\n#' Society, Series B} \\doi{10.1101/501114}.\n#'\n#' @examples\n#' data(N2finemapping)\nNULL\n\n#' @name N3finemapping\n#'\n#' @title Simulated Fine-mapping Data with Three Effect Variables.\n#'\n#' @docType data\n#'\n#' @description The data-set contains a matrix of 574\n#' individuals and 1,001 variables. These variables are real-world\n#' genotypes centered and scaled, and therefore retains the\n#' correlation structure of variables in the original genotype data. 3\n#' out of the variables have non-zero effects. The response data is\n#' generated under a multivariate linear regression model. See Wang\n#' \\emph{et al} (2020) for more details.\n#'\n#' @format \\code{N3finemapping} is a list with the following elements:\n#'\n#' \\describe{\n#'\n#' \\item{X}{N by P variable matrix of centered and scaled genotype\n#' data.}\n#'\n#' \\item{chrom}{Chromomsome of the original data, in hg38 coordinate.}\n#'\n#' \\item{pos}{Chromomosomal positoin of the original data, in hg38\n#' coordinate. The information can be used to compare impact of using\n#' other genotype references of the same variables in susie_rss\n#' application.}\n#'\n#' \\item{true_coef}{The simulated effect sizes.}\n#'\n#' \\item{residual_variance}{The simulated residual covariance matrix.}\n#'\n#' \\item{Y}{The simulated response variables.}\n#'\n#' \\item{allele_freq}{Allele frequency of the original genotype data.}\n#'\n#' \\item{V}{Prior covariance matrix for effect size of the three\n#' non-zero effect variables.} }\n#'\n#' @keywords data\n#'\n#' @references\n#' G. Wang, A. Sarkar, P. Carbonetto and M. Stephens (2020). A simple\n#' new approach to variable selection in regression, with application\n#' to genetic fine-mapping. \\emph{Journal of the Royal Statistical\n#' Society, Series B} \\doi{10.1101/501114}.\n#'\n#' @examples\n#' data(N3finemapping)\nNULL\n\n#' @name FinemappingConvergence\n#'\n#' @title Simulated Fine-mapping Data with Convergence Problem.\n#'\n#' @description Data simulated using real genotypes from 50,000\n#' individuals and 200 SNPs. Two of the SNPs have non-zero effects\n#' on the multivariate response. The response data are generated under\n#' a linear regression model. The simulated response and the columns\n#' of the genotype matrix are centered.\n#'\n#' @format \\code{FinemappingConvergence} is a list with the following\n#' elements:\n#'\n#' \\describe{\n#'\n#' \\item{XtX}{Summary statistics computed using the centered and\n#' scaled genotype matrix.}\n#'\n#' \\item{Xty}{Summary statistics computed using the centered and\n#' scaled genotype data, and the centered simulated response.}\n#'\n#' \\item{yty}{yty is computed using the centered simulated response.}\n#'\n#' \\item{n}{The sample size (50,000).}\n#'\n#' \\item{true_coef}{The coefficients used to simulate the responses.}\n#'\n#' \\item{z}{z-scores from a simple (single-SNP) linear regression.}}\n#'\n#' @docType data\n#'\n#' @keywords data\n#'\n#' @seealso A similar data set with more SNPs is used in the\n#' \\dQuote{Refine SuSiE model} vignette.\n#'\n#' @examples\n#' data(FinemappingConvergence)\nNULL\n\n#' @name SummaryConsistency\n#'\n#' @title Simulated Fine-mapping Data with LD matrix From Reference Panel.\n#'\n#' @description Data simulated using real genotypes from 10,000\n#' individuals and 200 SNPs. One SNP have non-zero effect\n#' on the multivariate response. The response data are generated under\n#' a linear regression model. There is also one SNP with flipped allele\n#' between summary statistics and the reference panel.\n#'\n#' @format \\code{SummaryConsistency} is a list with the following\n#' elements:\n#'\n#' \\describe{\n#'\n#' \\item{z}{z-scores computed by fitting univariate simple regression\n#' variable-by-variable.}\n#'\n#' \\item{ldref}{LD matrix estimated from the reference panel.}\n#'\n#' \\item{flip_id}{The index of the SNP with the flipped allele.}\n#'\n#' \\item{signal_id}{The index of the SNP with the non-zero effect.}}\n#'\n#' @seealso A similar data set with more samples is used in the\n#' \\dQuote{Diagnostic for fine-mapping with summary statistics}\n#' vignette.\n#'\n#' @docType data\n#'\n#' @keywords data\n#'\n#' @examples\n#' data(SummaryConsistency)\nNULL\n\n#' @name data_small\n#'\n#' @title Simulated Small-sample eQTL Data.\n#'\n#' @description A simulated eQTL data set with 47 individuals and 7,430\n#' variables. The response is a simulated gene expression phenotype and\n#' the variables are genotypes. This data set illustrates the small\n#' sample-size setting considered in Denault \\emph{et al} (2025).\n#'\n#' @format \\code{data_small} is a list with the following elements:\n#'\n#' \\describe{\n#'\n#' \\item{y}{Simulated gene expression response.}\n#'\n#' \\item{X}{Genotype matrix.}}\n#'\n#' @docType data\n#'\n#' @keywords data\n#'\n#' @seealso The \\dQuote{Small data example} vignette.\n#'\n#' @references\n#' W. R. P. Denault \\emph{et al} (2025). Accounting for uncertainty in\n#' residual variances improves fine-mapping in small sample studies.\n#' \\emph{bioRxiv} \\doi{10.1101/2025.05.16.654543}.\n#'\n#' @examples\n#' data(data_small)\nNULL\n\n#' @name unmappable_data\n#'\n#' @title Simulated Fine-mapping Data with Sparse, Oligogenic and Polygenic Effects.\n#'\n#' @description A simulated data set with 1,000 individuals and 5,000\n#' variants, combining 3 sparse, 5 oligogenic and 15 polygenic\n#' non-zero effects. The response is generated under a linear\n#' regression model. This data set illustrates fine-mapping with\n#' SuSiE-ash and SuSiE-inf.\n#'\n#' @format \\code{unmappable_data} is a list with the following elements:\n#'\n#' \\describe{\n#'\n#' \\item{X}{Centered and scaled genotype matrix.}\n#'\n#' \\item{y}{Simulated response.}\n#'\n#' \\item{beta}{Simulated effect sizes.}\n#'\n#' \\item{h2g}{Total proportion of variance in the response explained\n#' by the simulated effects.}}\n#'\n#' @docType data\n#'\n#' @keywords data\n#'\n#' @seealso The \\dQuote{Fine-mapping with SuSiE-ash and SuSiE-inf}\n#' vignette.\n#'\n#' @examples\n#' data(unmappable_data)\nNULL" }, { "path": "R/generic_methods.R", "content": "# =============================================================================\n# DATA INITIALIZATION & CONFIGURATION\n#\n# S3 generics dispatched on data objects setup, configuration, and preprocessing.\n# These prepare data objects for model fitting and handle data-specific\n# configurations like unmappable effects.\n#\n# Functions: configure_data, get_var_y\n# =============================================================================\n\n# Configure data object for specified method\n#' @keywords internal\nconfigure_data <- function(data, params) {\n UseMethod(\"configure_data\")\n}\n#' @keywords internal\nconfigure_data.default <- function(data, params) {\n return(data)\n}\n\n# Get variance of y\n#' @keywords internal\nget_var_y <- function(data, ...) {\n UseMethod(\"get_var_y\")\n}\n#' @keywords internal\nget_var_y.default <- function(data, ...) {\n stop(\"get_var_y: no method for class '\", class(data)[1], \"'\")\n}\n\n# =============================================================================\n# MODEL INITIALIZATION & SETUP\n#\n# Functions for initializing model objects and setting up initial states.\n# These create model matrices, initialize fitted values, and prepare\n# the SuSiE model for iterative fitting.\n#\n# Functions: initialize_susie_model, initialize_fitted, validate_prior, track_ibss_fit\n# =============================================================================\n\n# Initialize susie model object\n#' @keywords internal\ninitialize_susie_model <- function(data, params, ...) {\n UseMethod(\"initialize_susie_model\")\n}\n#' @keywords internal\ninitialize_susie_model.default <- function(data, params, ...) {\n stop(\"initialize_susie_model: no method for class '\", class(data)[1], \"'\")\n}\n\n# Initialize fitted values\n#' @keywords internal\ninitialize_fitted <- function(data, mat_init) {\n UseMethod(\"initialize_fitted\")\n}\n#' @keywords internal\ninitialize_fitted.default <- function(data, mat_init, ...) {\n stop(\"initialize_fitted: no method for class '\", class(data)[1], \"'\")\n}\n\n# Validate prior variance\n#' @keywords internal\nvalidate_prior <- function(data, params, model, ...) {\n UseMethod(\"validate_prior\")\n}\n#' @keywords internal\nvalidate_prior.default <- function(data, params, model, ...) {\n invisible(TRUE)\n}\n\n# Track core parameters of a susie fit across iterations\n#' @keywords internal\ntrack_ibss_fit <- function(data, params, model, tracking, iter, ...) {\n UseMethod(\"track_ibss_fit\")\n}\n#' @keywords internal\ntrack_ibss_fit.default <- function(data, params, model, tracking, iter, elbo, ...) {\n # Store iteration snapshot if tracking is enabled.\n # tracking is a purely numeric list: tracking[[1]], [[2]], etc.\n if (isTRUE(params$track_fit)) {\n tracking[[iter]] <- list(\n alpha = model$alpha,\n niter = iter,\n V = model$V,\n sigma2 = model$sigma2\n )\n # Track slot activity per iteration when active\n if (!is.null(model$slot_weights)) {\n tracking[[iter]]$slot_weights <- model$slot_weights\n tracking[[iter]]$lbf <- model$lbf\n }\n }\n return(tracking)\n}\n\n# =============================================================================\n# SINGLE EFFECT REGRESSION & ELBO\n#\n# Core functions for single effect regression computation and ELBO calculation.\n# These handle the mathematical core of SuSiE including residual computation, SER\n# statistics, posterior moments, and log-likelihood calculations for the ELBO.\n#\n# Functions: compute_residuals, compute_ser_statistics, SER_posterior_e_loglik,\n# calculate_posterior_moments, compute_kl, get_ER2, Eloglik, loglik, neg_loglik\n# =============================================================================\n\n#' Get the slot weight for effect l\n#'\n#' Returns the weight by which effect l's contribution to the fitted\n#' values is scaled. When \\code{model$slot_weights} is NULL (the default),\n#' all effects have weight 1 and standard SuSiE behavior is recovered.\n#'\n#' Slot weights enable a natural mechanism for adaptively estimating the\n#' number of effects: each slot l can have a weight in [0,1] reflecting\n#' the posterior probability that the slot is active. With a suitable\n#' prior on the number of active effects, this generalizes SuSiE's fixed\n#' L to a data-driven estimate.\n#'\n#' @param model SuSiE model object.\n#' @param l Effect index.\n#'\n#' @return Scalar weight (default 1).\n#'\n#' @keywords internal\nget_slot_weight <- function(model, l) {\n if (is.null(model$slot_weights)) 1 else model$slot_weights[l]\n}\n\n# Compute residuals for single effect regression\n#' @keywords internal\ncompute_residuals <- function(data, params, model, l, ...) {\n UseMethod(\"compute_residuals\")\n}\n#' @keywords internal\ncompute_residuals.default <- function(data, params, model, l, ...) {\n stop(\"compute_residuals: no method for class '\", class(data)[1], \"'\")\n}\n\n# Compute SER statistics (betahat, shat2)\n#' @keywords internal\ncompute_ser_statistics <- function(data, params, model, l, ...) {\n UseMethod(\"compute_ser_statistics\")\n}\n#' @keywords internal\ncompute_ser_statistics.default <- function(data, params, model, l, ...) {\n stop(\"compute_ser_statistics: no method for class '\", class(data)[1], \"'\")\n}\n\n# Single effect regression posterior expected log-likelihood\n#' @keywords internal\nSER_posterior_e_loglik <- function(data, params, model, l) {\n UseMethod(\"SER_posterior_e_loglik\")\n}\n#' @keywords internal\nSER_posterior_e_loglik.default <- function(data, params, model, l) {\n stop(\"SER_posterior_e_loglik: no method for class '\", class(data)[1], \"'\")\n}\n\n# Calculate posterior moments for single effect regression\n#' @keywords internal\ncalculate_posterior_moments <- function(data, params, model, V, l, ...) {\n UseMethod(\"calculate_posterior_moments\")\n}\n#' @keywords internal\ncalculate_posterior_moments.default <- function(data, params, model, V, l = NULL, ...) {\n stop(\"calculate_posterior_moments: no method for class '\", class(data)[1], \"'\")\n}\n\n# Calculate KL divergence\n#' @keywords internal\ncompute_kl <- function(data, params, model, l) {\n UseMethod(\"compute_kl\")\n}\n#' @keywords internal\ncompute_kl.default <- function(data, params, model, l) {\n model$KL[l] <- -model$lbf[l] + SER_posterior_e_loglik(data, params, model, l)\n return(model)\n}\n\n# Expected squared residuals\n#' @keywords internal\nget_ER2 <- function(data, model) {\n UseMethod(\"get_ER2\")\n}\n#' @keywords internal\nget_ER2.default <- function(data, model) {\n stop(\"get_ER2: no method for class '\", class(data)[1], \"'\")\n}\n\n# Expected log-likelihood\n#' @keywords internal\nEloglik <- function(data, model) {\n UseMethod(\"Eloglik\")\n}\n#' @keywords internal\nEloglik.default <- function(data, model) {\n stop(\"Eloglik: no method for class '\", class(data)[1], \"'\")\n}\n\n# Variational E_q[log p(y|b, sigma^2)] under SuSiE-NIG. Non-S3 helper called\n# from get_objective so we don't break the Eloglik(data, model) signature\n# that downstream packages override (mvsusieR, mfsusieR).\n# Decomposition: E_q[||y-Xb||^2 | sigma^2] = A + sigma^2 B,\n# B = sum_l sum_j alpha^(l)_j * r0^(l)_j * tau_j,\n# A = get_ER2 - E[sigma^2] * B.\n# Eloglik = -n/2 log(2 pi) - n/2 (log b - digamma(a)) - 0.5 (A * a/b + B).\n#' @keywords internal\nnig_eloglik <- function(data, params, model) {\n n <- data$n\n ERSS_marg <- get_ER2(data, model)\n a_post <- (params$alpha0 + n) / 2\n b_post <- (params$beta0 + ERSS_marg) / 2\n\n tau_v <- if (!is.null(model$shat2_inflation)) model$shat2_inflation else 1\n pw <- model$predictor_weights\n B <- 0\n for (l in seq_len(nrow(model$alpha))) {\n r0_l <- model$V[l] / (model$V[l] + tau_v / pw)\n B <- B + sum(model$alpha[l, ] * r0_l * tau_v)\n }\n A <- ERSS_marg - (b_post / (a_post - 1)) * B\n -n / 2 * log(2 * pi) - n / 2 * (log(b_post) - digamma(a_post)) -\n 0.5 * (A * a_post / b_post + B)\n}\n\n# Log-likelihood and posterior moments for fixed mixture prior\n# (estimate_prior_method = \"fixed_mixture\"). Evaluates BFs on a\n# pre-specified variance grid with given mixture weights.\n#' @keywords internal\nloglik_mixture <- function(data, params, model, ser_stats, l, ...) {\n UseMethod(\"loglik_mixture\")\n}\n#' @keywords internal\nloglik_mixture.default <- function(data, params, model, ser_stats, l, ...) {\n # Shared implementation for all data types.\n # compute_ser_statistics() (type-specific) has already produced betahat and shat2.\n model <- loglik_mixture_common(params, model, ser_stats, l)\n return(model)\n}\n\n#' @keywords internal\ncalculate_posterior_moments_mixture <- function(data, params, model, l, ...) {\n UseMethod(\"calculate_posterior_moments_mixture\")\n}\n#' @keywords internal\ncalculate_posterior_moments_mixture.default <- function(data, params, model, l, ...) {\n # Shared implementation: mixture posterior from stored lbf_grid and ser_stats\n model <- calculate_posterior_moments_mixture_common(params, model, l)\n return(model)\n}\n\n# Log-likelihood for prior variance optimization\n#' @keywords internal\nloglik <- function(data, params, model, V, ser_stats, l = NULL, ...) {\n UseMethod(\"loglik\")\n}\n#' @keywords internal\nloglik.default <- function(data, params, model, V, ser_stats, l = NULL, ...) {\n stop(\"loglik: no method for class '\", class(data)[1], \"'\")\n}\n\n# Negative log-likelihood for optimization (handles both log and linear scales)\n#' @keywords internal\nneg_loglik <- function(data, params, model, V_param, ser_stats, ...) {\n UseMethod(\"neg_loglik\")\n}\n#' @keywords internal\nneg_loglik.default <- function(data, params, model, V_param, ser_stats, ...) {\n stop(\"neg_loglik: no method for class '\", class(data)[1], \"'\")\n}\n\n# EM update for prior variance\n#' @keywords internal\nem_update_prior_variance <- function(data, params, model, alpha, moments, V_init) {\n UseMethod(\"em_update_prior_variance\")\n}\n#' @keywords internal\nem_update_prior_variance.default <- function(data, params, model, alpha, moments, V_init) {\n if (!is.null(params$use_NIG) && params$use_NIG) {\n nig_ss <- get_nig_sufficient_stats(data, model)\n return(update_prior_variance_NIG_EM(data$n, model$predictor_weights,\n model$residuals, nig_ss$yy, nig_ss$sxy,\n alpha, V_init, params$alpha0, params$beta0,\n nig_ss$tau))\n }\n # Standard EM update\n sum(alpha * moments$post_mean2)\n}\n\n# =============================================================================\n# MODEL UPDATES & FITTING\n#\n# Functions for iterative model updates and variance component estimation.\n# These handle the dynamic aspects of model fitting including fitted value\n# updates and variance component estimation.\n#\n# Functions: update_fitted_values, update_variance_components, update_derived_quantities\n# =============================================================================\n\n# Update fitted values\n#' @keywords internal\nupdate_fitted_values <- function(data, params, model, l, ...) {\n UseMethod(\"update_fitted_values\")\n}\n#' @keywords internal\nupdate_fitted_values.default <- function(data, params, model, l, ...) {\n stop(\"update_fitted_values: no method for class '\", class(data)[1], \"'\")\n}\n\n# Update variance components\n#' @keywords internal\nupdate_variance_components <- function(data, params, model, ...) {\n UseMethod(\"update_variance_components\")\n}\n#' @keywords internal\nupdate_variance_components.default <- function(data, params, model, ...) {\n if (isTRUE(params$use_NIG)) {\n # Posterior mean of IG((alpha0+n)/2, (beta0+ERSS)/2)\n sigma2 <- (params$beta0 + get_ER2(data, model)) /\n (params$alpha0 + data$n - 2)\n } else {\n sigma2 <- est_residual_variance(data, model)\n }\n return(list(sigma2 = sigma2))\n}\n\n# Update derived quantities after variance component changes\n#' @keywords internal\nupdate_derived_quantities <- function(data, params, model) {\n UseMethod(\"update_derived_quantities\")\n}\n#' @keywords internal\nupdate_derived_quantities.default <- function(data, params, model) {\n return(model)\n}\n\n# =============================================================================\n# OUTPUT GENERATION & POST-PROCESSING\n#\n# Functions for generating final results and summary statistics.\n# These process fitted models into interpretable outputs including\n# credible sets, variable names, and fitted values.\n#\n# Functions: get_scale_factors, get_intercept, get_fitted, get_cs,\n# get_variable_names, get_zscore, cleanup_model\n# =============================================================================\n\n# Get column scale factors\n#' @keywords internal\nget_scale_factors <- function(data, params, ...) {\n UseMethod(\"get_scale_factors\")\n}\n#' @keywords internal\nget_scale_factors.default <- function(data, params, ...) {\n stop(\"get_scale_factors: no method for class '\", class(data)[1], \"'\")\n}\n\n# Get intercept\n#' @keywords internal\nget_intercept <- function(data, params, model, ...) {\n UseMethod(\"get_intercept\")\n}\n#' @keywords internal\nget_intercept.default <- function(data, params, model, ...) {\n stop(\"get_intercept: no method for class '\", class(data)[1], \"'\")\n}\n\n# Get fitted values\n#' @keywords internal\nget_fitted <- function(data, params, model, ...) {\n UseMethod(\"get_fitted\")\n}\n#' @keywords internal\nget_fitted.default <- function(data, params, model, ...) {\n return(NULL)\n}\n\n# Get credible sets\n#' @keywords internal\nget_cs <- function(data, params, model, ...) {\n UseMethod(\"get_cs\")\n}\n#' @keywords internal\nget_cs.default <- function(data, params, model, ...) {\n stop(\"get_cs: no method for class '\", class(data)[1], \"'\")\n}\n\n# Get variable names\n#' @keywords internal\nget_variable_names <- function(data, model, ...) {\n UseMethod(\"get_variable_names\")\n}\n#' @keywords internal\nget_variable_names.default <- function(data, model, ...) {\n stop(\"get_variable_names: no method for class '\", class(data)[1], \"'\")\n}\n\n# Get univariate z-scores\n#' @keywords internal\nget_zscore <- function(data, params, model, ...) {\n UseMethod(\"get_zscore\")\n}\n#' @keywords internal\nget_zscore.default <- function(data, params, model, ...) {\n return(NULL)\n}\n\n# Clean up model object by removing temporary computational fields\n#' @keywords internal\ncleanup_model <- function(data, params, model, ...) {\n UseMethod(\"cleanup_model\")\n}\n\n#' Class-specific extra fields to strip in cleanup_model.default\n#'\n#' Default returns `character(0)`. Subclasses (e.g., mfsusieR's\n#' `raw_residuals`, mvsusieR's `Y_imputed`/`llik_cache`) override\n#' to add their per-class scratch fields. Result is unioned with\n#' the standard temp_fields list inside `cleanup_model.default`.\n#' @keywords internal\ncleanup_extra_fields <- function(data) {\n UseMethod(\"cleanup_extra_fields\")\n}\n#' @keywords internal\ncleanup_extra_fields.default <- function(data) {\n character(0)\n}\n\n#' @keywords internal\ncleanup_model.default <- function(data, params, model, ...) {\n # Remove temporary fields common to all data types\n temp_fields <- c(\"null_weight\", \"predictor_weights\", \"runtime\",\n \"prev_elbo\", \"prev_alpha\",\n \"residuals\", \"fitted_without_l\", \"residual_variance\",\n \"shat2_inflation\",\n cleanup_extra_fields(data))\n\n for (field in temp_fields) {\n if (field %in% names(model)) {\n model[[field]] <- NULL\n }\n }\n\n return(model)\n}\n" }, { "path": "R/individual_data_methods.R", "content": "# =============================================================================\n# DATA INITIALIZATION & CONFIGURATION\n#\n# Functions for data object setup, configuration, and preprocessing.\n# These prepare data objects for model fitting and handle data-specific\n# configurations like unmappable effects.\n#\n# Functions: configure_data, get_var_y\n# =============================================================================\n\n# Configure individual data for specified method\n#' @keywords internal\nconfigure_data.individual <- function(data, params) {\n if (params$unmappable_effects == \"none\" || params$unmappable_effects %in% c(\"ash\", \"ash_filter_archived\")) {\n return(configure_data.default(data, params))\n } else {\n # \"inf\" mode still requires sufficient statistics conversion\n warning_message(\"Individual-level data will be converted to sufficient statistics for unmappable effects methods (this step may take a while for a large data set)\")\n return(convert_individual_to_ss(data, params))\n }\n}\n\n# Get variance of y\n#' @keywords internal\n#' @importFrom stats var\nget_var_y.individual <- function(data, ...) {\n return(var(drop(data$y)))\n}\n\n# =============================================================================\n# MODEL INITIALIZATION & SETUP\n#\n# Functions for initializing model objects and setting up initial states.\n# These create model matrices, initialize fitted values, and prepare\n# the SuSiE model for iterative fitting.\n#\n# Functions: initialize_susie_model, initialize_fitted, validate_prior, track_ibss_fit\n# =============================================================================\n\n# Initialize SuSiE model\n#' @keywords internal\ninitialize_susie_model.individual <- function(data, params, var_y, ...) {\n\n # Base model\n model <- initialize_matrices(data, params, var_y)\n\n # Append predictor weights\n model$predictor_weights <- attr(data$X, \"d\")\n\n # Initialize NIG parameters\n if (params$use_NIG) {\n model$rv <- rep(1, params$L)\n model$marginal_loglik <- rep(as.numeric(NA), params$L)\n }\n\n # Initialize ash (Mr.ASH) tracking fields\n if (params$unmappable_effects == \"ash\") {\n model <- init_ash_fields(model, data$n, data$p, params$L, is_individual = TRUE)\n } else if (params$unmappable_effects == \"ash_filter_archived\") {\n model <- init_ash_fields_filter_archived(model, data$n, data$p, params$L, is_individual = TRUE)\n }\n\n return(model)\n}\n\n# Initialize fitted values\n#' @keywords internal\ninitialize_fitted.individual <- function(data, mat_init) {\n return(list(Xr = compute_Xb(data$X, colSums(mat_init$alpha * mat_init$mu))))\n}\n\n# Validate prior variance\n#' @keywords internal\nvalidate_prior.individual <- function(data, params, model, ...) {\n return(validate_prior.default(data, params, model, ...))\n}\n\n# Track core parameters across iterations\n#' @keywords internal\ntrack_ibss_fit.individual <- function(data, params, model, tracking, iter, elbo, ...) {\n if (params$unmappable_effects %in% c(\"ash\", \"ash_filter_archived\")) {\n tracking <- track_ibss_fit.default(data, params, model, tracking, iter, elbo, ...)\n if (isTRUE(params$track_fit)) {\n tracking[[iter]]$tau2 <- model$tau2\n }\n return(tracking)\n }\n return(track_ibss_fit.default(data, params, model, tracking, iter, elbo, ...))\n}\n\n# =============================================================================\n# SINGLE EFFECT REGRESSION & ELBO\n#\n# Core functions for single effect regression computation and ELBO calculation.\n# These handle the mathematical core of SuSiE including residual computation, SER\n# statistics, posterior moments, and log-likelihood calculations for the ELBO.\n#\n# Functions: compute_residuals, compute_ser_statistics, SER_posterior_e_loglik,\n# calculate_posterior_moments, compute_kl, get_ER2, Eloglik, loglik, neg_loglik\n# =============================================================================\n\n# Compute residuals for single effect regression\n#' @keywords internal\ncompute_residuals.individual <- function(data, params, model, l, ...) {\n # Remove lth effect from fitted values (scaled by slot weight)\n sw_l <- get_slot_weight(model, l)\n Xr_without_l <- model$Xr - sw_l * compute_Xb(data$X, model$alpha[l, ] * model$mu[l, ])\n\n # Compute residuals\n if (params$unmappable_effects %in% c(\"ash\", \"ash_filter_archived\")) {\n # Subtract both sparse effects (without l) and ash theta\n R <- data$y - Xr_without_l - model$X_theta\n } else {\n R <- data$y - Xr_without_l\n }\n XtR <- compute_Xty(data$X, R)\n\n # Store unified residuals in model\n model$residuals <- XtR\n model$fitted_without_l <- Xr_without_l\n model$raw_residuals <- R\n model$residual_variance <- model$sigma2 # Standard residual variance\n\n return(model)\n}\n\n# Compute SER statistics\n#' @keywords internal\ncompute_ser_statistics.individual <- function(data, params, model, l, ...) {\n betahat <- (1 / model$predictor_weights) * model$residuals\n shat2 <- model$residual_variance / model$predictor_weights\n\n # Optimization parameters\n optim_init <- log(max(c(betahat^2 - shat2, 1), na.rm = TRUE))\n optim_bounds <- c(-30, 15)\n optim_scale <- \"log\"\n\n return(list(\n betahat = betahat,\n shat2 = shat2,\n optim_init = optim_init,\n optim_bounds = optim_bounds,\n optim_scale = optim_scale\n ))\n}\n\n# Posterior expected log-likelihood for single effect regression\n#' @keywords internal\nSER_posterior_e_loglik.individual <- function(data, params, model, l) {\n Eb <- model$alpha[l, ] * model$mu[l, ]\n Eb2 <- model$alpha[l, ] * model$mu2[l, ]\n return(-0.5 * data$n * log(2 * pi * model$sigma2) -\n 0.5 / model$sigma2 * (sum(model$raw_residuals * model$raw_residuals)\n - 2 * sum(model$raw_residuals * compute_Xb(data$X, Eb)) +\n sum(model$predictor_weights * Eb2)))\n}\n\n# Calculate posterior moments for single effect regression\n#' @keywords internal\ncalculate_posterior_moments.individual <- function(data, params, model, V, l, ...) {\n if (params$use_NIG) {\n if (V <= 0) {\n # Zero variance case\n post_mean <- rep(0, data$p)\n post_mean2 <- rep(0, data$p)\n model$rv[l] <- 1\n } else {\n # Compute posterior moments for NIG prior\n nig_ss <- get_nig_sufficient_stats(data, model)\n moments <- compute_posterior_moments_NIG(data$n, model$predictor_weights,\n model$residuals, nig_ss$yy, nig_ss$sxy,\n V, params$alpha0, params$beta0, nig_ss$tau)\n\n post_mean <- moments$post_mean\n post_mean2 <- moments$post_mean2\n\n # Compute weighted average of residual variance modes using PIPs\n model$rv[l] <- sum(model$alpha[l, ] * moments$rv)\n }\n } else {\n # Standard Gaussian posterior calculations\n post_var <- (1 / V + model$predictor_weights / model$residual_variance)^(-1)\n post_mean <- (1 / model$residual_variance) * post_var * model$residuals\n post_mean2 <- post_var + post_mean^2\n }\n\n # Store posterior moments in model\n model$mu[l, ] <- post_mean\n model$mu2[l, ] <- post_mean2\n\n return(model)\n}\n\n# Calculate KL divergence\n#' @keywords internal\ncompute_kl.individual <- function(data, params, model, l) {\n if (params$use_NIG) {\n # NIG KL only valid for L=1 (gIBSS for L>1 has no coherent ELBO; supp. line 503)\n if (params$L == 1) {\n ki <- nig_kl_inputs(data, params, model, l)\n kl <- compute_kl_NIG(model$alpha[l, ], model$mu[l, ], model$mu2[l, ],\n model$pi, model$V[l],\n a0 = params$alpha0 / 2, b0 = params$beta0 / 2,\n a_post = ki$a_post, b_post = ki$b_post,\n s_j_sq = ki$s_j_sq)\n } else {\n kl <- 0\n }\n } else {\n # Standard Gaussian KL divergence\n loglik_term <- model$lbf[l] + sum(dnorm(model$raw_residuals, 0, sqrt(model$sigma2), log = TRUE))\n kl <- -loglik_term + SER_posterior_e_loglik(data, params, model, l)\n }\n\n # Store in model and return\n model$KL[l] <- kl\n return(model)\n}\n\n# Expected squared residuals\n#' @keywords internal\nget_ER2.individual <- function(data, model) {\n Xr_L <- compute_MXt(model$alpha * model$mu, data$X)\n postb2 <- model$alpha * model$mu2\n # For ash, subtract theta contribution from residuals\n y_adj <- if (!is.null(model$X_theta)) data$y - model$X_theta else data$y\n # Slot-weight correction: E[||y - sum_l c_l X beta^(l)||^2] under Bern(chat_l)\n # = ||y - Xr||^2 + sum_l chat_l * E[||X b^(l)||^2] - chat_l^2 * ||X bbar_l||^2\n # When slot_weights is NULL (all weights = 1), reduces to the standard formula.\n sw <- if (!is.null(model$slot_weights)) model$slot_weights else rep(1, nrow(model$alpha))\n per_slot_Eb2 <- as.vector(postb2 %*% model$predictor_weights) # L-vector\n per_slot_Xb2 <- rowSums(Xr_L^2) # L-vector\n return(sum((y_adj - model$Xr)^2) + sum(sw * per_slot_Eb2 - sw^2 * per_slot_Xb2))\n}\n\n# Expected log-likelihood\n#' @keywords internal\nEloglik.individual <- function(data, model) {\n return(-data$n / 2 * log(2 * pi * model$sigma2) -\n 1 / (2 * model$sigma2) * get_ER2(data, model))\n}\n\n#' @importFrom Matrix colSums\n#' @importFrom stats dnorm\n#' @importFrom stats cor\n#' @keywords internal\nloglik.individual <- function(data, params, model, V, ser_stats, l = NULL, ...) {\n # Check if using NIG prior\n if (params$use_NIG) {\n # Compute log Bayes factors for NIG prior\n nig_ss <- get_nig_sufficient_stats(data, model)\n lbf <- compute_lbf_NIG(data$n, model$predictor_weights,\n model$residuals, nig_ss$yy, nig_ss$sxy,\n V, params$alpha0, params$beta0, nig_ss$tau)\n } else {\n # Standard Gaussian prior log Bayes factors\n lbf <- dnorm(ser_stats$betahat, 0, sqrt(V + ser_stats$shat2), log = TRUE) -\n dnorm(ser_stats$betahat, 0, sqrt(ser_stats$shat2), log = TRUE)\n }\n\n # Stabilize logged Bayes Factor\n stable_res <- lbf_stabilization(lbf, model$pi, ser_stats$shat2)\n\n # Compute posterior weights\n weights_res <- compute_posterior_weights(stable_res$lpo)\n\n # Store in model if l is provided, otherwise return lbf_model for prior variance optimization\n if (!is.null(l)) {\n # Store results in model\n model$alpha[l, ] <- weights_res$alpha\n model$lbf[l] <- weights_res$lbf_model\n model$lbf_variable[l, ] <- stable_res$lbf\n\n # Compute and store marginal log-likelihood for NIG prior\n if (params$use_NIG) {\n model$marginal_loglik[l] <- compute_marginal_loglik(weights_res$lbf_model, data$n,\n nig_ss$yy, params$alpha0, params$beta0,\n TRUE)\n }\n return(model)\n } else {\n return(weights_res$lbf_model)\n }\n}\n\n#' @keywords internal\nneg_loglik.individual <- function(data, params, model, V_param, ser_stats, ...) {\n # Convert parameter to V based on optimization scale (always log for individual)\n V <- exp(V_param)\n lbf_model <- loglik.individual(data, params, model, V, ser_stats)\n return(-lbf_model)\n}\n\n# =============================================================================\n# MODEL UPDATES & FITTING\n#\n# Functions for iterative model updates and variance component estimation.\n# These handle the dynamic aspects of model fitting including fitted value\n# updates and variance component estimation.\n#\n# Functions: update_fitted_values, update_variance_components, update_derived_quantities\n# =============================================================================\n\n# Update fitted values\n#' @keywords internal\nupdate_fitted_values.individual <- function(data, params, model, l, ...) {\n sw_l <- get_slot_weight(model, l)\n model$Xr <- model$fitted_without_l + sw_l * compute_Xb(data$X, model$alpha[l, ] * model$mu[l, ])\n\n return(model)\n}\n\n# Update variance components for individual data\n#' @keywords internal\nupdate_variance_components.individual <- function(data, params, model, ...) {\n if (params$unmappable_effects == \"ash_filter_archived\") {\n # Original filter-based masking (archived for internal diagnostics)\n return(update_ash_variance_components_filter_archived(data, model, params))\n } else if (params$unmappable_effects == \"ash\") {\n # c_hat + 3 LD-interference heuristics\n return(update_ash_variance_components(data, model, params))\n }\n return(update_variance_components.default(data, params, model, ...))\n}\n\n# Update derived quantities for individual data\n#' @keywords internal\nupdate_derived_quantities.individual <- function(data, params, model) {\n if (params$unmappable_effects %in% c(\"ash\", \"ash_filter_archived\")) {\n # For ash, recompute full Xr including sparse effects only\n # (theta is tracked separately via X_theta)\n # Use slot_weights (c_hat) if available to maintain consistency\n # with the c_hat-weighted Xr from ibss_fit + update_c_hat.\n sw <- if (!is.null(model$slot_weights)) model$slot_weights else rep(1, nrow(model$alpha))\n b <- colSums(sw * model$alpha * model$mu)\n model$Xr <- as.vector(compute_Xb(data$X, b))\n return(model)\n }\n return(update_derived_quantities.default(data, params, model))\n}\n\n# =============================================================================\n# OUTPUT GENERATION & POST-PROCESSING\n#\n# Functions for generating final results and summary statistics.\n# These process fitted models into interpretable outputs including\n# credible sets, variable names, and fitted values.\n#\n# Functions: get_scale_factors, get_intercept, get_fitted, get_cs,\n# get_variable_names, get_zscore\n# =============================================================================\n\n# Get column scale factors\n#' @keywords internal\nget_scale_factors.individual <- function(data, params) {\n return(attr(data$X, \"scaled:scale\"))\n}\n\n# Get intercept\n#' @keywords internal\nget_intercept.individual <- function(data, params, model, ...) {\n if (params$intercept) {\n return(data$mean_y - sum(attr(data$X, \"scaled:center\") *\n (colSums(model$alpha * model$mu) / attr(data$X, \"scaled:scale\"))))\n } else {\n return(0)\n }\n}\n\n# Get Fitted Values\n#' @keywords internal\nget_fitted.individual <- function(data, params, model, ...) {\n if (params$intercept) {\n fitted <- model$Xr + data$mean_y\n } else {\n fitted <- model$Xr\n }\n\n # Include ash theta contribution\n if (!is.null(model$X_theta)) {\n fitted <- fitted + model$X_theta\n }\n\n fitted <- drop(fitted)\n names(fitted) <- `if`(is.null(names(data$y)), rownames(data$X), names(data$y))\n\n return(fitted)\n}\n\n# Get Credible Sets\n#' @keywords internal\nget_cs.individual <- function(data, params, model, ...) {\n if (is.null(params$coverage) || is.null(params$min_abs_corr)) {\n return(NULL)\n }\n\n return(susie_get_cs(model,\n X = data$X,\n coverage = params$coverage,\n min_abs_corr = params$min_abs_corr,\n n_purity = params$n_purity))\n}\n\n\n# Get Variable Names\n#' @keywords internal\nget_variable_names.individual <- function(data, model, ...) {\n return(assign_names(data, model, colnames(data$X)))\n}\n\n# Get univariate z-score\n#' @keywords internal\nget_zscore.individual <- function(data, params, model, ...) {\n if (isFALSE(params$compute_univariate_zscore)) {\n return(get_zscore.default(data, params, model))\n }\n\n X <- data$X\n\n if (!is.matrix(X)) {\n warning_message(\n \"Calculation of univariate regression z-scores is not \",\n \"implemented specifically for sparse or trend filtering \",\n \"matrices, so this step may be slow if the matrix is large; \",\n \"to skip this step set compute_univariate_zscore = FALSE\"\n )\n }\n if (!is.null(model$null_weight) && model$null_weight != 0) {\n X <- X[, 1:(ncol(X) - 1)]\n }\n\n return(calc_z(X, data$y, center = params$intercept, scale = params$standardize))\n}\n\n# Clean up model object for individual data\n#' @keywords internal\ncleanup_model.individual <- function(data, params, model, ...) {\n # Remove common fields\n model <- cleanup_model.default(data, params, model, ...)\n\n # Remove individual-specific temporary fields\n model$raw_residuals <- NULL\n\n # Remove NIG specific temporary fields\n if (params$use_NIG) {\n model$marginal_loglik <- NULL\n }\n\n # Remove ash-specific runtime fields\n if (!is.null(params$unmappable_effects) && params$unmappable_effects == \"ash\") {\n model <- cleanup_ash_fields(model)\n } else if (!is.null(params$unmappable_effects) && params$unmappable_effects == \"ash_filter_archived\") {\n model <- cleanup_ash_fields_filter_archived(model)\n }\n\n return(model)\n}\n" }, { "path": "R/iterative_bayesian_stepwise_selection.R", "content": "# =============================================================================\n# IBSS INITIALIZATION\n#\n# Initializes the SuSiE model object for Iterative Bayesian Stepwise Selection.\n# Sets up model matrices, handles model_init, and prepares for IBSS.\n# =============================================================================\n#' Initialize IBSS model\n#'\n#' Creates and initializes the model object for the IBSS algorithm.\n#'\n#' @param data Data object (individual, ss, or rss_lambda)\n#' @param params Validated params object\n#'\n#' @return Initialized model object ready for the IBSS iteration loop.\n#' @importFrom utils modifyList\n#' @export\n#' @keywords internal\nibss_initialize <- function(data, params) {\n UseMethod(\"ibss_initialize\")\n}\n\n#' @rdname ibss_initialize\n#' @export\n#' @keywords internal\nibss_initialize.default <- function(data, params) {\n\n # Set var(y)\n var_y <- get_var_y(data)\n\n # Adjust number of single effects if needed\n if (data$p < params$L) {\n params$L <- data$p\n }\n\n # Check & validate residual variance\n if (is.null(params$residual_variance)) {\n params$residual_variance <- var_y\n }\n # For multivariate models, residual_variance can be a matrix\n if (!is.matrix(params$residual_variance)) {\n if (!is.numeric(params$residual_variance)) {\n stop(\"Input residual variance sigma2 must be numeric.\")\n }\n params$residual_variance <- as.numeric(params$residual_variance)\n if (length(params$residual_variance) != 1) {\n stop(\"Input residual variance sigma2 must be a scalar.\")\n }\n if (params$residual_variance <= 0) {\n stop(\"Residual variance sigma2 must be positive (is your var(Y) zero?).\")\n }\n }\n\n # Handle model initialization\n if (!is.null(params$model_init)) {\n # Validate the contents of model_init\n validate_init(data, params)\n\n # Prune effects with zero prior variance\n model_init_pruned <- prune_single_effects(params$model_init)\n\n # Adjust the number of effects\n adjustment <- adjust_L(params, model_init_pruned, var_y)\n params$L <- adjustment$L\n\n # Create base model with all required fields\n mat_init <- initialize_susie_model(data, params, var_y)\n\n # Merge with adjusted model_init\n mat_init <- modifyList(mat_init, adjustment$model_init)\n\n # Reset iteration-specific values\n mat_init$KL <- rep(as.numeric(NA), params$L)\n mat_init$lbf <- rep(as.numeric(NA), params$L)\n } else {\n # Create fresh model\n mat_init <- initialize_susie_model(data, params, var_y)\n }\n\n # Initialize fitted values and null index\n fitted <- initialize_fitted(data, mat_init)\n null_index <- initialize_null_index(data, mat_init)\n\n # Preserve model class set by initialize_susie_model (e.g., \"mvsusie\")\n model_class <- class(mat_init)\n\n # Return assembled SuSiE object\n model <- c(mat_init,\n list(null_index = null_index),\n fitted)\n\n # Use the class from initialize_susie_model if it inherits from \"susie\",\n # otherwise default to \"susie\"\n if (inherits(mat_init, \"susie\")) {\n class(model) <- model_class\n } else {\n class(model) <- \"susie\"\n }\n model$converged <- FALSE\n\n # Initialize slot activity (c_hat) if specified\n sp <- params$slot_prior\n if (!is.null(sp)) {\n if (!is.slot_prior(sp))\n stop(\"slot_prior must be created by slot_prior_betabinom() or \",\n \"slot_prior_poisson(). \",\n \"Got class: \", paste(class(sp), collapse=\", \"))\n L <- nrow(model$alpha)\n\n if (inherits(sp, \"slot_prior_betabinom\")) {\n a_beta <- sp$a_beta\n b_beta <- sp$b_beta\n prior_mean <- a_beta / (a_beta + b_beta)\n\n if (!is.null(sp$c_hat_init) && length(sp$c_hat_init) == L) {\n c_hat <- sp$c_hat_init\n } else {\n c_hat <- rep(min(prior_mean, 1 - 1e-10), L)\n }\n\n model$slot_weights <- c_hat\n model$c_hat_state <- list(\n prior_type = \"betabinom\", a_beta = a_beta, b_beta = b_beta,\n update_schedule = sp$update_schedule,\n skip_threshold_multiplier = sp$skip_threshold_multiplier,\n skip_threshold = 0\n )\n } else {\n C_val <- sp$C\n nu <- sp$nu\n\n if (!is.null(sp$c_hat_init) && length(sp$c_hat_init) == L) {\n c_hat <- sp$c_hat_init\n a_g <- nu + sum(c_hat)\n } else {\n c_hat <- rep(min(C_val / L, 1 - 1e-10), L)\n a_g <- nu + C_val\n }\n b_g <- nu / max(C_val, 1e-6) + 1\n\n model$slot_weights <- c_hat\n model$c_hat_state <- list(\n prior_type = \"poisson\", C = C_val, nu = nu, a_g = a_g, b_g = b_g,\n update_schedule = sp$update_schedule,\n skip_threshold_multiplier = sp$skip_threshold_multiplier,\n skip_threshold = 0\n )\n }\n\n model <- recompute_fitted_weighted(data, model)\n }\n\n # SS-path lambda_bias is stored as a scalar on the model. Only\n # allocate when R_mismatch is active so R_mismatch = \"none\" returns to the\n # un-augmented behavior (compute_shat2_inflation falls back to 0\n # when model$lambda_bias is NULL). The rss_lambda dispatch is out\n # of scope and continues to use a length-L vector.\n R_mismatch_mode <- if (!is.null(params$R_mismatch)) params$R_mismatch else \"none\"\n if (R_mismatch_mode != \"none\" && !is.null(data$R_finite_B) &&\n inherits(data, c(\"ss\", \"ss_mixture\"))) {\n model$lambda_bias <- 0\n model$B_corrected <- data$R_finite_B\n model$R_finite_B <- data$R_finite_B\n }\n\n return(model)\n}\n\n# =============================================================================\n# IBSS FITTING\n#\n# Updates all L single effects in the SuSiE model for one IBSS iteration.\n# Calls single_effect_update for each effect and validates prior variance estimates.\n# =============================================================================\n#'\n#' @param data Data object (individual, ss, or rss_lambda)\n#' @param params Validated params object\n#' @param model Current SuSiE model object\n#'\n#' @return Updated SuSiE model object with new alpha, mu, mu2, V, lbf, KL, and\n#' fitted values\n#'\n#' @keywords internal\n#' @noRd\nibss_fit <- function(data, params, model) {\n\n L <- nrow(model$alpha)\n use_c_hat <- !is.null(model$c_hat_state)\n\n # SS / ss_mixture: lambda_bias / B_corrected are scalars set per-sweep\n # by fit_R_mismatch at the end of the sweep. rss_lambda does not carry\n # these (lambda > 0 + R_mismatch != \"none\" errors at entry). No reset\n # needed.\n\n if (L > 0) {\n for (l in seq_len(L)) {\n if (use_c_hat &&\n model$slot_weights[l] < model$c_hat_state$skip_threshold) {\n next\n }\n\n model <- single_effect_update(data, params, model, l)\n\n if (use_c_hat) {\n model <- update_c_hat(data, model, l)\n }\n }\n }\n\n # Gamma-Poisson batch shape update (once per sweep)\n if (use_c_hat && model$c_hat_state$update_schedule == \"batch\" &&\n model$c_hat_state$prior_type != \"betabinom\") {\n model$c_hat_state$a_g <- model$c_hat_state$nu + sum(model$slot_weights)\n }\n\n # Adaptive skip threshold: baseline c_hat with lbf=0, scaled by multiplier\n if (use_c_hat && model$c_hat_state$skip_threshold_multiplier > 0) {\n st <- model$c_hat_state\n L_val <- nrow(model$alpha)\n if (st$prior_type == \"betabinom\") {\n # Self-consistent baseline: one Newton step for k_{-l} = k_total - baseline\n k_total <- sum(model$slot_weights)\n approx <- log(st$a_beta + k_total) - log(st$b_beta + L_val - 1 - k_total)\n k_others <- k_total - 1 / (1 + exp(-approx))\n baseline_logodds <- log(st$a_beta + k_others) -\n log(st$b_beta + L_val - 1 - k_others)\n } else {\n baseline_logodds <- digamma(st$a_g) - log(st$b_g) - log(L_val)\n }\n c_hat_baseline <- 1 / (1 + exp(-baseline_logodds))\n model$c_hat_state$skip_threshold <-\n st$skip_threshold_multiplier * c_hat_baseline\n }\n\n # Region-level R-bias fit at the end of the sweep, before validate.\n # No-op when R_mismatch = \"none\" or on the rss_lambda dispatch (out of\n # scope; that path keeps the legacy per-slot fit). Reuses the\n # existing estimate_lambda_bias optimizer; only the cadence and\n # storage shape change (was per-slot inside the SER step; now\n # scalar at sweep boundary).\n if (inherits(data, c(\"ss\", \"ss_mixture\"))) {\n old_lambda_bias <- model$lambda_bias\n model <- fit_R_mismatch(data, params, model)\n new_lambda_bias <- model$lambda_bias\n if (!is.null(old_lambda_bias) || !is.null(new_lambda_bias)) {\n old <- if (is.null(old_lambda_bias)) 0 else old_lambda_bias\n new <- if (is.null(new_lambda_bias)) 0 else new_lambda_bias\n model$runtime$lambda_bias_diff <- max(abs(new - old))\n }\n }\n\n # Validate prior variance is reasonable\n validate_prior(data, params, model)\n\n return(model)\n}\n\n# =============================================================================\n# SLOT ACTIVITY (c_hat) HELPERS\n#\n# c_hat[l] = posterior probability that slot l is active.\n# Beta-Binomial: logit(c_l) = log(a + k_{-l}) - log(b + L-1 - k_{-l}) + lbf_l\n# Gamma-Poisson: logit(c_l) = psi(a_g) - log(b_g) - log(L) + lbf_l\n# =============================================================================\n\n#' Update c_hat for slot l after its SER step.\n#' @keywords internal\n#' @noRd\nupdate_c_hat <- function(data, model, l) {\n st <- model$c_hat_state\n old_c <- model$slot_weights[l]\n L <- nrow(model$alpha)\n\n lbf_l <- model$lbf[l]\n if (is.na(lbf_l) || !is.finite(lbf_l)) lbf_l <- 0\n\n if (st$prior_type == \"betabinom\") {\n k_others <- sum(model$slot_weights[-l])\n log_odds <- log(st$a_beta + k_others) -\n log(st$b_beta + L - 1 - k_others) + lbf_l\n } else {\n log_odds <- digamma(st$a_g) - log(st$b_g) - log(L) + lbf_l\n }\n log_odds <- max(min(log_odds, 20), -20)\n new_c <- 1 / (1 + exp(-log_odds))\n model$slot_weights[l] <- new_c\n\n if (abs(new_c - old_c) > 1e-15) {\n b_bar_l <- model$alpha[l, ] * model$mu[l, ]\n model <- adjust_fitted_for_c_hat(data, model, b_bar_l, new_c - old_c)\n }\n\n # Gamma shape update (sequential mode; Beta-Binomial uses k_others directly)\n if (st$prior_type != \"betabinom\" && st$update_schedule == \"sequential\") {\n model$c_hat_state$a_g <- st$nu + sum(model$slot_weights)\n }\n\n return(model)\n}\n\n#' Add delta_weight * R*b_bar_l to the fitted-values field (Xr/XtXr/Rz).\n#' @keywords internal\n#' @noRd\nadjust_fitted_for_c_hat <- function(data, model, b_bar_l, delta_weight) {\n fitted_field <- detect_fitted_field(model)\n if (fitted_field == \"Xr\") {\n model$Xr <- model$Xr +\n delta_weight * as.vector(compute_Xb(data$X, b_bar_l))\n } else {\n model[[fitted_field]] <- model[[fitted_field]] +\n delta_weight * as.vector(compute_Rv(data, b_bar_l, model$X_meta))\n }\n return(model)\n}\n\n#' @keywords internal\n#' @noRd\ndetect_fitted_field <- function(model) {\n if (\"Rz\" %in% names(model)) \"Rz\"\n else if (\"XtXr\" %in% names(model)) \"XtXr\"\n else if (\"Xr\" %in% names(model)) \"Xr\"\n else stop(\"Cannot detect fitted-values field on model object.\")\n}\n\n#' Recompute fitted = sum_l c_hat[l] * R * bbar[l] from scratch.\n#' @keywords internal\n#' @noRd\nrecompute_fitted_weighted <- function(data, model) {\n fitted_field <- detect_fitted_field(model)\n L <- nrow(model$alpha)\n c_hat <- model$slot_weights\n b_weighted <- rep(0, ncol(model$alpha))\n for (ll in seq_len(L)) {\n b_weighted <- b_weighted + c_hat[ll] * model$alpha[ll, ] * model$mu[ll, ]\n }\n if (fitted_field == \"Xr\") {\n model$Xr <- as.vector(compute_Xb(data$X, b_weighted))\n } else {\n model[[fitted_field]] <- as.vector(compute_Rv(data, b_weighted, model$X_meta))\n }\n return(model)\n}\n\n# =============================================================================\n# IBSS FINALIZATION\n#\n# Finalizes the SuSiE model after convergence or maximum number of iterations\n# reached. Computes credible sets, PIPs, intercept, fitted values, and z-scores.\n# =============================================================================\n#' Finalize IBSS model\n#'\n#' Computes credible sets, PIPs, z-scores, and cleans up temporary\n#' fields from the model object.\n#'\n#' @param data Data object (individual, ss, or rss_lambda)\n#' @param params Validated params object\n#' @param model Converged model object\n#' @param elbo ELBO values (optional)\n#' @param iter Number of iterations completed\n#' @param tracking Tracking data (optional)\n#'\n#' @return Finalized model object with credible sets and PIPs.\n#' @export\n#' @keywords internal\nibss_finalize <- function(data, params, model, elbo = NULL, iter = NA_integer_,\n tracking = NULL) {\n\n # Append ELBO & iteration count to model output\n model$niter <- iter\n\n # Intercept & Fitted Values\n model$X_column_scale_factors <- get_scale_factors(data, params)\n model$intercept <- get_intercept(data, params, model)\n model$fitted <- get_fitted(data, params, model)\n\n # Posterior Inclusion Probabilities, credible sets, z-scores\n model$sets <- get_cs(data, params, model)\n model$pip <- susie_get_pip(model, prior_tol = params$prior_tol)\n model$z <- get_zscore(data, params, model)\n\n # Tracking Across Iterations\n if (params$track_fit) model$trace <- tracking\n\n # Assign Variable Names\n model <- get_variable_names(data, model)\n\n # R diagnostics (from data -> model, following sets/pip/z pattern).\n # SS / ss_mixture paths store lambda_bias / B_corrected as scalars\n # (set by fit_R_mismatch once per sweep). The rss_lambda dispatch keeps\n # the per-slot vector form. Copy whatever shape lives on the model.\n R_finite_diagnostics <- data$R_finite_diagnostics\n if (!is.null(R_finite_diagnostics)) {\n model$R_finite_diagnostics <- R_finite_diagnostics\n if (!is.null(model$lambda_bias))\n model$R_finite_diagnostics$lambda_bias <- model$lambda_bias\n if (!is.null(model$B_corrected))\n model$R_finite_diagnostics$B_corrected <- model$B_corrected\n if (!is.null(data$R_mismatch))\n model$R_finite_diagnostics$R_mismatch <- data$R_mismatch\n if (!is.null(model$shat2_inflation))\n model$R_finite_diagnostics$per_variable_penalty <- as.vector(model$shat2_inflation - 1)\n # Q_art / artifact fields are present only for R_mismatch = \"map_qc\"\n # (set by fit_R_mismatch). Copy whichever exist.\n for (fld in c(\"Q_art\", \"artifact_flag\", \"artifact_evaluable\",\n \"low_eigen_count\", \"low_eigen_fraction\", \"eig_delta\",\n \"mode_label\"))\n if (!is.null(model[[fld]]))\n model$R_finite_diagnostics[[fld]] <- model[[fld]]\n }\n\n # Multi-panel omega weights\n if (!is.null(model$omega))\n model$omega_weights <- model$omega\n\n # Store Gamma-Poisson c_hat results on output for user access\n # and for susieAnn to extract (a_g, b_g needed for genome-wide nu update).\n if (!is.null(model$c_hat_state)) {\n model$c_hat <- model$slot_weights\n model$C_hat <- sum(model$slot_weights)\n if (model$c_hat_state$prior_type == \"betabinom\") {\n model$a_beta <- model$c_hat_state$a_beta\n model$b_beta <- model$c_hat_state$b_beta\n } else {\n model$a_g <- model$c_hat_state$a_g\n model$b_g <- model$c_hat_state$b_g\n }\n model$c_hat_state <- NULL # cleanup internal state\n }\n\n # Clean up temporary computational fields\n model <- cleanup_model(data, params, model)\n\n return(model)\n}\n" }, { "path": "R/mixture_prior.R", "content": "# =============================================================================\n# FIXED MIXTURE PRIOR\n#\n# Shared implementations for estimate_prior_method = \"fixed_mixture\".\n# Evaluates Bayes factors on a pre-specified variance grid with given mixture\n# weights, computes mixture posterior moments, and stores per-grid BF matrix.\n#\n# These functions are data-type-agnostic: they operate on betahat and shat2\n# produced by the type-specific compute_ser_statistics().\n# =============================================================================\n\n#' Resolve fixed mixture prior parameters\n#'\n#' Called from susie, susie_ss, and susie_rss to handle the\n#' prior_variance_grid / mixture_weights parameters. When\n#' prior_variance_grid is non-NULL, overrides estimate_prior_method\n#' to \"fixed_mixture\" and validates inputs. Returns a list with\n#' the resolved estimate_prior_method, estimate_prior_variance,\n#' prior_variance_grid, and mixture_weights.\n#'\n#' @keywords internal\nresolve_mixture_prior <- function(estimate_prior_method,\n estimate_prior_variance,\n prior_variance_grid,\n mixture_weights) {\n if (!is.null(prior_variance_grid)) {\n K <- length(prior_variance_grid)\n if (is.null(mixture_weights))\n mixture_weights <- rep(1 / K, K)\n stopifnot(\n length(mixture_weights) == K,\n all(prior_variance_grid > 0),\n all(mixture_weights >= 0),\n abs(sum(mixture_weights) - 1) < 1e-8\n )\n estimate_prior_method <- \"fixed_mixture\"\n estimate_prior_variance <- FALSE\n } else {\n estimate_prior_method <- match.arg(\n estimate_prior_method, c(\"optim\", \"EM\", \"simple\")\n )\n }\n list(\n estimate_prior_method = estimate_prior_method,\n estimate_prior_variance = estimate_prior_variance,\n prior_variance_grid = prior_variance_grid,\n mixture_weights = mixture_weights\n )\n}\n\n#' Compute mixture log-Bayes factors and posterior inclusion probabilities\n#'\n#' For each grid point k and variant j, computes the Wakefield approximate\n#' Bayes factor (ABF), then forms the mixture BF as a weighted sum over grid\n#' points. Stores the full p x K log-BF matrix in model$lbf_grid[[l]] for\n#' downstream use (e.g., mixsqp M-step in susieAnn).\n#'\n#' @param params Params object with prior_variance_grid (K-vector) and\n#' mixture_weights (K-vector summing to 1)\n#' @param model Current model object with pi (prior weights)\n#' @param ser_stats List with betahat (p-vector) and shat2 (p-vector)\n#' @param l Effect index\n#'\n#' @return Updated model with alpha[l,], lbf[l], lbf_variable[l,], lbf_grid[[l]]\n#'\n#' @keywords internal\nloglik_mixture_common <- function(params, model, ser_stats, l) {\n grid <- params$prior_variance_grid # K-vector\n w <- params$mixture_weights # K-vector\n K <- length(grid)\n\n betahat <- ser_stats$betahat # p-vector\n shat2 <- ser_stats$shat2 # p-vector (may contain Inf)\n p <- length(betahat)\n\n # Compute p x K matrix of log-BFs (Wakefield ABF at each grid point)\n # Uses pmax only for the ABF computation to avoid log(0), matching the\n # scalar path which applies pmax inside loglik.rss_lambda\n shat2_safe <- pmax(shat2, .Machine$double.eps)\n lbf_grid <- matrix(0, nrow = p, ncol = K)\n for (k in seq_len(K)) {\n V_k <- grid[k]\n lbf_grid[, k] <- -0.5 * log(1 + V_k / shat2_safe) +\n 0.5 * betahat^2 * V_k / (shat2_safe * (V_k + shat2_safe))\n }\n\n # Mixture log-BF per variant: log(sum_k w_k * exp(lbf_jk))\n # For K=1 this reduces to lbf_grid[,1] exactly (no numerical error)\n if (K == 1L) {\n lbf_mix <- lbf_grid[, 1]\n } else {\n log_w <- log(w)\n lbf_mix <- apply(lbf_grid, 1, function(row) {\n shifted <- row + log_w\n max_val <- max(shifted)\n max_val + log(sum(exp(shifted - max_val)))\n })\n }\n\n # Store per-grid BF matrix for M-step (e.g., mixsqp in susieAnn)\n if (is.null(model$lbf_grid)) {\n model$lbf_grid <- vector(\"list\", nrow(model$alpha))\n }\n model$lbf_grid[[l]] <- lbf_grid\n\n # Cache ser_stats for calculate_posterior_moments_mixture_common\n model$.ser_stats <- ser_stats\n\n # Compute posterior inclusion probabilities using existing machinery.\n # Pass raw shat2 (not pmax'd) to lbf_stabilization, matching the scalar path.\n stable_res <- lbf_stabilization(lbf_mix, model$pi, shat2)\n weights_res <- compute_posterior_weights(stable_res$lpo)\n\n model$alpha[l, ] <- weights_res$alpha\n model$lbf[l] <- weights_res$lbf_model\n model$lbf_variable[l, ] <- stable_res$lbf\n\n return(model)\n}\n\n\n#' Compute mixture posterior moments\n#'\n#' For each grid point k, computes the conjugate normal posterior moments\n#' (mean, variance) given prior variance V_k. Forms the mixture posterior\n#' using responsibility weights r_jk = w_k * BF_jk / sum_k' w_k' * BF_jk'.\n#'\n#' Uses betahat and shat2 from ser_stats (produced by the data-type-specific\n#' compute_ser_statistics), so this function is data-type-agnostic.\n#'\n#' @param params Params object with prior_variance_grid and mixture_weights\n#' @param model Model with lbf_grid[[l]] (p x K), alpha[l,] already computed,\n#' and ser_stats cached from loglik_mixture_common\n#' @param l Effect index\n#'\n#' @return Updated model with mu[l,] and mu2[l,]\n#'\n#' @keywords internal\ncalculate_posterior_moments_mixture_common <- function(params, model, l) {\n grid <- params$prior_variance_grid\n w <- params$mixture_weights\n K <- length(grid)\n\n lbf_grid <- model$lbf_grid[[l]] # p x K\n betahat <- model$.ser_stats$betahat # cached by loglik_mixture_common\n shat2 <- model$.ser_stats$shat2\n shat2_safe <- pmax(shat2, .Machine$double.eps)\n p <- length(betahat)\n\n # Responsibility weights: r_jk = w_k * BF_jk / sum_k' w_k' * BF_jk'\n # Work in log space for stability\n log_w <- log(w + .Machine$double.eps)\n log_r <- sweep(lbf_grid, 2, log_w, \"+\") # p x K\n log_r_max <- apply(log_r, 1, max)\n r <- exp(log_r - log_r_max) # p x K, shifted\n r <- r / rowSums(r) # normalize to responsibilities\n\n # Per-grid posterior moments\n post_mean <- matrix(0, p, K)\n post_mean2 <- matrix(0, p, K)\n for (k in seq_len(K)) {\n V_k <- grid[k]\n pv_k <- V_k * shat2_safe / (V_k + shat2_safe) # posterior variance\n pm_k <- pv_k / shat2_safe * betahat # posterior mean\n post_mean[, k] <- pm_k\n post_mean2[, k] <- pv_k + pm_k^2 # E[beta^2]\n }\n\n # Mixture posterior: weighted average over grid points\n model$mu[l, ] <- rowSums(r * post_mean)\n model$mu2[l, ] <- rowSums(r * post_mean2)\n\n # Clean up cached ser_stats\n model$.ser_stats <- NULL\n\n return(model)\n}\n" }, { "path": "R/model_methods.R", "content": "# =============================================================================\n# MODEL-LEVEL S3 METHODS\n\n# S3 generics dispatched on model class (model field access, initialization, \n# convergence, ELBO)\n# =============================================================================\n\n#' Get prior variance for effect l\n#' @keywords internal\nget_prior_variance_l <- function(model, l) {\n UseMethod(\"get_prior_variance_l\")\n}\n#' @keywords internal\nget_prior_variance_l.default <- function(model, l) {\n model$V[l]\n}\n\n#' Set prior variance for effect l\n#' @keywords internal\nset_prior_variance_l <- function(model, l, V) {\n UseMethod(\"set_prior_variance_l\")\n}\n#' @keywords internal\nset_prior_variance_l.default <- function(model, l, V) {\n model$V[l] <- V\n model\n}\n\n#' Get posterior inclusion probabilities for effect l\n#' @keywords internal\nget_alpha_l <- function(model, l) {\n UseMethod(\"get_alpha_l\")\n}\n#' @keywords internal\nget_alpha_l.default <- function(model, l) {\n model$alpha[l, ]\n}\n\n#' Get posterior moments for effect l (for EM prior variance update)\n#' @keywords internal\nget_posterior_moments_l <- function(model, l) {\n UseMethod(\"get_posterior_moments_l\")\n}\n#' @keywords internal\nget_posterior_moments_l.default <- function(model, l) {\n list(post_mean = model$mu[l, ], post_mean2 = model$mu2[l, ])\n}\n\n#' Get PIP-weighted posterior mean for effect l (alpha * mu)\n#' @keywords internal\nget_posterior_mean_l <- function(model, l) {\n UseMethod(\"get_posterior_mean_l\")\n}\n#' @keywords internal\nget_posterior_mean_l.default <- function(model, l) {\n model$alpha[l, ] * model$mu[l, ]\n}\n\n#' Get sum of PIP-weighted posterior means across all effects\n#' @keywords internal\nget_posterior_mean_sum <- function(model) {\n UseMethod(\"get_posterior_mean_sum\")\n}\n#' @keywords internal\nget_posterior_mean_sum.default <- function(model) {\n colSums(model$alpha * model$mu)\n}\n\n# =============================================================================\n# MODEL INITIALIZATION\n#\n# Initialize core model matrices and parameter storage.\n# =============================================================================\n\n#' @keywords internal\ninitialize_matrices <- function(data, params, var_y) {\n UseMethod(\"initialize_matrices\")\n}\n\n#' @keywords internal\ninitialize_matrices.default <- function(data, params, var_y) {\n L <- params$L\n mat_init <- list(\n alpha = matrix(1 / data$p, L, data$p),\n mu = matrix(0, L, data$p),\n mu2 = matrix(0, L, data$p),\n V = expand_scaled_prior_variance(params$scaled_prior_variance, var_y, L),\n KL = rep(as.numeric(NA), L),\n lbf = rep(as.numeric(NA), L),\n lbf_variable = matrix(as.numeric(NA), L, data$p),\n sigma2 = params$residual_variance,\n pi = params$prior_weights,\n null_weight = params$null_weight,\n predictor_weights = rep(as.numeric(NA), data$p)\n )\n\n return(mat_init)\n}\n\n# =============================================================================\n# VARIANCE UPDATE\n#\n# Update residual variance (and possibly other variance components) after\n# each IBSS iteration.\n# =============================================================================\n\n#' @keywords internal\n#' @importFrom utils modifyList\nupdate_model_variance <- function(data, params, model) {\n UseMethod(\"update_model_variance\")\n}\n\n#' @keywords internal\nupdate_model_variance.default <- function(data, params, model) {\n if (!isTRUE(params$estimate_residual_variance)) return(model)\n # Update variance components\n variance_result <- update_variance_components(data, params, model)\n model <- modifyList(model, variance_result)\n\n # Apply bounds to residual variance\n model$sigma2 <- min(max(model$sigma2, params$residual_variance_lowerbound),\n params$residual_variance_upperbound)\n\n # Update derived quantities after variance component changes\n model <- update_derived_quantities(data, params, model)\n\n return(model)\n}\n\n# =============================================================================\n# CONVERGENCE CHECKING\n# =============================================================================\n\n#' @keywords internal\ncheck_convergence <- function(data, params, model, elbo, iter) {\n UseMethod(\"check_convergence\")\n}\n\n#' Format the per-iter sigma2 cell for verbose output\n#'\n#' Default returns the scalar sigma2 in `%.4f`. Subclasses\n#' (e.g., mfsusieR's list-of-vectors sigma2; mvsusieR's\n#' matrix sigma2) override to a compact summary string of\n#' fixed width.\n#' @keywords internal\nformat_sigma2_summary <- function(model) {\n UseMethod(\"format_sigma2_summary\")\n}\n#' @keywords internal\nformat_sigma2_summary.default <- function(model) {\n sprintf(\"%.4f\", model$sigma2)\n}\n\n#' Append class-specific extra-diag columns to the verbose row\n#'\n#' Default returns an empty string. Subclasses override to inject\n#' columns such as `max_pi_null`, `max_KL_l`, alpha-entropy\n#' n_eff. Output is appended after the V column in the per-iter\n#' tabular line.\n#' @keywords internal\nformat_extra_diag <- function(model) {\n UseMethod(\"format_extra_diag\")\n}\n#' @keywords internal\nformat_extra_diag.default <- function(model) {\n if (is.null(model$lambda_bias))\n return(\"\")\n lambda_infl <- model$lambda_bias\n # Zero-masking of small finite values happens at source in\n # estimate_lambda_bias; we just sanitize non-finite for display.\n lambda_infl[!is.finite(lambda_infl)] <- 0\n if (length(lambda_infl) != 1)\n stop(\"lambda_bias must be a scalar on the SS path.\")\n lb <- paste0(\"lambda_infl=\", format(lambda_infl, digits = 2,\n scientific = TRUE))\n if (!is.null(model$B_corrected)) {\n B_corrected <- model$B_corrected\n if (length(unique(B_corrected[is.finite(B_corrected)])) == 1) {\n lb <- paste0(lb, \" B_eff=\", format(B_corrected[which(is.finite(B_corrected))[1]],\n digits = 4, scientific = FALSE))\n }\n }\n lb\n}\n\n#' @keywords internal\ncheck_convergence.default <- function(data, params, model, elbo, iter) {\n verbose <- isTRUE(params$verbose)\n V_str <- format_V_summary(model$V)\n chat_str <- format_chat_summary(model)\n sigma2_str <- format_sigma2_summary(model)\n extra_str <- format_extra_diag(model)\n\n # Tabular verbose format (ELBO-convergence path): columns are\n # iter, ELBO, delta, sigma2, mem, V (variable-width, last),\n # plus optional class-specific extras after V.\n verbose_row_fmt <- \"%4d %11.4f %9s %-9s %-7s %s%s%s\"\n verbose_header <- sprintf(\"%-4s %11s %9s %-9s %-7s %s%s\",\n \"iter\", \"ELBO\", \"delta\", \"sigma2\", \"mem\", \"V\",\n if (nzchar(extra_str)) \" extras\" else \"\")\n\n # Skip convergence check on first iteration\n if (iter == 1) {\n model$converged <- FALSE\n if (verbose) {\n elbo_val <- elbo[iter + 1]\n if (!is.na(elbo_val) && is.finite(elbo_val)) {\n message(verbose_header)\n message(sprintf(verbose_row_fmt,\n iter, elbo_val, \"-\", sigma2_str,\n sprintf(\"%.2f GB\", mem_used_gb()),\n paste0(V_str, chat_str),\n if (nzchar(extra_str)) paste0(\" \", extra_str) else \"\",\n \"\"))\n } else {\n message(sprintf(\"iter %3d: sigma2=%s, V=%s%s [mem: %.2f GB]\",\n iter, sigma2_str, V_str, chat_str, mem_used_gb()))\n }\n }\n return(model)\n }\n\n # Calculate difference in ELBO values\n ELBO_diff <- elbo[iter + 1] - model$runtime$prev_elbo\n ELBO_failed <- is.na(ELBO_diff) || is.infinite(ELBO_diff)\n\n if (params$convergence_method == \"pip\" || ELBO_failed) {\n if (ELBO_failed && params$convergence_method == \"elbo\") {\n warning_message(paste0(\"Iteration \", iter, \" produced an NA/infinite ELBO\",\n \" value. Using pip-based convergence this iteration.\"))\n }\n # PIP/alpha convergence. pip_stall_window is reused as the maximum\n # short-cycle lag; it is no longer a \"no improvement\" stop.\n model <- check_alpha_pip_cycle_convergence(data, params, model)\n pip_diff <- model$runtime$pip_diff\n lambda_diff <- if (!is.null(model$runtime$lambda_bias_diff))\n model$runtime$lambda_bias_diff else 0\n # Coordinate EB guard: fit_R_mismatch runs after the SER sweep, so a material\n # lambda update must be consumed by one more sweep before convergence.\n if (isTRUE(model$converged) && lambda_diff > params$tol) {\n model$converged <- FALSE\n model$convergence_reason <- paste0(\"lambda_infl_changed(\",\n format(lambda_diff, digits = 3,\n scientific = TRUE), \")\")\n }\n if (verbose) {\n conv_tag <- if (model$converged)\n paste0(\" -- converged (\", model$convergence_reason, \")\")\n else\n \"\"\n lambda_str <- if (lambda_diff > 0)\n paste0(\", max|d(lambda_infl)|=\", format(lambda_diff, digits = 3,\n scientific = TRUE))\n else \"\"\n message(sprintf(\"iter %3d: max|d(alpha,PIP)|=%.2e%s, V=%s%s%s%s [mem: %.2f GB]\",\n iter, pip_diff, lambda_str, V_str, chat_str,\n if (nzchar(extra_str)) paste0(\", \", extra_str) else \"\",\n conv_tag, mem_used_gb()))\n }\n\n if (model$converged && !is.null(params$unmappable_effects) &&\n params$unmappable_effects %in% c(\"ash\", \"ash_filter_archived\")) {\n model <- run_final_ash_pass(data, params, model)\n }\n return(model)\n }\n\n # Converge when ELBO stabilizes: small non-negative change.\n # A large negative ELBO_diff means the objective dropped, not convergence.\n if (ELBO_diff < -params$tol) {\n warning_message(sprintf(\"ELBO decreased by %.2e at iteration %d\",\n -ELBO_diff, iter))\n }\n model$converged <- (ELBO_diff >= 0 && ELBO_diff < params$tol)\n lambda_diff <- if (!is.null(model$runtime$lambda_bias_diff))\n model$runtime$lambda_bias_diff else 0\n # Coordinate EB guard: fit_R_mismatch runs after the SER sweep, so a material\n # lambda update must be consumed by one more sweep before declaring convergence.\n if (isTRUE(model$converged) && lambda_diff > params$tol)\n model$converged <- FALSE\n\n if (verbose)\n message(sprintf(verbose_row_fmt,\n iter, elbo[iter + 1],\n sprintf(\"%.2e\", ELBO_diff),\n sigma2_str,\n sprintf(\"%.2f GB\", mem_used_gb()),\n paste0(V_str, chat_str),\n if (nzchar(extra_str)) paste0(\" \", extra_str) else \"\",\n if (model$converged) \" converged\" else \"\"))\n\n if (model$converged && !is.null(params$unmappable_effects) &&\n params$unmappable_effects %in% c(\"ash\", \"ash_filter_archived\")) {\n model <- run_final_ash_pass(data, params, model)\n }\n return(model)\n}\n\n# =============================================================================\n# OBJECTIVE FUNCTION (ELBO)\n# =============================================================================\n\n#' Compute the SuSiE ELBO (evidence lower bound)\n#'\n#' Building-block function used by downstream packages implementing\n#' custom IBSS loops.\n#'\n#' @param data Data object.\n#' @param params Params object.\n#' @param model Model object.\n#'\n#' @return Scalar ELBO value.\n#'\n#' @export\n#' @keywords internal\nget_objective <- function(data, params, model) {\n UseMethod(\"get_objective\")\n}\n\n#' @export\n#' @keywords internal\nget_objective.default <- function(data, params, model) {\n if (!is.null(params$unmappable_effects) && params$unmappable_effects == \"inf\") {\n # Compute omega\n L <- nrow(model$alpha)\n omega_res <- compute_omega_quantities(data, model$tau2, model$sigma2)\n omega <- matrix(0, L, data$p)\n\n for (l in seq_len(L)) {\n omega[l, ] <- omega_res$diagXtOmegaX + 1 / model$V[l]\n }\n\n # Compute total ELBO for infinitesimal effects model\n objective <- compute_elbo_inf(\n model$alpha, model$mu, omega, model$lbf,\n model$sigma2, model$tau2, data$n, data$p,\n data$eigen_vectors, data$eigen_values,\n data$VtXty, data$yty\n )\n } else if (params$use_NIG && nrow(model$alpha) == 1) {\n objective <- model$marginal_loglik[1]\n } else if (isTRUE(params$use_NIG)) {\n # NIG L>1: KL[l] is gated to 0 (gIBSS has no coherent ELBO); use the\n # proper variational expected log-likelihood.\n objective <- nig_eloglik(data, params, model)\n } else {\n # Standard ELBO computation. `na.rm = TRUE` so subclasses that\n # leave KL[l] = NA on null-effect rows (mfsusieR, mvsusieR) do\n # not need to override get_objective just to skip NAs.\n objective <- Eloglik(data, model) - sum(model$KL, na.rm = TRUE)\n }\n\n # Add slot prior ELBO terms when c_hat is active.\n # Without these, the ELBO is missing the prior and entropy contributions\n # from the slot activity model.\n if (!is.null(model$c_hat_state)) {\n objective <- objective + slot_prior_elbo(model)\n }\n\n if (is.infinite(objective)) {\n stop(\"get_objective() produced an infinite ELBO value\")\n }\n return(objective)\n}\n\n# =============================================================================\n# EFFECT TRIMMING\n#\n# Zero out effects with negligible prior variance after convergence.\n# =============================================================================\n\n#' @keywords internal\ntrim_null_effects <- function(data, params, model) {\n UseMethod(\"trim_null_effects\")\n}\n\n#' @keywords internal\ntrim_null_effects.default <- function(data, params, model) {\n null_idx <- which(model$V < params$prior_tol)\n if (length(null_idx) == 0) return(model)\n\n model$V[null_idx] <- 0\n model$alpha[null_idx, ] <- rep(model$pi, each = length(null_idx))\n model$mu[null_idx, ] <- 0\n model$mu2[null_idx, ] <- 0\n model$lbf_variable[null_idx, ] <- 0\n model$lbf[null_idx] <- 0\n model$KL[null_idx] <- 0\n\n return(model)\n}\n" }, { "path": "R/mr.ash.R", "content": "#' @title Multiple Regression with Adaptive Shrinkage\n#' \n#' @description Model fitting algorithms for Multiple Regression with\n#' Adaptive Shrinkage (\"Mr.ASH\"). Mr.ASH is a variational empirical\n#' Bayes (VEB) method for multiple linear regression. The fitting\n#' algorithms (locally) maximize the approximate marginal likelihood\n#' (the \"evidence lower bound\", or ELBO) via coordinate-wise updates.\n#' \n#' @details Mr.ASH is a statistical inference method for the following\n#' multiple linear regression model: \\deqn{y | X, \\beta, \\sigma^2 ~\n#' N(X \\beta, \\sigma I_n),} in which the regression coefficients\n#' \\eqn{\\beta} admit a mixture-of-normals prior, \\deqn{\\beta | \\pi,\n#' \\sigma ~ g = \\sum_{k=1}^K N(0, \\sigma^2 \\sigma_k^2).} Each mixture\n#' component in the prior, \\eqn{g}, is a normal density centered at\n#' zero, with variance \\eqn{\\sigma^2 \\sigma_k^2}. \n#' \n#' The fitting algorithm, it run for a large enough number of\n#' iterations, will find an approximate posterior for the regression\n#' coefficients, denoted by \\eqn{q(\\beta)}, residual variance\n#' parameter \\eqn{sigma^2}, and prior mixture weights \\eqn{\\pi_1,\n#' \\ldots, \\pi_K} maximizing the evidence lower bound, \\deqn{F(q, \\pi,\n#' \\sigma^2) = E_q \\log p(y | X, \\beta, \\sigma^2) - \\sum_{j=1}^p\n#' D_{KL}(q_j || g),} where \\eqn{D_{KL}(q_j || g)} denotes the\n#' Kullback-Leibler (KL) divergence, a measure of the \"distance\"\n#' between (approximate) posterior \\eqn{q_j(\\beta_j)} and prior\n#' \\eqn{g(\\beta_j)}. The fitting algorithm iteratively updates the\n#' approximate posteriors \\eqn{q_1, \\ldots, q_p}, separately for each\n#' \\eqn{j = 1, \\ldots, p} (in an order determined by\n#' \\code{update.order}), then separately updates the mixture weights\n#' and \\eqn{\\pi} and residual variance \\eqn{\\sigma^2}. This\n#' coordinate-wise update scheme iterates until the convergence\n#' criterion is met, or until the algorithm hits an upper bound on\n#' the number of iterations (specified by \\code{max.iter}). Coordinate-wise \n#' optimization algorithms for model fitting are implemented in C++ for \n#' efficient handling of large-scale data\n#' \n#' See \\sQuote{References} for more details about the model and\n#' algorithm.\n#'\n#' @param X The input matrix, of dimension (n,p); each column is a\n#' single predictor; and each row is an observation vector. Here, n is\n#' the number of samples and p is the number of predictors. The matrix\n#' cannot be sparse.\n#' \n#' @param y The observed continuously-valued responses, a vector of\n#' length p.\n#' \n#' @param Z The covariate matrix, of dimension (n,k), where k is the\n#' number of covariates. This feature is not yet implemented;\n#' \\code{Z} must be set to \\code{NULL}.\n#' \n#' @param sa2 The vector of prior mixture component variances. The\n#' variances should be in increasing order, starting at zero; that is,\n#' \\code{sort(sa2)} should be the same as \\code{sa2}. When \\code{sa2}\n#' is \\code{NULL}, the default setting is used, \\code{sa2[k] =\n#' (2^(0.05*(k-1)) - 1)^2}, for \\code{k = 1:20}. For this default\n#' setting, \\code{sa2[1] = 0}, and \\code{sa2[20]} is roughly 1.\n#' \n#' @param method_q The algorithm used to update the variational\n#' approximation to the posterior distribution of the regression\n#' coefficients, \\code{method = \"sigma_dep_q\"} and \\code{method =\n#' \"sigma_indep_q\"}, take different approaches to updating the\n#' residual variance \\eqn{sigma^2}.\n#'\n#' @param method_g \\code{method = \"caisa\"}, an abbreviation of\n#' \"Cooridinate Ascent Iterative Shinkage Algorithm\", fits the model\n#' by approximate EM; it iteratively updates the variational\n#' approximation to the posterior distribution of the regression\n#' coefficients (the approximate E-step) and the model parameters\n#' (mixture weights and residual covariance) in an approximate\n#' M-step. Settings \\code{method = \"block\"} and\n#' \\code{method = \"accelerate\"} are considered experimental.\n#' \n#' @param max.iter The maximum number of outer loop iterations allowed.\n#' \n#' @param min.iter The minimum number of outer loop iterations allowed.\n#' \n#' @param beta.init The initial estimate of the (approximate)\n#' posterior mean regression coefficients. This should be \\code{NULL},\n#' or a vector of length p. When \\code{beta.init} is \\code{NULL}, the\n#' posterior mean coefficients are all initially set to zero.\n#' \n#' @param update.pi If \\code{update.pi = TRUE}, the mixture\n#' proportions in the mixture-of-normals prior are estimated from the\n#' data. In the manuscript, \\code{update.pi = TRUE}.\n#' \n#' @param pi The initial estimate of the mixture proportions\n#' \\eqn{\\pi_1, \\ldots, \\pi_K}. If \\code{pi} is \\code{NULL}, the\n#' mixture weights are initialized to \\code{rep(1/K,K)}}, where\n#' \\code{K = length(sa2).\n#' \n#' @param update.sigma2 If \\code{update.sigma2 = TRUE}, the residual\n#' variance \\eqn{sigma^2} is estimated from the data. In the manuscript,\n#' \\code{update.sigma = TRUE}.\n#' \n#' @param sigma2 The initial estimate of the residual variance,\n#' \\eqn{\\sigma^2}. If \\code{sigma2 = NULL}, the residual variance is\n#' initialized to the empirical variance of the residuals based on the\n#' initial estimates of the regression coefficients, \\code{beta.init},\n#' after removing linear effects of the intercept and any covariances.\n#'\n#' @param update.order The order in which the co-ordinate ascent\n#' updates for estimating the posterior mean coefficients are\n#' performed. \\code{update.order} can be \\code{NULL}, \\code{\"random\"},\n#' or any permutation of \\eqn{(1,\\ldots,p)}, where \\code{p} is the number\n#' of columns in the input matrix \\code{X}. When \\code{update.order}\n#' is \\code{NULL}, the co-ordinate ascent updates are performed in\n#' order in which they appear in \\code{X}; this is equivalent to\n#' setting \\code{update.order = 1:p}. When \\code{update.order =\n#' \"random\"}, the co-ordinate ascent updates are performed in a\n#' randomly generated order, and this random ordering is different at\n#' each outer-loop iteration.\n#' \n#' @param standardize The logical flag for standardization of the\n#' columns of X variable, prior to the model fitting. The coefficients\n#' are always returned on the original scale.\n#' \n#' @param intercept When \\code{intercept = TRUE}, an intercept is\n#' included in the regression model.\n#' \n#' @param tol Additional settings controlling behaviour of the model\n#' fitting algorithm. \\code{tol$convtol} controls the termination\n#' criterion for the model fitting. The outer-loop updates stop when\n#' the relative L2 change in the estimates of the posterior mean\n#' coefficients is less than \\code{convtol}, i.e., \\code{||beta_new -\n#' beta_old||_2 / max(1, ||beta_old||_2) < convtol}.\n#' \\code{tol$epstol} is a small, positive number added to the\n#' likelihoods to avoid logarithms of zero.\n#'\n#' @param verbose If \\code{verbose = TRUE}, some information about the\n#' status of the model fitting is printed to the console.\n#' \n#' @return A list object with the following elements:\n#' \n#' \\item{intercept}{The estimated intercept.}\n#' \n#' \\item{beta}{A vector containing posterior mean estimates of the\n#' regression coefficients for all predictors.}\n#' \n#' \\item{sigma2}{The estimated residual variance.}\n#' \n#' \\item{pi}{A vector of containing the estimated mixture\n#' proportions.}\n#' \n#' \\item{iter}{The number of outer-loop iterations that were\n#' performed.}\n#' \n#' \\item{update.order}{The ordering used for performing the\n#' coordinate-wise updates. For \\code{update.order = \"random\"}, the\n#' orderings for outer-loop iterations are provided in a vector of\n#' length \\code{p*max.iter}, where \\code{p} is the number of predictors.}\n#' \n#' \\item{varobj}{A vector of length \\code{numiter}, containing the\n#' value of the variational objective (equal to the negative \"evidence\n#' lower bound\") attained at each (outer-loop) model fitting\n#' iteration. Note that the objective does not account for the\n#' intercept term, even when \\code{intercept = TRUE}; therefore, this\n#' value shoudl be interpreted as being an approximation to the\n#' marginal likelihood \\emph{conditional} on the estimate of the\n#' intercept.}\n#'\n#' \\item{data}{The preprocessed data (X, Z, y) provided as input to the model\n#' fitting algorithm. \\code{data$w} is equal to\n#' \\code{diag(crossprod(X))}, in which \\code{X} is the preprocessed\n#' data matrix. Additionally, \\code{data$sa2} gives the prior variances\n#' used.}\n#' \n#' @seealso \\code{\\link{get.full.posterior}}, \\code{\\link{predict.mr.ash}}\n#' \n#' @references\n#'\n#' Y. Kim (2020), Bayesian shrinkage methods for high dimensional\n#' regression. Ph.D. thesis, University of Chicago.\n#' \n#' @useDynLib susieR, .registration = TRUE\n#'\n#' @importFrom utils modifyList\n#' @importFrom stats var\n#' \n#' @examples\n#' ### generate synthetic data\n#' set.seed(1)\n#' n = 200\n#' p = 300\n#' X = matrix(rnorm(n*p),n,p)\n#' beta = double(p)\n#' beta[1:10] = 1:10\n#' y = X %*% beta + rnorm(n)\n#' \n#' ### fit Mr.ASH\n#' fit.mr.ash = mr.ash(X,y, method_q = \"sigma_indep_q\")\n#' #' fit.mr.ash = mr.ash(X,y, method_q = \"sigma_dep_q\")\n#' \n#' ### prediction routine\n#' Xnew = matrix(rnorm(n*p),n,p)\n#' ynew = Xnew %*% beta + rnorm(n)\n#' ypred = predict(fit.mr.ash, Xnew)\n#'\n#' ### test error\n#' rmse = norm(ynew - ypred, '2') / sqrt(n)\n#' \n#' ### coefficients\n#' betahat = predict(fit.mr.ash, type = \"coefficients\")\n#' # this equals c(fit.mr.ash$intercept, fit.mr.ash$beta)\n#' \n#' @export\n#' \nmr.ash = function(X, y, Z = NULL, sa2 = NULL,\n method_q = c(\"sigma_dep_q\",\"sigma_indep_q\"),\n method_g = c(\"caisa\",\"accelerate\",\"block\"),\n max.iter = 1000, min.iter = 1,\n beta.init = NULL,\n update.pi = TRUE, pi = NULL,\n update.sigma2 = TRUE, sigma2 = NULL,\n update.order = NULL,\n standardize = FALSE, intercept = TRUE,\n tol = set_default_tolerance(), \n verbose = TRUE){\n \n # get sizes\n n = nrow(X)\n p = ncol(X)\n \n # check necessary conditions\n if (!is.null(sa2)) {\n if (any(sa2 < 0)) {\n stop (\"all the mixture component variances must be non-negative.\")\n }\n if (sa2[1] != 0) {\n stop (\"the first mixture component variance sa2[1] must be 0.\")\n }\n }\n \n # check Z\n if (!is.null(Z)) {\n stop(\"covariates are not currently fully implemented; Z should be set to NULL\")\n }\n \n # match method\n method_q = match.arg(method_q)\n method_g = match.arg(method_g)\n \n # set default tolerances unless specified\n tol0 = set_default_tolerance()\n tol = modifyList(tol0,tol,keep.null = TRUE)\n \n # remove covariates\n data = remove_covariate(X, y, Z, standardize, intercept)\n \n # initialize beta\n if ( is.null(beta.init) ){\n data$beta = as.vector(double(p))\n } else {\n if (standardize) {\n data$beta = as.vector(beta.init) * attr(data$X,\"scaled:scale\")\n } else {\n data$beta = as.vector(beta.init)\n }\n }\n data$beta[1] = data$beta[1] + 0 # to make sure beta.init is not modified\n \n # initialize r\n r = data$y - data$X %*% data$beta\n \n # sigma2\n if (is.null(sigma2))\n sigma2 = c(var.n(r))\n \n # precompute x_j^T x_j\n w = colSums(data$X^2)\n data$w = w\n \n # set sa2 if missing\n if ( is.null(sa2) ) {\n sa2 = (2^((0:24) / 25) - 1)^2\n sa2 = sa2 / median(data$w) * n\n }\n K = length(sa2)\n data$sa2 = sa2\n \n # initialize other parameters\n if ( is.null(pi) ) {\n if ( is.null(beta.init) ){\n \n Phi = matrix(1,p,K)/K\n pi = rep(1,K)/K\n \n } else {\n \n S = outer(1/w, sa2, '+') * sigma2\n Phi = -data$beta^2/S/2 - log(S)/2\n Phi = exp(Phi - apply(Phi,1,max))\n Phi = Phi / rowSums(Phi)\n pi = colMeans(Phi)\n \n }\n } else\n Phi = matrix(rep(pi, each = p), nrow = p)\n pi[1] <- pi[1] + 0\n \n # run algorithm\n \n if ( is.null(update.order) ) {\n o = rep(0:(p-1), max.iter)\n } else if (is.numeric(update.order)) {\n o = rep(update.order - 1, max.iter)\n } else if (update.order == \"random\") {\n o = random_order(p, max.iter)\n }\n \n out = caisa_cpp (data$X, w, sa2, pi, data$beta, r, sigma2, o,\n max.iter, min.iter, tol$convtol, tol$epstol,\n method_q, update.pi, update.sigma2, verbose)\n\n ## Convert to plain numeric vectors (drop matrix dim from Armadillo)\n out$beta = c(out$beta)\n out$pi = c(out$pi)\n out$sigma2 = c(out$sigma2)\n\n if (method_q == \"sigma_scaled_beta\") {\n out$beta = out$beta * sqrt(out$sigma2)\n }\n\n ## polish return object\n out$intercept = c(data$ZtZiZy - data$ZtZiZX %*% out$beta)\n data[\"beta\"] = NULL\n out$data = data\n out$update.order = o\n \n ## rescale beta is needed\n if (standardize)\n out$beta = out$beta / attr(data$X, \"scaled:scale\")\n class(out) <- c(\"mr.ash\", \"list\")\n \n ## warn if necessary\n if (update.pi & out$pi[K] > 1/K) {\n warning(sprintf(paste(\"The mixture proportion associated with the\",\n \"largest prior variance is greater than %0.2e;\",\n \"this indicates that the model fit could be\",\n \"improved by using a larger setting of the\",\n \"prior variance. Consider increasing the range\",\n \"of the variances \\\"sa2\\\".\"),1/K))\n }\n \n return(out)\n}\n\n#' @title Extract Regression Coefficients from Mr.ASH Fit\n#'\n#' @description Retrieve posterior mean estimates of the regression\n#' coefficients in a Mr.ASH model.\n#' \n#' @param object A Mr.ASH fit, usually the result of calling\n#' \\code{mr.ash}.\n#'\n#' @param ... Additional arguments passed to the default S3 method.\n#' \n#' @return A p+1 vector. The first element gives the estimated\n#' intercept, and the remaining p elements are the estimated\n#' regression coefficients.\n#' \n#' ## generate synthetic data\n#' set.seed(1)\n#' n = 200\n#' p = 300\n#' X = matrix(rnorm(n*p),n,p)\n#' beta = double(p)\n#' beta[1:10] = 1:10\n#' y = X %*% beta + rnorm(n)\n#' \n#' ## fit mr.ash\n#' fit.mr.ash = mr.ash(X, y)\n#' \n#' ## coefficient\n#' coef.mr.ash = coef(fit.mr.ash)\n#' intercept = coef.mr.ash[1]\n#' beta = coef.mr.ash[-1]\n#' \n#' @importFrom stats coef\n#' \n#' @export coef.mr.ash\n#' \n#' @export\n#' \ncoef.mr.ash = function (object, ...)\n c(object$intercept,object$beta)\n\n#' @title Predict Outcomes or Extract Coefficients from Mr.ASH Fit\n#'\n#' @description This function predicts outcomes (y) given the observed\n#' variables (X) and a Mr.ASH model; alternatively, retrieve the\n#' estimates of the regression coefficients.\n#'\n#' @param object A mr_ash fit, usually the result of calling\n#' \\code{mr.ash}.\n#'\n#' @param newx The input matrix, of dimension (n,p); each column is a\n#' single predictor; and each row is an observation vector. Here, n is\n#' the number of samples and p is the number of predictors. When\n#' \\code{newx} is \\code{NULL}, the fitted values for the training data\n#' are provided.\n#' \n#' @param type The type of output. For \\code{type = \"response\"},\n#' predicted or fitted outcomes are returned; for \\code{type =\n#' \"coefficients\"}, the estimated coefficients are returned.\n#' \n#' @param ... Additional arguments passed to the default S3 method.\n#'\n#' @return For \\code{type = \"response\"}, predicted or fitted outcomes\n#' are returned; for \\code{type = \"coefficients\"}, the estimated\n#' coefficients are returned.\n#' \n#' @examples\n#' ## generate synthetic data\n#' set.seed(1)\n#' n = 200\n#' p = 300\n#' X = matrix(rnorm(n*p),n,p)\n#' beta = double(p)\n#' beta[1:10] = 1:10\n#' y = X %*% beta + rnorm(n)\n#' \n#' ## fit mr.ash\n#' fit.mr.ash = mr.ash(X, y)\n#' \n#' ## predict\n#' Xnew = matrix(rnorm(n*p),n,p)\n#' ypred = predict(fit.mr.ash, Xnew)\n#' \n#' @importFrom stats predict\n#' \n#' @export predict.mr.ash\n#' \n#' @export\n#' \npredict.mr.ash = function(object,newx = NULL,\n type=c(\"response\",\"coefficients\"),...) {\n \n type <- match.arg(type)\n if (type == \"coefficients\"){\n if(!missing(newx))\n stop(\"Do not supply newx when predicting coefficients\")\n return(coef(object))\n }\n else if(missing(newx))\n return(object$fitted)\n else {\n if (!all(object$data$Z == 1))\n stop(\"predict.mr.ash is not implemented for covariates Z other than \",\n \"intercept\")\n return(drop(object$intercept + newx %*% coef(object)[-1]))\n }\n}\n\nset_default_tolerance = function(){\n epstol = 1e-12\n convtol = 1e-4\n \n return ( list(epstol = epstol, convtol = convtol ) )\n}\n\n#' @title Approximation Posterior Expectations from Mr.ASH Fit\n#'\n#' @description Recover the parameters specifying the variational\n#' approximation to the posterior distribution of the regression\n#' coefficients. To streamline the model fitting implementation, and\n#' to reduce memory requirements, \\code{\\link{mr.ash}} does not store\n#' all the parameters needed to specify the approximate posterior.\n#' \n#' @param fit A Mr.ASH fit obtained, for example, by running\n#' \\code{mr.ash}.\n#' \n#' @return A list object with the following elements:\n#' \n#' \\item{phi}{An p x K matrix containing the posterior assignment\n#' probabilities, where p is the number of predictors, and K is the\n#' number of mixture components. (Each row of \\code{phi} should sum to\n#' 1.)}\n#' \n#' \\item{m}{An p x K matrix containing the posterior means conditional\n#' on assignment to each mixture component.}\n#' \n#' \\item{s2}{An p x K matrix containing the posterior variances\n#' conditional on assignment to each mixture component.}\n#' \n#' @examples\n#' ## generate synthetic data\n#' set.seed(1)\n#' n = 200\n#' p = 300\n#' X = matrix(rnorm(n*p),n,p)\n#' beta = double(p)\n#' beta[1:10] = 1:10\n#' y = X %*% beta + rnorm(n)\n#' \n#' ## fit mr.ash\n#' fit.mr.ash = mr.ash(X, y)\n#' \n#' ## recover full posterior\n#' full.post = get.full.posterior(fit.mr.ash)\n#' \n#' @export\n#' \nget.full.posterior <- function(fit) {\n \n # compute residual\n r = fit$data$y - fit$data$X %*% fit$beta\n \n # compute bw and s2\n bw = as.vector((t(fit$data$X) %*% r) + fit$data$w * fit$beta)\n s2 = fit$sigma2 / outer(fit$data$w, 1/fit$data$sa2, '+')\n \n # compute m, phi\n m = bw * s2 / fit$sigma2\n phi = -log(1 + outer(fit$data$w,fit$data$sa2))/2 + m * (bw/2/fit$sigma2)\n phi = c(fit$pi) * t(exp(phi - apply(phi,1,max)))\n phi = t(phi) / colSums(phi)\n return (list(phi = phi, m = m, s2 = s2))\n}\n\ngibbs.sampling = function(X, y, pi, sa2 = (2^((0:19) / 20) - 1)^2,\n max.iter = 1500, burn.in = 500,\n standardize = FALSE, intercept = TRUE,\n sigma2 = NULL, beta.init = NULL,\n verbose = TRUE){\n \n # get sizes\n n = nrow(X)\n p = ncol(X)\n \n # remove covariates\n data = remove_covariate(X, y, NULL, standardize, intercept)\n if ( is.null(beta.init) )\n data$beta = as.vector(double(p))\n else\n data$beta = as.vector(beta.init)\n \n # initialize r\n r = data$y - data$X %*% data$beta\n \n # sigma2\n if ( is.null(sigma2) )\n sigma2 = c(var(r))\n \n # precalculate\n w = colSums(data$X^2)\n data$w = w\n \n # gibbs sampling\n out = gibbs.sampling(data$X, w, sa2, pi, data$beta, r, sigma2, max.iter, burn.in, verbose)\n out$data = data\n out$mu = c(data$ZtZiZy - data$ZtZiZX %*% out$beta)\n \n return (out)\n}\n\nvar.n = function(x) {\n a = x - mean(x)\n return (sum(a^2) / length(a))\n}\n" }, { "path": "R/mr.ash.rss.R", "content": "#' @title Bayesian Multiple Regression with Mixture-of-Normals Prior (RSS)\n#'\n#' @description This function performs Bayesian multiple regression with a\n#' mixture-of-normals prior using summary statistics (RSS: Regression with\n#' Summary Statistics). It uses a C++ implementation for efficient computation.\n#'\n#' @param bhat Numeric vector of observed effect sizes (standardized).\n#' @param shat Numeric vector of standard errors of effect sizes.\n#' @param R Numeric matrix of the correlation matrix.\n#' @param var_y Numeric value of the variance of the outcome.\n#' If NULL, it is set to Inf (effects on standardized scale).\n#' @param n Integer value of the sample size.\n#' @param s0 Numeric vector of prior variances for the mixture components.\n#' @param w0 Numeric vector of prior weights for the mixture components.\n#' @param sigma2_e Numeric value of the initial error variance estimate.\n#' If \\code{NULL} (default), initialized to \\code{var_y} (matching\n#' \\code{mr.ash} behavior of using residual variance with zero\n#' initialization), or 1 when \\code{var_y = Inf}.\n#' @param mu1_init Numeric vector of initial values for the posterior mean of\n#' the coefficients. Default is \\code{numeric(0)} (initialize to zero).\n#' @param tol Numeric value of the convergence tolerance. Default is 1e-8.\n#' @param max_iter Integer value of the maximum number of iterations.\n#' Default is 1e5.\n#' @param z Numeric vector of Z-scores. If not provided, computed as\n#' \\code{bhat / shat}.\n#' @param update_w0 Logical value indicating whether to update the mixture\n#' weights. Default is TRUE.\n#' @param update_sigma Logical value indicating whether to update the error\n#' variance. Default is TRUE.\n#' @param compute_ELBO Logical value indicating whether to compute the\n#' Evidence Lower Bound (ELBO). Default is TRUE.\n#' @param standardize Logical value indicating whether to standardize the\n#' input data. Default is FALSE.\n#'\n#' @return A list containing the following components:\n#' \\describe{\n#' \\item{beta}{Numeric vector of posterior mean coefficients (same as mu1).}\n#' \\item{sigma2}{Numeric value of the residual variance (same as sigma2_e).}\n#' \\item{pi}{Numeric vector of mixture weights (same as w0).}\n#' \\item{iter}{Integer, number of iterations performed.}\n#' \\item{varobj}{Numeric vector of ELBO values per iteration.}\n#' \\item{mu1}{Numeric vector of the posterior mean of the coefficients.}\n#' \\item{sigma2_1}{Numeric vector of the posterior variance of the coefficients.}\n#' \\item{w1}{Numeric matrix of the posterior assignment probabilities.}\n#' \\item{sigma2_e}{Numeric value of the error variance.}\n#' \\item{w0}{Numeric vector of the mixture weights.}\n#' \\item{ELBO}{Numeric value of the Evidence Lower Bound (if \\code{compute_ELBO = TRUE}).}\n#' }\n#'\n#' @examples\n#' # Generate example data\n#' set.seed(985115)\n#' n <- 350\n#' p <- 16\n#' sigmasq_error <- 0.5\n#' zeroes <- rbinom(p, 1, 0.6)\n#' beta.true <- rnorm(p, 1, sd = 4)\n#' beta.true[zeroes] <- 0\n#'\n#' X <- cbind(matrix(rnorm(n * p), nrow = n))\n#' X <- scale(X, center = TRUE, scale = FALSE)\n#' y <- X %*% matrix(beta.true, ncol = 1) + rnorm(n, 0, sqrt(sigmasq_error))\n#' y <- scale(y, center = TRUE, scale = FALSE)\n#'\n#' # Set the prior\n#' K <- 9\n#' sigma0 <- c(0.001, .1, .5, 1, 5, 10, 20, 30, .005)\n#' omega0 <- rep(1 / K, K)\n#'\n#' # Calculate summary statistics\n#' b.hat <- sapply(1:p, function(j) {\n#' summary(lm(y ~ X[, j]))$coefficients[-1, 1]\n#' })\n#' s.hat <- sapply(1:p, function(j) {\n#' summary(lm(y ~ X[, j]))$coefficients[-1, 2]\n#' })\n#' R.hat <- cor(X)\n#' var_y <- var(y)\n#' sigmasq_init <- 1.5\n#'\n#' # Run mr.ash.rss\n#' out <- mr.ash.rss(b.hat, s.hat,\n#' R = R.hat, var_y = var_y, n = n,\n#' sigma2_e = sigmasq_init, s0 = sigma0, w0 = omega0,\n#' mu1_init = rep(0, ncol(X)), tol = 1e-8, max_iter = 1e5,\n#' update_w0 = TRUE, update_sigma = TRUE, compute_ELBO = TRUE,\n#' standardize = FALSE\n#' )\n#'\n#' @export\nmr.ash.rss <- function(bhat, shat, R, var_y, n,\n s0, w0,\n sigma2_e = NULL, mu1_init = numeric(0),\n tol = 1e-8, max_iter = 1e5, z = numeric(0),\n update_w0 = TRUE, update_sigma = TRUE,\n compute_ELBO = TRUE, standardize = FALSE) {\n if (is.null(var_y)) var_y <- Inf\n if (identical(z, numeric(0))) z <- bhat / shat\n\n # Default sigma2_e: use var_y when available (matches mr.ash behavior of\n # initializing to var(residuals) when beta.init is zero, since var(y - X*0) = var(y)).\n # When var_y is Inf (standardized scale), default to 1.\n if (is.null(sigma2_e)) {\n sigma2_e <- if (is.finite(var_y)) var_y else 1\n }\n\n result <- mr_ash_rss_cpp(\n bhat = bhat, shat = shat, z = z, R = R,\n var_y = var_y, n = n, sigma2_e = sigma2_e,\n s0 = s0, w0 = w0, mu1_init = mu1_init,\n tol = tol, max_iter = max_iter,\n update_w0 = update_w0, update_sigma = update_sigma,\n compute_ELBO = compute_ELBO, standardize = standardize\n )\n\n # Add mr.ash-compatible output names for consistency\n result$beta <- c(result$mu1) # posterior mean coefficients\n result$sigma2 <- c(result$sigma2_e) # residual variance (scalar)\n result$pi <- c(result$w0) # mixture weights\n result$iter <- as.integer(c(result$iter)) # iteration count\n result$varobj <- c(result$varobj) # ELBO per iteration\n\n return(result)\n}\n" }, { "path": "R/predict.susie.R", "content": "#' @title Extract regression coefficients from susie fit\n#'\n#' @param object A susie fit.\n#'\n#' @param \\dots Additional arguments passed to the generic \\code{coef}\n#' method.\n#'\n#' @return A p+1 vector, the first element being an intercept, and the\n#' remaining p elements being estimated regression coefficients.\n#'\n#' @importFrom stats coef\n#'\n#' @method coef susie\n#'\n#' @export coef.susie\n#'\n#' @export\n#'\ncoef.susie <- function(object, ...) {\n s <- object\n # Compute mappable effects\n mappable_coef <- colSums(s$alpha * s$mu) / s$X_column_scale_factors\n\n if (!is.null(s$theta)) {\n total_coef <- mappable_coef + s$theta / s$X_column_scale_factors\n } else {\n total_coef <- mappable_coef\n }\n\n return(c(s$intercept, total_coef))\n}\n\n#' @title Predict outcomes or extract coefficients from susie fit.\n#'\n#' @param object A susie fit.\n#'\n#' @param newx A new value for X at which to do predictions.\n#'\n#' @param type The type of output. For \\code{type = \"response\"},\n#' predicted or fitted outcomes are returned; for \\code{type =\n#' \"coefficients\"}, the estimated coefficients are returned.\n#'\n#' @param \\dots Other arguments used by generic predict function. These\n#' extra arguments are not used here.\n#'\n#' @return For \\code{type = \"response\"}, predicted or fitted outcomes\n#' are returned; for \\code{type = \"coefficients\"}, the estimated\n#' coefficients are returned. If the susie fit has intercept =\n#' \\code{NA} (which is common when using \\code{susie_ss}) then\n#' predictions are computed using an intercept of 0, and a warning is\n#' emitted.\n#'\n#' @importFrom stats coef\n#'\n#' @method predict susie\n#'\n#' @export predict.susie\n#'\n#' @export\n#'\npredict.susie <- function(object, newx = NULL,\n type = c(\"response\", \"coefficients\"), ...) {\n s <- object\n type <- match.arg(type)\n if (type == \"coefficients\") {\n if (!missing(newx)) {\n stop(\"Do not supply newx when predicting coefficients\")\n }\n return(coef(s))\n }\n if (missing(newx)) {\n return(s$fitted)\n }\n if (is.na(s$intercept)) {\n warning_message(\"The prediction assumes intercept = 0\")\n return(drop(newx %*% coef(s)[-1]))\n } else {\n return(drop(s$intercept + newx %*% coef(s)[-1]))\n }\n}\n" }, { "path": "R/refinement.R", "content": "#' Block coordinate ascent for iterative model refinement.\n#'\n#' Generic framework for post-convergence refinement of fitted models.\n#' Repeatedly applies a block update (\\code{step_fn}) to a fitted model,\n#' monitoring ELBO for convergence and stability. Both CS refinement\n#' (\\code{\\link{run_refine}}) and residual variance estimation (mvsusieR)\n#' are instances of block coordinate ascent over different parameter blocks.\n#'\n#' Convergence is reached when either:\n#' \\itemize{\n#' \\item \\code{step_fn} returns \\code{converged = TRUE}\n#' (the block update signals no further improvement), or\n#' \\item the relative ELBO change falls below \\code{tol}\n#' (ELBO stabilized across block updates).\n#' }\n#'\n#' A warning is issued if the ELBO decreases between iterations.\n#'\n#' @param model Fitted model (e.g., from \\code{susie_workhorse} or\n#' \\code{mvsusie_workhorse}).\n#' @param data Data object passed to \\code{step_fn}.\n#' @param step_fn A function with signature\n#' \\code{function(model, data, iter)} that performs one block coordinate\n#' update. Must return a named list with elements:\n#' \\describe{\n#' \\item{model}{(required) The updated model.}\n#' \\item{data}{(optional) Updated data object, e.g. after changing\n#' residual variance. If \\code{NULL}, the data is unchanged.}\n#' \\item{converged}{(optional) Logical; if \\code{TRUE}, stop\n#' iterating.}\n#' \\item{log_msg}{(optional) Character string appended to verbose\n#' output.}\n#' }\n#' @param max_iter Maximum number of block ascent iterations\n#' (default 100).\n#' @param tol Convergence tolerance for relative ELBO change\n#' (default 1e-3).\n#' @param verbose If \\code{TRUE}, print progress each iteration\n#' (default \\code{FALSE}).\n#'\n#' @return The refined model, with \\code{model$converged} set to\n#' \\code{TRUE} or \\code{FALSE}.\n#'\n#' @export\nblock_coordinate_ascent <- function(model, data, step_fn,\n max_iter = 100, tol = 1e-3,\n verbose = FALSE) {\n prev_elbo <- susie_get_objective(model)\n prev_model <- model\n converged <- FALSE\n\n for (iter in seq_len(max_iter)) {\n result <- step_fn(model, data, iter)\n model <- result$model\n if (!is.null(result$data)) data <- result$data\n\n current_elbo <- susie_get_objective(model)\n elbo_change <- current_elbo - prev_elbo\n\n # If ELBO decreased, the step did not improve the objective.\n # Revert to the previous model and treat as converged.\n if (elbo_change < 0) {\n if (verbose)\n message(sprintf(\n \"Block ascent iter %d: update did not improve ELBO (change=%.4g); \",\n iter, elbo_change),\n \"rejecting update and stopping.\")\n model <- prev_model\n converged <- TRUE\n break\n }\n\n if (verbose) {\n msg <- sprintf(\"Block ascent iter %d: ELBO=%.4f, change=%.4g\",\n iter, current_elbo, elbo_change)\n if (!is.null(result$log_msg))\n msg <- paste0(msg, \", \", result$log_msg)\n message(msg)\n }\n\n # Convergence: step_fn signals done, or ELBO stabilized\n if (isTRUE(result$converged)) {\n converged <- TRUE\n break\n }\n elbo_delta <- abs(elbo_change) / max(1, abs(current_elbo))\n if (elbo_delta < tol) {\n converged <- TRUE\n break\n }\n\n prev_elbo <- current_elbo\n prev_model <- model\n }\n\n model$converged <- converged\n if (!converged)\n warning_message(\"Block coordinate ascent did not converge in \",\n max_iter, \" iterations\")\n return(model)\n}\n\n\n# Credible set refinement via block coordinate ascent.\n#\n# For each credible set, perturbs prior weights (zeroing out the CS\n# variables) and re-fits via a two-step procedure:\n# Step 1: fit with zeroed CS weights (explores alternative signals)\n# Step 2: re-fit with original weights, warm-started from Step 1\n# The best candidate (highest ELBO) is accepted if it improves beyond\n# tolerance. This is repeated until no further improvement.\n#\n# @keywords internal\nrun_refine <- function(model, data, params) {\n\n if (!is.null(params$model_init))\n warning_message(\"The given model_init is not used in refinement\")\n\n pw_s <- extract_prior_weights(model)\n\n # One block coordinate step: try refining each CS, pick best candidate.\n cs_refine_step <- function(model, data, iter) {\n if (is.null(model$sets) || length(model$sets$cs) == 0)\n return(list(model = model, converged = TRUE))\n\n candidates <- list()\n for (cs_idx in seq_along(model$sets$cs)) {\n # Zero out prior weights for variables in this CS\n pw_cs <- pw_s\n pw_cs[model$sets$cs[[cs_idx]]] <- 0\n if (all(pw_cs == 0)) break\n\n # Step 1: fit with zeroed CS weights (no initialization)\n p1 <- params\n p1$prior_weights <- reconstruct_full_weights(pw_cs, model$null_weight)\n p1$null_weight <- model$null_weight\n p1$model_init <- NULL\n p1$verbose <- FALSE\n p1$track_fit <- FALSE\n p1$refine <- FALSE\n m1 <- susie_workhorse(data, p1)\n\n # Step 2: re-fit with original weights, warm-started from Step 1\n init <- list(alpha = m1$alpha, mu = m1$mu, mu2 = m1$mu2)\n class(init) <- \"susie\"\n p2 <- params\n p2$prior_weights <- reconstruct_full_weights(pw_s, model$null_weight)\n p2$null_weight <- model$null_weight\n p2$model_init <- init\n p2$verbose <- FALSE\n p2$track_fit <- FALSE\n p2$refine <- FALSE\n candidates <- c(candidates, list(susie_workhorse(data, p2)))\n }\n\n if (length(candidates) == 0)\n return(list(model = model, converged = TRUE))\n\n elbos <- sapply(candidates, susie_get_objective)\n current_elbo <- susie_get_objective(model)\n\n if (max(elbos) - current_elbo > params$tol) {\n # Accept best candidate\n list(model = candidates[[which.max(elbos)]])\n } else {\n # No improvement beyond tolerance -- converged\n list(model = model, converged = TRUE)\n }\n }\n\n block_coordinate_ascent(model, data, cs_refine_step,\n max_iter = 100, tol = params$tol,\n verbose = params$verbose)\n}\n" }, { "path": "R/rss_lambda_methods.R", "content": "# =============================================================================\n# OMEGA OPTIMIZATION TOLERANCES\n#\n# Named constants for multi-panel mixture weight optimization.\n# Collected here to avoid scattered magic numbers.\n# =============================================================================\n\n.omega_tol <- list(\n convergence = 1e-3, # max|delta omega| to skip future updates\n grid_spacing = 0.25, # K=2 warm-start grid resolution\n fw_stop = 1e-6, # Frank-Wolfe improvement stopping criterion\n fw_max_iter = 5L # Frank-Wolfe max iterations\n)\n\n# =============================================================================\n# DATA INITIALIZATION & CONFIGURATION\n#\n# Functions for data object setup, configuration, and preprocessing.\n# These prepare data objects for model fitting and handle data-specific\n# configurations like unmappable effects.\n#\n# Functions: configure_data, get_var_y\n# =============================================================================\n\n# Configure data\n#' @keywords internal\nconfigure_data.rss_lambda <- function(data, params) {\n return(configure_data.default(data, params))\n}\n\n# Get variance of y\n#' @keywords internal\nget_var_y.rss_lambda <- function(data, ...) {\n return(1)\n}\n\n# =============================================================================\n# MODEL INITIALIZATION & SETUP\n#\n# Functions for initializing model objects and setting up initial states.\n# These create model matrices, initialize fitted values, and prepare\n# the SuSiE model for iterative fitting.\n#\n# Functions: initialize_susie_model, initialize_fitted, validate_prior, track_ibss_fit\n# =============================================================================\n\n# Initialize SuSiE model\n#' @keywords internal\ninitialize_susie_model.rss_lambda <- function(data, params, var_y, ...) {\n # Base model\n model <- initialize_matrices(data, params, var_y)\n\n # Initialize SinvRj and RjSinvRj\n eigen_R <- get_eigen_R(data, model)\n D <- eigen_R$values\n V <- eigen_R$vectors\n Vt <- t(V)\n Dinv <- compute_Dinv(model, data)\n\n model$SinvRj <- V %*% (Dinv * D * Vt)\n model$RjSinvRj <- colSums(Vt * (Dinv * D^2 * Vt))\n\n return(model)\n}\n\n# Initialize fitted values.\n#' @keywords internal\ninitialize_fitted.rss_lambda <- function(data, mat_init) {\n return(list(Rz = as.vector(compute_Rv(data, colSums(mat_init$alpha * mat_init$mu)))))\n}\n\n# Validate prior variance\n#' @keywords internal\nvalidate_prior.rss_lambda <- function(data, params, model, ...) {\n return(validate_prior.default(data, params, model, ...))\n}\n\n# Track core parameters for tracking\n#' @keywords internal\ntrack_ibss_fit.rss_lambda <- function(data, params, model, tracking, iter, elbo, ...) {\n return(track_ibss_fit.default(data, params, model, tracking, iter, elbo, ...))\n}\n\n# =============================================================================\n# SINGLE EFFECT REGRESSION & ELBO\n#\n# Core functions for single effect regression computation and ELBO calculation.\n# These handle the mathematical core of SuSiE including residual computation, SER\n# statistics, posterior moments, and log-likelihood calculations for the ELBO.\n#\n# Functions: compute_residuals, compute_ser_statistics, SER_posterior_e_loglik,\n# calculate_posterior_moments, compute_kl, get_ER2, Eloglik, loglik, neg_loglik\n# =============================================================================\n\n# Compute residuals for single effect regression\n#' @keywords internal\ncompute_residuals.rss_lambda <- function(data, params, model, l, ...) {\n # Remove lth effect from fitted values (scaled by slot weight)\n sw_l <- get_slot_weight(model, l)\n Rz_without_l <- model$Rz - sw_l * compute_Rv(data, model$alpha[l, ] * model$mu[l, ])\n\n # Store unified residuals in model\n model$residuals <- data$z - Rz_without_l\n model$fitted_without_l <- Rz_without_l\n model$residual_variance <- 1 # RSS lambda uses normalized residual variance\n\n return(model)\n}\n\n# Compute SER statistics\n#' @keywords internal\ncompute_ser_statistics.rss_lambda <- function(data, params, model, l, ...) {\n signal <- as.vector(crossprod(model$SinvRj, model$residuals))\n shat2 <- 1 / model$RjSinvRj\n betahat <- signal * shat2\n\n # Optimization parameters\n optim_init <- log(max(c(betahat^2 - shat2, 1e-6), na.rm = TRUE))\n optim_bounds <- c(-30, 15)\n optim_scale <- \"log\"\n\n return(list(\n betahat = betahat,\n shat2 = shat2,\n optim_init = optim_init,\n optim_bounds = optim_bounds,\n optim_scale = optim_scale\n ))\n}\n\n# SER posterior expected log-likelihood\n#' @keywords internal\nSER_posterior_e_loglik.rss_lambda <- function(data, params, model, l) {\n Eb <- model$alpha[l, ] * model$mu[l, ]\n Eb2 <- model$alpha[l, ] * model$mu2[l, ]\n eigen_R <- get_eigen_R(data, model)\n V <- eigen_R$vectors\n Dinv <- compute_Dinv(model, data)\n rR <- compute_Rv(data, model$residuals)\n SinvEb <- V %*% (Dinv * crossprod(V, Eb))\n\n return(-0.5 * (-2 * sum(rR * SinvEb) + sum(model$RjSinvRj * Eb2)))\n}\n\n# Calculate posterior moments for single effect regression\n#' @keywords internal\ncalculate_posterior_moments.rss_lambda <- function(data, params, model, V, l, ...) {\n shat2 <- 1 / model$RjSinvRj\n\n post_var <- V * shat2 / (V + shat2)\n signal <- as.vector(crossprod(model$SinvRj, model$residuals))\n betahat <- signal * (1 / model$RjSinvRj)\n post_mean <- post_var / shat2 * betahat\n post_mean2 <- post_var + post_mean^2\n\n # Store posterior moments in model\n model$mu[l, ] <- post_mean\n model$mu2[l, ] <- post_mean2\n\n return(model)\n}\n\n# Calculate KL divergence\n#' @keywords internal\ncompute_kl.rss_lambda <- function(data, params, model, l) {\n model <- compute_kl.default(data, params, model, l)\n return(model)\n}\n\n# Expected squared residuals\n#' @keywords internal\nget_ER2.rss_lambda <- function(data, model) {\n # Eigen decomposition components\n eigen_R <- get_eigen_R(data, model)\n D <- eigen_R$values\n V <- eigen_R$vectors\n Dinv <- compute_Dinv(model, data)\n\n # Cached quantities\n Vtz <- get_Vtz(data, model)\n zbar <- model$zbar\n postb2 <- model$diag_postb2\n\n # z^T S^{-1} z (use model z_null_norm2 if omega changed, else data)\n # When lambda=0, null-space components are projected out (ignored).\n z_null_norm2 <- if (!is.null(model$z_null_norm2)) model$z_null_norm2 else data$z_null_norm2\n zSinvz <- sum((Dinv * Vtz) * Vtz)\n if (data$lambda > 0) zSinvz <- zSinvz + z_null_norm2 / data$lambda\n\n # -2 zbar^T S^{-1} z\n tmp <- V %*% (Dinv * (D * Vtz))\n term2 <- -2 * sum(tmp * zbar)\n\n # zbar^T R S^{-1} R zbar\n Vtzbar <- crossprod(V, zbar)\n term3 <- sum((Vtzbar^2) * (Dinv * D^2))\n\n # RZ2 = sum((Z %*% RSinvR) * Z)\n VtZ <- model$Z %*% V\n term4 <- sum((VtZ^2) %*% (Dinv * D^2))\n\n # diag(RSinvR)^T postb2\n diag_RSinvR <- rowSums((V^2) * rep(Dinv * D^2, each = nrow(V)))\n term5 <- sum(diag_RSinvR * postb2)\n\n return(zSinvz + term2 + term3 - term4 + term5)\n}\n\n# Expected log-likelihood\n#' @keywords internal\nEloglik.rss_lambda <- function(data, model) {\n D <- get_eigen_R(data, model)$values\n d <- model$sigma2 * D + data$lambda\n # When lambda=0, zero eigenvalues give d=0; project out null-space.\n d_pos <- d[d > 0]\n r_eff <- length(d_pos)\n return(-(r_eff / 2) * log(2 * pi) - 0.5 *\n sum(log(d_pos)) - 0.5 * get_ER2.rss_lambda(data, model))\n}\n\n# Log-likelihood for RSS\n#' @keywords internal\nloglik.rss_lambda <- function(data, params, model, V, ser_stats, l = NULL, ...) {\n # Wakefield ABF using betahat/shat2 from ser_stats (supports inflation)\n shat2 <- pmax(ser_stats$shat2, .Machine$double.eps)\n lbf <- -0.5 * log(1 + V / shat2) +\n 0.5 * ser_stats$betahat^2 * V / (shat2 * (V + shat2))\n\n # Stabilize logged Bayes Factor\n stable_res <- lbf_stabilization(lbf, model$pi, ser_stats$shat2)\n\n # Compute posterior weights\n weights_res <- compute_posterior_weights(stable_res$lpo)\n\n # Store in model if l is provided, otherwise return lbf_model for prior variance optimization\n if (!is.null(l)) {\n model$alpha[l, ] <- weights_res$alpha\n model$lbf[l] <- weights_res$lbf_model\n model$lbf_variable[l, ] <- stable_res$lbf\n return(model)\n } else {\n return(weights_res$lbf_model)\n }\n}\n\n#' @keywords internal\nneg_loglik.rss_lambda <- function(data, params, model, V_param, ser_stats, ...) {\n # Convert parameter to V based on optimization scale (always log for RSS lambda)\n V <- exp(V_param)\n lbf_model <- loglik.rss_lambda(data, params, model, V, ser_stats)\n return(-lbf_model)\n}\n\n# =============================================================================\n# MODEL UPDATES & FITTING\n#\n# Functions for iterative model updates and variance component estimation.\n# These handle the dynamic aspects of model fitting including fitted value\n# updates and variance component estimation.\n#\n# Functions: update_fitted_values, update_variance_components, update_derived_quantities\n# =============================================================================\n\n# Update fitted values\n#' @keywords internal\nupdate_fitted_values.rss_lambda <- function(data, params, model, l, ...) {\n # Add back lth effect (scaled by slot weight)\n sw_l <- get_slot_weight(model, l)\n model$Rz <- model$fitted_without_l + sw_l *\n as.vector(compute_Rv(data, model$alpha[l, ] * model$mu[l, ]))\n model <- precompute_rss_lambda_terms(data, model)\n\n return(model)\n}\n\n# Update model variance\n#' @keywords internal\nupdate_model_variance.rss_lambda <- function(data, params, model) {\n if (!isTRUE(params$estimate_residual_variance)) return(model)\n\n variance_result <- update_variance_components(data, params, model)\n model <- modifyList(model, variance_result)\n model$sigma2 <- min(max(model$sigma2, params$residual_variance_lowerbound),\n params$residual_variance_upperbound)\n model <- update_derived_quantities(data, params, model)\n\n return(model)\n}\n\n# Update variance components\n#' @keywords internal\n#' @importFrom stats optimize\nupdate_variance_components.rss_lambda <- function(data, params, model, ...) {\n if (!isTRUE(params$estimate_residual_variance)) return(list())\n\n upper_bound <- 1 - data$lambda\n objective <- function(sigma2) {\n temp_model <- model\n temp_model$sigma2 <- sigma2\n Eloglik.rss_lambda(data, temp_model)\n }\n est_sigma2 <- optimize(objective, interval = c(1e-4, upper_bound),\n maximum = TRUE)$maximum\n if (objective(est_sigma2) < objective(upper_bound))\n est_sigma2 <- upper_bound\n\n list(sigma2 = est_sigma2)\n}\n\n# Update derived quantities\n#' @keywords internal\nupdate_derived_quantities.rss_lambda <- function(data, params, model) {\n eigen_R <- get_eigen_R(data, model)\n Dinv <- compute_Dinv(model, data)\n V <- eigen_R$vectors\n D <- eigen_R$values\n Vt <- t(V)\n\n # Update SinvRj and RjSinvRj\n model$SinvRj <- V %*% (Dinv * D * Vt)\n model$RjSinvRj <- colSums(Vt * (Dinv * (D^2) * Vt))\n\n return(model)\n}\n\n# =============================================================================\n# OUTPUT GENERATION & POST-PROCESSING\n#\n# Functions for generating final results and summary statistics.\n# These process fitted models into interpretable outputs including\n# credible sets, variable names, and fitted values.\n#\n# Functions: get_scale_factors, get_intercept, get_fitted, get_cs,\n# get_variable_names, get_zscore\n# =============================================================================\n\n# Get scale factors\n#' @keywords internal\nget_scale_factors.rss_lambda <- function(data, params) {\n return(rep(1, data$p))\n}\n\n# Get intercept\n#' @keywords internal\nget_intercept.rss_lambda <- function(data, params, model, ...) {\n return(data$intercept_value)\n}\n\n# Get fitted values\n#' @keywords internal\nget_fitted.rss_lambda <- function(data, params, model, ...) {\n return(get_fitted.default(data, params, model, ...))\n}\n\n# Get credible sets\n#' @keywords internal\nget_cs.rss_lambda <- function(data, params, model, ...) {\n if (is.null(params$coverage) || is.null(params$min_abs_corr)) {\n return(NULL)\n }\n\n if (!is.null(data$X)) {\n return(susie_get_cs(model,\n X = data$X,\n coverage = params$coverage,\n min_abs_corr = params$min_abs_corr,\n n_purity = params$n_purity))\n }\n\n return(susie_get_cs(model,\n Xcorr = safe_cov2cor(data$R),\n check_symmetric = FALSE,\n coverage = params$coverage,\n min_abs_corr = params$min_abs_corr,\n n_purity = params$n_purity))\n}\n\n# Get variable names\n#' @keywords internal\nget_variable_names.rss_lambda <- function(data, model, ...) {\n return(assign_names(data, model, names(data$z)))\n}\n\n# Get univariate z-scores\n#' @keywords internal\nget_zscore.rss_lambda <- function(data, params, model, ...) {\n return(get_zscore.default(data, params, model))\n}\n\n# Clean up model object for RSS lambda data\n#' @keywords internal\ncleanup_model.rss_lambda <- function(data, params, model, ...) {\n # Remove common fields\n model <- cleanup_model.default(data, params, model, ...)\n\n # Remove RSS-lambda-specific temporary fields\n rss_fields <- c(\"SinvRj\", \"RjSinvRj\", \"Rz\", \"Z\", \"zbar\", \"diag_postb2\",\n \"eigen_R\", \"Vtz\", \"z_null_norm2\",\n \"residuals\", \"fitted_without_l\", \"residual_variance\")\n\n for (field in rss_fields) {\n if (field %in% names(model)) {\n model[[field]] <- NULL\n }\n }\n\n return(model)\n}\n" }, { "path": "R/rss_mismatch.R", "content": "# RSS R-reference mismatch handling.\n#\n# Single home for code that targets the discrepancy between the\n# supplied R reference and the target population. Active on the SS\n# / ss_mixture dispatches; the rss_lambda dispatch (lambda > 0) does\n# NOT use any of this (entry-level errors block lambda > 0 with\n# R_finite or R_mismatch != \"none\").\n#\n# * 1-D MAP optimizer for the variance component lambda_bias\n# (estimate_lambda_bias)\n# * per-variable inflation factor used inside the SER step\n# (compute_shat2_inflation)\n# * model-state storage helper for per-slot inflation diagnostics\n# (apply_inflation_state)\n# * per-sweep region-level fit (fit_R_mismatch)\n# * residual R-mismatch QC diagnostic Q_art (R_mismatch = \"map_qc\")\n#\n# Storage convention on the model:\n# model$lambda_bias scalar set once per sweep by fit_R_mismatch\n# model$B_corrected 1 / (1/B + lambda_bias)\n# model$shat2_inflation per-variable inflation vector of length p,\n# consumed by the SER step.\n\n# =============================================================================\n# FINITE-REFERENCE SETUP AND DIAGNOSTICS\n# =============================================================================\n\n# Resolve R_finite into an explicit reference sample size B.\n# R_finite = TRUE is only meaningful when the reference factor X is available;\n# for precomputed R, the caller must provide B explicitly.\n#' @keywords internal\nresolve_R_finite <- function(R_finite, X = NULL, is_multi_panel = FALSE) {\n if (is.null(R_finite))\n return(NULL)\n if (isTRUE(R_finite)) {\n if (is.null(X))\n stop(\"R_finite = TRUE requires X input. \",\n \"When using a precomputed R matrix, provide a positive number \",\n \"specifying the reference sample size B instead.\")\n if (is_multi_panel)\n return(min(vapply(X, nrow, integer(1))))\n return(nrow(X))\n }\n if (!is.numeric(R_finite) || any(!is.finite(R_finite)) ||\n any(R_finite <= 0)) {\n stop(\"R_finite must be NULL, TRUE, or positive numeric value(s).\")\n }\n if (is_multi_panel) {\n K <- if (is.null(X)) length(R_finite) else length(X)\n if (length(R_finite) == 1)\n return(rep(as.numeric(R_finite), K))\n if (length(R_finite) == K)\n return(as.numeric(R_finite))\n stop(\"For multi-panel input, R_finite must be TRUE, a single positive \",\n \"number, or one positive number per panel.\")\n }\n if (length(R_finite) == 1)\n return(as.numeric(R_finite))\n stop(\"R_finite must be NULL, TRUE, or a single positive number.\")\n}\n\n# Compute finite-reference R diagnostics (debiased Frobenius norm,\n# effective rank, r/B ratio, per-variant diagonal deviation from 1).\n# Used by both summary_stats_constructor and rss_lambda_constructor.\n#\n# @param X Factor matrix (B x p), or NULL.\n# @param R Precomputed R matrix (p x p), or NULL.\n# @param B Reference panel sample size.\n# @param p Number of variants.\n# @param x_is_standardized If TRUE, X has been standardized so X'X = R_hat\n# directly (no normalization). If FALSE, R_hat = X'X/B so the Frobenius\n# norm needs a /B^2 correction.\n# @return List with B, p, R_frob_sq_debiased, effective_rank, r_over_B,\n# Rhat_diag_deviation.\n#' @keywords internal\ncompute_R_finite_diagnostics <- function(X = NULL, R = NULL, B, p,\n x_is_standardized = FALSE) {\n if (!is.null(X)) {\n A <- tcrossprod(X) # B x B Gram matrix\n R_frob_sq <- sum(A * A) # ||XX'||_F^2 = ||X'X||_F^2\n if (!x_is_standardized)\n R_frob_sq <- R_frob_sq / nrow(X)^2\n Rhat_diag <- colSums(X^2)\n if (!x_is_standardized)\n Rhat_diag <- Rhat_diag / nrow(X)\n } else if (!is.null(R)) {\n R_frob_sq <- sum(R * R)\n Rhat_diag <- diag(R)\n } else {\n R_frob_sq <- p # identity fallback\n Rhat_diag <- rep(1, p)\n }\n\n # Debiased Frobenius norm (Ledoit-Wolf unbiased estimator)\n R_frob_sq_db <- (B * R_frob_sq - p^2) / (B + 1)\n eff_rank <- p^2 / max(R_frob_sq_db, 1)\n\n list(\n B = B,\n p = p,\n R_frob_sq_debiased = R_frob_sq_db,\n effective_rank = eff_rank,\n r_over_B = eff_rank / B,\n Rhat_diag_deviation = abs(Rhat_diag - 1)\n )\n}\n\n# =============================================================================\n# 1-D MAP OPTIMIZER FOR lambda_bias\n# =============================================================================\n\n# Estimate extra R-bias variance beyond finite-reference uncertainty.\n# Likelihood on the z-score residual scale,\n# tau_j^2 = sigma2 + (1/R_finite_B + lambda_bias) * s_j,\n# with a half-Cauchy(prior_scale) prior on u = sqrt(lambda_bias).\n# The Fisher-information boundary SE,\n# SE_0 = sqrt(2) * sigma2 / sqrt(sum(s^2)),\n# defines a data-driven floor: estimates below 0.1 * SE_0 are zeroed.\n# This both suppresses Brent boundary noise and replaces ad-hoc display\n# thresholds with one rule; \"none\" short-circuits before optimization.\n#' @keywords internal\nestimate_lambda_bias <- function(r, s, sigma2, R_finite_B, method) {\n if (is.null(method) || method == \"none\")\n return(0)\n keep <- is.finite(r) & is.finite(s) & s > .Machine$double.eps\n if (!any(keep) || !is.finite(sigma2) || sigma2 <= .Machine$double.eps)\n return(0)\n\n cache <- list(r2 = r[keep]^2, s = s[keep])\n cache$base <- sigma2 + cache$s / R_finite_B\n pos <- (cache$r2 - cache$base) / cache$s\n pos <- pos[is.finite(pos) & pos > 0]\n prior_scale <- sqrt(max(1 / R_finite_B, 1 / 10000))\n upper_lambda <- max(c(1, 100 / R_finite_B, 100 * prior_scale^2,\n 10 * pos), na.rm = TRUE)\n upper_u <- sqrt(upper_lambda)\n\n nll <- function(u) {\n lambda_bias <- u^2\n tau <- cache$base + lambda_bias * cache$s\n 0.5 * sum(log(tau) + cache$r2 / tau) + log1p((u / prior_scale)^2)\n }\n lambda_hat <- optimize(nll, interval = c(0, upper_u))$minimum^2\n\n ss2 <- sum(cache$s^2)\n if (ss2 <= 0) return(0)\n se_boundary <- sqrt(2) * sigma2 / sqrt(ss2)\n if (lambda_hat < 0.1 * se_boundary) 0 else lambda_hat\n}\n\n# =============================================================================\n# PER-VARIABLE INFLATION\n# =============================================================================\n\n# SS-path per-variable inflation factor tau_j^2 / sigma2 with\n# tau_j^2 = sigma2 + (1/R_finite_B + lambda_bias) * (eta_j^2 + v_g),\n# eta_j^2 = XtXr_without_l[j]^2 / (n-1) (z-score scale)\n# v_g = sum(b_minus_l * XtXr_without_l).\n# Reads the region-level scalar lambda_bias from model (set once per\n# sweep by fit_R_mismatch). Per-slot lambda_bias re-fitting was removed:\n# the previous design re-estimated lambda_bias inside every SER step\n# from the leave-one-effect residual, which intentionally contains the\n# lth sparse signal and so confounded signal with R-bias. The fix is\n# the per-sweep fit_R_mismatch hook in ibss_fit; this function only\n# applies the scalar to the slot-specific xi_l.\n# Returns NULL when no inflation applies, otherwise a list with the\n# inflation vector and lambda_bias / B_corrected = NULL so that\n# apply_inflation_state does not write per-slot diagnostics on the SS\n# path (those are scalars on the model, set by fit_R_mismatch).\n#' @keywords internal\ncompute_shat2_inflation <- function(data, model, XtXr_without_l, b_minus_l, r) {\n R_finite_B <- if (!is.null(model$R_finite_B)) model$R_finite_B else data$R_finite_B\n if (is.null(R_finite_B) ||\n model$sigma2 <= .Machine$double.eps) {\n return(NULL)\n }\n v_g <- max(sum(b_minus_l * XtXr_without_l), 0)\n eta2 <- XtXr_without_l^2 / (data$n - 1)\n s <- eta2 + v_g\n lambda_bias <- if (is.null(model$lambda_bias)) 0 else model$lambda_bias\n infl <- 1 + (1 / R_finite_B + lambda_bias) * s / model$sigma2\n list(infl = infl, lambda_bias = NULL, B_corrected = NULL)\n}\n\n# =============================================================================\n# MODEL-STATE STORAGE FOR PER-SLOT INFLATION DIAGNOSTICS\n# =============================================================================\n\n# Unpack the inflation list from compute_shat2_inflation into the model.\n# Sets model$shat2_inflation to the per-variant inflation vector. The\n# per-slot writes to model$lambda_bias[l] / model$B_corrected[l] gated\n# below are dormant in the current code: SS / ss_mixture callers always\n# pass infl_state$lambda_bias = NULL (the scalar lambda_bias is set\n# once per sweep by fit_R_mismatch), and the rss_lambda path no longer\n# calls this function. The per-slot machinery is retained as inert\n# back-compat shim and will be removed when the next constructor pass\n# converges on a single storage shape.\n#' @keywords internal\napply_inflation_state <- function(model, infl_state, l) {\n if (is.null(infl_state)) {\n model$shat2_inflation <- NULL\n return(model)\n }\n model$shat2_inflation <- infl_state$infl\n L <- nrow(model$alpha)\n if (!is.null(infl_state$lambda_bias)) {\n if (is.null(model$lambda_bias) || length(model$lambda_bias) != L)\n model$lambda_bias <- rep(0, L)\n model$lambda_bias[l] <- infl_state$lambda_bias\n }\n if (!is.null(infl_state$B_corrected)) {\n if (is.null(model$B_corrected) || length(model$B_corrected) != L)\n model$B_corrected <- rep(NA_real_, L)\n model$B_corrected[l] <- infl_state$B_corrected\n }\n model\n}\n\n# =============================================================================\n# PER-SWEEP REGION-LEVEL fit_R_mismatch\n# =============================================================================\n\n#' Fit the region-level lambda_bias from the post-sweep fitted residual.\n#'\n#' Math (see archive/ld_mismatch_generativemodel.tex):\n#' beta_bar = colSums(slot_weight * alpha * mu) (full posterior mean, betahat scale)\n#' XtXr_full = X'X * beta_bar = (n-1) * R * beta_bar\n#' r_fit = (data$Xty - XtXr_full) / sqrt(n-1) (z-scale fitted residual)\n#' eta_fit_j^2 = XtXr_full[j]^2 / (n-1) (z-scale per-variant signal)\n#' v_g_fit = sum(beta_bar * XtXr_full) (= beta_bar_z' R beta_bar_z)\n#' xi_fit_j = eta_fit_j^2 + v_g_fit\n#' MAP for lambda_bias on the working likelihood\n#' r_fit_j ~ N(0, sigma2 + (1/B + lambda) * xi_fit_j)\n#' with half-Cauchy(scale = sqrt(max(1/B, 1e-4))) prior on sqrt(lambda).\n#' Fisher SE zero-mask applied (see estimate_lambda_bias).\n#'\n#' Replaces the per-slot re-fit that used to live inside\n#' compute_shat2_inflation, which estimated lambda_bias from the\n#' intra-sweep r_full_z that drifts as the slot loop progresses.\n#'\n#' For mode = \"map_qc\" the same lambda_bias fit is followed by the\n#' Q_art residual artifact diagnostic; see compute_Q_art. The\n#' The artifact diagnostic emits an R warning when flagged; it does\n#' not change lambda_bias or the SER likelihood.\n#'\n#' @keywords internal\n#' @noRd\nfit_R_mismatch <- function(data, params, model) {\n R_mismatch <- if (!is.null(params$R_mismatch)) params$R_mismatch else \"none\"\n if (R_mismatch == \"none\") return(model)\n R_finite_B <- if (!is.null(model$R_finite_B)) model$R_finite_B else data$R_finite_B\n if (is.null(R_finite_B) || !is.finite(model$sigma2) ||\n model$sigma2 <= .Machine$double.eps)\n return(model)\n if (!inherits(data, c(\"ss\", \"ss_mixture\"))) return(model)\n\n sw <- if (!is.null(model$slot_weights)) model$slot_weights else\n rep(1, nrow(model$alpha))\n b_full <- colSums(sw * model$alpha * model$mu)\n XtXr_full <- if (!is.null(model$XtXr))\n model$XtXr\n else compute_Rv(data, b_full)\n nm1 <- if (!is.null(data$nm1)) data$nm1 else (data$n - 1)\n if (!is.finite(nm1) || nm1 <= 0) return(model)\n\n r_fit_z <- (data$Xty - XtXr_full) / sqrt(nm1)\n v_g_full <- max(sum(b_full * XtXr_full), 0)\n s_full <- XtXr_full^2 / nm1 + v_g_full\n\n model$lambda_bias <- estimate_lambda_bias(r_fit_z, s_full, model$sigma2,\n R_finite_B, R_mismatch)\n model$B_corrected <- 1 / (1 / R_finite_B + model$lambda_bias)\n\n if (R_mismatch == \"map_qc\") {\n eigen_R <- get_R_mismatch_eigen(data, model)\n if (is.null(eigen_R))\n stop(\"R_mismatch = 'map_qc' requires data$eigen_R; \",\n \"summary_stats_constructor should have cached it.\")\n eig_delta_rel <- if (!is.null(params$eig_delta_rel))\n params$eig_delta_rel else 1e-3\n eig_delta_abs <- if (!is.null(params$eig_delta_abs))\n params$eig_delta_abs else 0\n art <- compute_Q_art(eigen_R, r_fit_z, eig_delta_rel, eig_delta_abs)\n threshold <- if (!is.null(params$artifact_threshold))\n params$artifact_threshold else 0.1\n flagged <- isTRUE(art$evaluable) && isTRUE(art$Q_art > threshold)\n\n model$Q_art <- art$Q_art\n model$artifact_evaluable <- art$evaluable\n model$artifact_flag <- flagged\n model$low_eigen_count <- art$low_eigen_count\n model$low_eigen_fraction <- art$low_eigen_count /\n length(eigen_R$values)\n model$eig_delta <- art$eig_delta\n\n if (flagged) {\n msg <- paste0(\"Residual R-bias artifact detected (Q_art = \",\n sprintf(\"%.3g\", art$Q_art),\n \" > threshold \", sprintf(\"%.3g\", threshold),\n \"). Fine-mapping results may be unreliable with \",\n \"this R reference. Consider allele/QC review, \",\n \"multi-reference analysis, or conservative fallback.\")\n model$mode_label <- \"warning\"\n warning_message(msg)\n warning(msg, call. = FALSE)\n } else {\n model$mode_label <- \"normal\"\n }\n }\n\n model\n}\n\n# Eigen accessor for map_qc. The ordinary SS path stores data$eigen_R.\n# The ss_mixture path can change R through omega, so recover the current\n# mixture spectrum from panel_R when omega is available; otherwise fall\n# back to the initialized X_meta crossproduct.\n#' @keywords internal\nget_R_mismatch_eigen <- function(data, model) {\n if (!is.null(model$eigen_R))\n return(model$eigen_R)\n if (!is.null(data$eigen_R) && !inherits(data, \"ss_mixture\"))\n return(data$eigen_R)\n if (inherits(data, \"ss_mixture\")) {\n if (!is.null(model$omega) && !is.null(data$omega_cache)) {\n eig <- eigen_from_reduced(data$omega_cache, model$omega,\n data$K, data$p)\n eig$values <- pmax(eig$values, 0)\n return(eig)\n }\n if (!is.null(model$omega) && !is.null(data$panel_R)) {\n R_mix <- Reduce(\"+\", Map(function(w, R) w * R, model$omega, data$panel_R))\n R_mix <- 0.5 * (R_mix + t(R_mix))\n eig <- eigen(R_mix, symmetric = TRUE)\n eig$values <- pmax(eig$values, 0)\n return(eig)\n }\n if (!is.null(data$X)) {\n R_init <- crossprod(data$X) / data$nm1\n R_init <- 0.5 * (R_init + t(R_init))\n eig <- eigen(R_init, symmetric = TRUE)\n eig$values <- pmax(eig$values, 0)\n return(eig)\n }\n }\n data$eigen_R\n}\n\n# =============================================================================\n# Q_art residual R-bias artifact diagnostic\n# =============================================================================\n\n# Fraction of fitted-residual energy in low-eigenvalue directions of R.\n# delta = max(eig_delta_abs, eig_delta_rel * max(d))\n# A_delta = {k : d_k <= delta}\n# Q_art = sum_{k in A_delta} (v_k' r_fit)^2 / sum(r_fit^2)\n# When the fitted residual is well-explained by R, energy in\n# low-eigenvalue directions is near the noise floor. A large Q_art\n# flags residual structure that the supplied reference says should be\n# weak or absent; allele/strand flips should still be checked by\n# kriging-style diagnostics.\n#\n# Returns a list with Q_art (in [0, 1]), evaluable (FALSE when no\n# low-eigenvalues exist or r_fit has negligible energy),\n# low_eigen_count, eig_delta. Q_art is a heuristic proportion, not a\n# calibrated test statistic; see archive/ld_mismatch_generativemodel.tex\n# Sec. \"Detecting residual R-bias artifacts\".\n#' @keywords internal\ncompute_Q_art <- function(eigen_R, r_fit, eig_delta_rel = 1e-3,\n eig_delta_abs = 0,\n residual_energy_floor = 1e-12) {\n d <- eigen_R$values\n V <- eigen_R$vectors\n delta <- max(eig_delta_abs, eig_delta_rel * max(d))\n A_delta <- which(d <= delta)\n rss <- sum(r_fit^2)\n if (length(A_delta) == 0L || rss <= residual_energy_floor) {\n return(list(Q_art = 0, evaluable = FALSE,\n low_eigen_count = length(A_delta), eig_delta = delta))\n }\n proj <- as.numeric(crossprod(V[, A_delta, drop = FALSE], r_fit))\n Q <- sum(proj^2) / rss\n list(Q_art = Q, evaluable = TRUE,\n low_eigen_count = length(A_delta), eig_delta = delta)\n}\n" }, { "path": "R/single_effect_regression.R", "content": "# =============================================================================\n# SINGLE EFFECT REGRESSION\n#\n# Performs single effect regression for the lth effect in the SuSiE model.\n# Computes posterior moments, log Bayes factors, and optimizes prior variance.\n# =============================================================================\n#'\n#' @param data Data object (individual, ss, or rss_lambda)\n#' @param params Validated params object\n#' @param model Current SuSiE model object\n#' @param l Effect index being updated\n#'\n#' @return Updated model with alpha, mu, mu2, lbf, lbf_variable, V, and KL stored for the lth effect\n#'\n#' @keywords internal\n#' @noRd\nsingle_effect_regression <- function(data, params, model, l) {\n\n # Fixed mixture prior path: evaluate BFs on a pre-specified variance grid\n # with given mixture weights, bypassing scalar V optimization entirely.\n # Activated by estimate_prior_method = \"fixed_mixture\" with non-NULL\n # prior_variance_grid and mixture_weights in params.\n if (params$estimate_prior_method == \"fixed_mixture\") {\n ser_stats <- compute_ser_statistics(data, params, model, l)\n model <- loglik_mixture(data, params, model, ser_stats, l)\n model <- calculate_posterior_moments_mixture(data, params, model, l)\n model <- compute_kl(data, params, model, l)\n # Store effective V as posterior-weighted grid mean (for diagnostics)\n V_eff <- sum(params$mixture_weights * params$prior_variance_grid)\n model <- set_prior_variance_l(model, l, V_eff)\n return(model)\n }\n\n # Two S3 hook slots: pre/post loglik. Defaults dispatch on\n # `params$estimate_prior_method`; downstream classes override.\n\n V <- get_prior_variance_l(model, l)\n ser_stats <- compute_ser_statistics(data, params, model, l)\n\n out <- pre_loglik_prior_hook(data, params, model, ser_stats,\n l = l, V_init = V)\n V <- out$V\n model <- out$model\n\n model <- loglik(data, params, model, V, ser_stats, l)\n model <- calculate_posterior_moments(data, params, model, V, l)\n model <- compute_kl(data, params, model, l)\n\n out <- post_loglik_prior_hook(data, params, model, ser_stats,\n l = l, V_init = V)\n V <- out$V\n model <- out$model\n\n model <- set_prior_variance_l(model, l, V)\n model\n }\n\n#' Pre-loglik prior-update hook\n#'\n#' S3 generic, called between SER stats and `loglik`. Default\n#' routes to `optimize_prior_variance` for `optim` / `uniroot` /\n#' `simple`. Returns `list(V, model)`.\n#'\n#' @export\n#' @keywords internal\npre_loglik_prior_hook <- function(data, params, model, ser_stats,\n l, V_init) {\n UseMethod(\"pre_loglik_prior_hook\")\n}\n\n#' @export\n#' @keywords internal\npre_loglik_prior_hook.default <- function(data, params, model, ser_stats,\n l, V_init) {\n if (params$estimate_prior_method %in% c(\"optim\", \"uniroot\", \"simple\")) {\n return(optimize_prior_variance(data, params, model, ser_stats,\n l = l, V_init = V_init))\n }\n list(V = V_init, model = model)\n}\n\n#' Post-loglik prior-update hook\n#'\n#' S3 generic, called after `loglik` / posterior moments / KL.\n#' Default routes to `optimize_prior_variance` for `EM`. Returns\n#' `list(V, model)`.\n#'\n#' @export\n#' @keywords internal\npost_loglik_prior_hook <- function(data, params, model, ser_stats,\n l, V_init) {\n UseMethod(\"post_loglik_prior_hook\")\n}\n\n#' @export\n#' @keywords internal\npost_loglik_prior_hook.default <- function(data, params, model, ser_stats,\n l, V_init) {\n if (identical(params$estimate_prior_method, \"EM\")) {\n return(optimize_prior_variance(\n data, params, model, ser_stats,\n l = l,\n alpha = get_alpha_l(model, l),\n moments = get_posterior_moments_l(model, l),\n V_init = V_init))\n }\n list(V = V_init, model = model)\n}\n\n# =============================================================================\n# PRIOR VARIANCE OPTIMIZATION\n#\n# Optimizes prior variance for single effects using different methods.\n# Handles optim, EM, simple methods and null threshold checking.\n# =============================================================================\n\n#' Per-effect prior variance update (S3 generic)\n#'\n#' Dispatched on the data class so downstream packages with non-scalar\n#' prior structures (e.g., mfsusieR's adaptive mixture-of-normals\n#' prior, future cross-modality priors) can run a per-effect prior\n#' update step here while reusing the surrounding SER scaffolding.\n#'\n#' The default path implements the standard susieR scalar-V\n#' optimization (`optim` Brent / `uniroot` / `EM` / `simple` /\n#' `none`) plus the post-optimization null-threshold check.\n#'\n#' @param data Data object (e.g., `individual`, `ss`, `rss_lambda`,\n#' or a downstream class such as `mv_individual`, `mf_individual`).\n#' @param params Validated params object.\n#' @param model Current SuSiE model object.\n#' @param ser_stats SER statistics and optimization parameters from\n#' `compute_ser_statistics`.\n#' @param l Index of the effect being updated. Used by downstream\n#' methods that need per-effect state (e.g., the EM mixture-weight\n#' path); the default method uses it only for diagnostic purposes.\n#' @param alpha Per-SNP posterior weights for effect `l`, supplied by\n#' the EM path (`get_alpha_l(model, l)`); `NULL` on the pre-loglik\n#' call.\n#' @param moments Posterior moments for effect `l`, supplied by the\n#' EM path (`get_posterior_moments_l(model, l)`); `NULL` on the\n#' pre-loglik call.\n#' @param V_init Initial value for the prior variance scalar.\n#'\n#' @return A named list with two elements:\n#' \\describe{\n#' \\item{`V`}{numeric scalar, the optimized prior variance for\n#' effect `l`.}\n#' \\item{`model`}{the (possibly mutated) model object. The default\n#' method leaves `model` unchanged; downstream methods may write\n#' prior-state updates here (e.g., mixture-weight vectors).}\n#' }\n#'\n#' @keywords internal\n#' @noRd\noptimize_prior_variance <- function(data, params, model, ser_stats,\n l = NULL,\n alpha = NULL,\n moments = NULL,\n V_init = NULL) {\n UseMethod(\"optimize_prior_variance\")\n}\n\n#' Default scalar-V prior-variance optimization\n#'\n#' Backbone implementation of `optimize_prior_variance`. Handles the\n#' five `params$estimate_prior_method` cases (`optim`, `uniroot`,\n#' `EM`, `simple`, `none`) on a scalar prior variance and runs the\n#' post-optimization null-threshold check.\n#'\n#' @inheritParams optimize_prior_variance\n#' @return A named list `list(V = ..., model = model)` (see\n#' `optimize_prior_variance` for the full contract). `model` is\n#' returned unchanged by this default method.\n#' @keywords internal\n#' @noRd\noptimize_prior_variance.default <- function(data, params, model, ser_stats,\n l = NULL,\n alpha = NULL,\n moments = NULL,\n V_init = NULL) {\n V <- V_init\n if (params$estimate_prior_method != \"simple\") {\n if (params$estimate_prior_method == \"optim\") {\n V_param_opt <- optim(\n par = ser_stats$optim_init,\n fn = function(V_param) neg_loglik(data, params, model, V_param, ser_stats),\n method = \"Brent\",\n lower = ser_stats$optim_bounds[1],\n upper = ser_stats$optim_bounds[2]\n )$par\n\n # Convert optimized parameter to V based on scale of optimization\n V_new <- if (ser_stats$optim_scale == \"linear\") {\n V_param_opt\n } else {\n exp(V_param_opt)\n }\n\n # Check if new estimate improves likelihood\n V_param_init <- if (ser_stats$optim_scale == \"linear\") V else log(V)\n if (neg_loglik(data, params, model, V_param_opt, ser_stats) >\n neg_loglik(data, params, model, V_param_init, ser_stats)) {\n V_new <- V\n }\n V <- V_new\n } else if (params$estimate_prior_method == \"uniroot\") {\n # Root-finding on the gradient of neg_loglik (on the optimization scale)\n neg_loglik_fn <- function(V_param) neg_loglik(data, params, model, V_param, ser_stats)\n neg_loglik_grad <- function(V_param) {\n h <- max(abs(V_param) * 1e-4, 1e-8)\n (neg_loglik_fn(V_param + h) - neg_loglik_fn(V_param - h)) / (2 * h)\n }\n\n V_root <- tryCatch(\n uniroot(neg_loglik_grad,\n interval = c(ser_stats$optim_bounds[1], ser_stats$optim_bounds[2]),\n extendInt = \"yes\",\n tol = .Machine$double.eps^0.25)$root,\n error = function(e) {\n # Fallback: if uniroot fails (no sign change), use initial value\n if (ser_stats$optim_scale == \"linear\") V else log(V)\n }\n )\n\n V_new <- if (ser_stats$optim_scale == \"linear\") V_root else exp(V_root)\n\n # Check if new estimate improves likelihood\n V_param_init <- if (ser_stats$optim_scale == \"linear\") V else log(V)\n if (neg_loglik(data, params, model, V_root, ser_stats) >\n neg_loglik(data, params, model, V_param_init, ser_stats)) {\n V_new <- V\n }\n V <- V_new\n } else if (params$estimate_prior_method == \"EM\") {\n V <- em_update_prior_variance(data, params, model, alpha, moments, V_init)\n } else {\n stop(\"Invalid option for estimate_prior_method: \", params$estimate_prior_method)\n }\n }\n\n # Set V exactly 0 if that beats the numerical value by\n # check_null_threshold in loglik. check_null_threshold = 0.1 is\n # exp(0.1) = 1.1 on likelihood scale; it means that for parsimony\n # reasons we set estimate of V to zero, if its numerical estimate is\n # only \"negligibly\" different from zero. We use a likelihood ratio\n # of exp(check_null_threshold) to define \"negligible\" in this\n # context. This is fairly modest condition compared to, say, a\n # formal LRT with p-value 0.05. But the idea is to be lenient to\n # non-zeros estimates unless they are indeed small enough to be\n # neglible. See more intuition at\n # https://stephens999.github.io/fiveMinuteStats/LR_and_BF.html\n #\n # For EM, skip this check: the null check would zero V without\n # recomputing the posterior, creating an inconsistent (q, V) pair\n # that can decrease the ELBO. Null effects are handled by\n # trim_null_effects() after convergence instead.\n # see https://github.com/stephenslab/mvsusieR/issues/26\n if (params$estimate_prior_method != \"EM\" &&\n params$estimate_prior_method != \"none\") {\n if (loglik(data, params, model, 0, ser_stats) +\n params$check_null_threshold >= loglik(data, params, model, V, ser_stats)) {\n V <- 0\n }\n }\n\n list(V = V, model = model)\n}\n\n# =============================================================================\n# SINGLE EFFECT UPDATE\n#\n# High-level function that updates one effect in the SuSiE model.\n# Coordinates residual computation, SER, KL divergence, and fitted value updates.\n# =============================================================================\n#'\n#' @param data Data object (individual, ss, or rss_lambda)\n#' @param params Validated params object\n#' @param model Current SuSiE model object\n#' @param l Effect index being updated\n#'\n#' @return Updated SuSiE model object with new parameters for effect l\n#'\n#' @keywords internal\n#' @noRd\nsingle_effect_update <- function(data, params, model, l) {\n\n # Compute Residuals\n model <- compute_residuals(data, params, model, l)\n\n # Run Single Effect Regression\n model <- single_effect_regression(data, params, model, l)\n\n # Update fitted values\n model <- update_fitted_values(data, params, model, l)\n\n return(model)\n}" }, { "path": "R/slot_prior.R", "content": "#' @title Slot Activity Prior for SuSiE\n#'\n#' @description Construct a prior specification for the slot activity\n#' model, which regularizes the number of active single effects in\n#' SuSiE. Two prior families are available: Beta-Binomial (default,\n#' recommended for single-locus) and Gamma-Poisson (recommended for\n#' genome-wide applications via susieAnn).\n#'\n#' @param C Expected number of causal variants for the Gamma-Poisson prior\n#' on the per-block causal rate. Must be positive. Not used by\n#' \\code{slot_prior_betabinom}.\n#' @param nu Overdispersion parameter for the Gamma-Poisson prior on the\n#' per-block causal rate. Not used by \\code{slot_prior_betabinom}.\n#' Larger values give stronger shrinkage toward C. Default 8 when\n#' not specified.\n#' @param a_beta Shape parameter for the Beta prior on inclusion\n#' probability rho. Default 1.\n#' @param b_beta Shape parameter for the Beta prior on inclusion\n#' probability rho. Default 2, giving a moderate sparsity preference\n#' with \\code{E[rho] = 1/3 ~ 0.33}. Setting \\code{a_beta = 1}\n#' and \\code{b_beta = 1} gives a uniform prior on [0,1], providing\n#' automatic multiplicity correction following Scott and Berger (2010).\n#' @param update_schedule How the Gamma shape parameter is updated\n#' during IBSS iterations (Gamma-Poisson only; ignored for\n#' Beta-Binomial which is inherently sequential).\n#' \\code{\"batch\"} updates once per full sweep (standard CAVI).\n#' \\code{\"sequential\"} updates after each slot (faster convergence\n#' per iteration, used by susieAnn).\n#' @param c_hat_init Optional numeric L-vector of initial slot activity\n#' probabilities for warm-starting. If NULL, initialized at the\n#' prior mean.\n#' @param skip_threshold_multiplier Multiplier for the adaptive skip\n#' threshold. Slots with c_hat below this fraction of the baseline\n#' (prior with zero signal) are skipped. Default 0 (no skipping).\n#' The threshold is recomputed after each sweep from the current\n#' model state, and is set to 0 on the first sweep so all slots\n#' are evaluated at least once.\n#'\n#' @return A list of class \\code{\"slot_prior\"} with the appropriate\n#' subclass.\n#'\n#' @details\n#' Two prior types are available:\n#' \\describe{\n#' \\item{\\code{slot_prior_betabinom}}{Uses a Beta-Binomial model\n#' for slot inclusion. The inclusion probability rho is given a\n#' Beta(a_beta, b_beta) prior and integrated out analytically,\n#' yielding an adaptive multiplicity correction that penalizes\n#' less when more slots are active. This is the recommended\n#' default for single-locus applications. See Scott and Berger\n#' (2010) for the theoretical justification.}\n#' \\item{\\code{slot_prior_poisson}}{Uses the Gamma-Poisson model\n#' with Poisson approximation for slot indicators. Recommended\n#' for genome-wide applications via susieAnn, where C and nu\n#' are estimated across loci.}\n#' }\n#'\n#' @references\n#' Scott, J. G. and Berger, J. O. (2010). Bayes and empirical-Bayes\n#' multiplicity adjustment in the variable-selection problem.\n#' \\emph{Annals of Statistics}, 38(5), 2587--2619.\n#'\n#' @examples\n#' # Default: Beta-Binomial with Beta(1, 2) prior on inclusion probability\n#' slot_prior_betabinom()\n#'\n#' # Gamma-Poisson for susieAnn\n#' slot_prior_poisson(C = 5, nu = 8)\n#'\n#' # Pass to susie\n#' # fit <- susie(X, y, slot_prior = slot_prior_betabinom())\n#'\n# Beta-Binomial: rho ~ Beta(a, b), c_l | rho ~ Bern(rho), rho collapsed.\n# Collapsed update: logit(c_l) = log(a + k_{-l}) - log(b + L-1 - k_{-l}) + lbf_l\n# Scott & Berger (2010), Ann. Statist. 38(5):2587-2619.\n#' @export\nslot_prior_betabinom <- function(a_beta = NULL, b_beta = NULL,\n c_hat_init = NULL,\n skip_threshold_multiplier = 0) {\n ab_was_default <- is.null(a_beta) && is.null(b_beta)\n if (is.null(a_beta)) a_beta <- 1\n # Beta(1, 2) gives approximately linear decline in the number of active\n # slots: P(K=1) > P(K=2) > P(K=3) > ..., favoring sparse architectures\n # while still allowing multiple effects. E[rho] = 1/3, expecting ~3 of 10.\n if (is.null(b_beta)) b_beta <- 2\n\n stopifnot(is.numeric(a_beta), length(a_beta) == 1, a_beta > 0)\n stopifnot(is.numeric(b_beta), length(b_beta) == 1, b_beta > 0)\n structure(\n list(\n a_beta = a_beta,\n b_beta = b_beta,\n ab_was_default = ab_was_default,\n update_schedule = \"sequential\", # inherently sequential (uses k_{-l})\n c_hat_init = c_hat_init,\n skip_threshold_multiplier = skip_threshold_multiplier\n ),\n class = c(\"slot_prior_betabinom\", \"slot_prior\")\n )\n}\n\n#' @rdname slot_prior_betabinom\n#' @export\nslot_prior_poisson <- function(C, nu = NULL, update_schedule = c(\"sequential\", \"batch\"),\n c_hat_init = NULL, skip_threshold_multiplier = 0) {\n update_schedule <- match.arg(update_schedule)\n stopifnot(is.numeric(C), length(C) == 1, C > 0)\n nu_was_null <- is.null(nu)\n if (nu_was_null) nu <- 8\n stopifnot(is.numeric(nu), length(nu) == 1, nu > 0)\n structure(\n list(\n C = C,\n nu = nu,\n nu_was_default = nu_was_null,\n update_schedule = update_schedule,\n c_hat_init = c_hat_init,\n skip_threshold_multiplier = skip_threshold_multiplier\n ),\n class = c(\"slot_prior_poisson\", \"slot_prior\")\n )\n}\n\n#' @export\nprint.slot_prior <- function(x, ...) {\n type <- if (inherits(x, \"slot_prior_betabinom\")) \"beta-binomial\"\n else \"poisson\"\n cat(sprintf(\"Slot activity prior (%s)\\n\", type))\n if (type == \"beta-binomial\") {\n cat(sprintf(\" a_beta: %g\\n\", x$a_beta))\n cat(sprintf(\" b_beta: %g\\n\", x$b_beta))\n } else {\n cat(sprintf(\" C (expected causal): %g\\n\", x$C))\n cat(sprintf(\" nu (overdispersion): %g\\n\", x$nu))\n }\n if (type != \"beta-binomial\")\n cat(sprintf(\" update schedule: %s\\n\", x$update_schedule))\n if (!is.null(x$c_hat_init))\n cat(sprintf(\" warm start: %d-vector\\n\", length(x$c_hat_init)))\n invisible(x)\n}\n\n#' Check if an object is a slot_prior\n#' @param x Object to test.\n#' @return Logical.\n#' @keywords internal\n#' @noRd\nis.slot_prior <- function(x) inherits(x, \"slot_prior\")\n\n#' ELBO contribution from the slot activity prior.\n#' Beta-Binomial: log Beta(a+k, b+L-k) - log Beta(a,b) + Bernoulli entropy.\n#' Gamma-Poisson: Gamma prior/entropy + Poisson slot prior + Bernoulli entropy.\n#' @keywords internal\n#' @noRd\nslot_prior_elbo <- function(model) {\n st <- model$c_hat_state\n chat <- model$slot_weights\n L <- length(chat)\n\n # Bernoulli entropy: -sum(c log c + (1-c) log(1-c))\n eps <- .Machine$double.eps\n ch <- pmax(pmin(chat, 1 - eps), eps)\n bern_entropy <- -sum(ch * log(ch) + (1 - ch) * log(1 - ch))\n\n if (st$prior_type == \"betabinom\") {\n k <- sum(chat)\n log_prior <- lbeta(st$a_beta + k, st$b_beta + L - k) -\n lbeta(st$a_beta, st$b_beta)\n return(log_prior + bern_entropy)\n }\n\n # Gamma-Poisson: E_q[log mu] = psi(a_g) - log(b_g), E_q[mu] = a_g/b_g\n a_g <- st$a_g; b_g <- st$b_g; nu <- st$nu; C <- st$C\n Eq_log_mu <- digamma(a_g) - log(b_g)\n Eq_mu <- a_g / b_g\n Lhat <- sum(chat)\n\n # E[log p(mu)] + H[q(mu)] + E[log p(c|mu)]\n gamma_prior <- (nu - 1) * Eq_log_mu - (nu / max(C, 1e-10)) * Eq_mu +\n nu * log(nu / max(C, 1e-10)) - lgamma(nu)\n gamma_entropy <- a_g - log(b_g) + lgamma(a_g) + (1 - a_g) * digamma(a_g)\n slot_prior <- Lhat * (Eq_log_mu - log(L))\n\n return(gamma_prior + gamma_entropy + slot_prior + bern_entropy)\n}\n" }, { "path": "R/sparse_multiplication.R", "content": "# @title Computes standardized.X %*% b using sparse multiplication trick\n# @param X an n by p unstandardized matrix with three attributes:\n# attr(X,\"scaled:center\"), attr(X,\"scaled:scale\") and attr(X,\"d\")\n# @param b a p vector\n# @return an n vector\n#\n#' @importFrom Matrix t\n#' @importFrom Matrix tcrossprod\ncompute_Xb <- function(X, b) {\n cm <- attr(X, \"scaled:center\")\n csd <- attr(X, \"scaled:scale\")\n\n # Scale Xb.\n if (!is.null(attr(X, \"matrix.type\"))) {\n\n # When X is a trend filtering matrix.\n scaled.Xb <- compute_tf_Xb(attr(X, \"order\"), b / csd)\n } else {\n\n # When X is an ordinary sparse/dense matrix.\n scaled.Xb <- tcrossprod(X, t(b / csd))\n }\n\n # Center Xb.\n Xb <- scaled.Xb - sum(cm * b / csd)\n return(as.numeric(Xb))\n}\n\n# @title Computes t(standardized.X) %*% y using sparse multiplication trick\n# @param X an n by p unstandardized matrix with three attributes:\n# attr(X,\"scaled:center\"), attr(X,\"scaled:scale\") and attr(X,\"d\")\n# @param y an n vector\n# @return a p vector\n#\n#' @importFrom Matrix t\n#' @importFrom Matrix crossprod\ncompute_Xty <- function(X, y) {\n cm <- attr(X, \"scaled:center\")\n csd <- attr(X, \"scaled:scale\")\n ytX <- crossprod(y, X)\n\n # Scale Xty.\n if (!is.null(attr(X, \"matrix.type\"))) {\n\n # When X is a trend filtering matrix.\n scaled.Xty <- compute_tf_Xty(attr(X, \"order\"), y) / csd\n } else {\n\n # When X is an ordinary sparse/dense matrix.\n scaled.Xty <- t(ytX / csd)\n }\n\n # Center Xty.\n centered.scaled.Xty <- scaled.Xty - cm / csd * sum(y)\n return(as.numeric(centered.scaled.Xty))\n}\n\n# @title Computes t(standardized.X) %*% standardized.X using attributes\n# @param X an n by p unstandardized matrix with three attributes:\n# attr(X,\"scaled:center\"), attr(X,\"scaled:scale\") and attr(X,\"d\")\n# @return a p by p matrix representing (scaled X)'(scaled X)\n#\n#' @importFrom Matrix crossprod\ncompute_XtX <- function(X) {\n cm <- attr(X, \"scaled:center\")\n csd <- attr(X, \"scaled:scale\")\n n <- nrow(X)\n colsums_X <- colSums(X)\n\n if (!is.null(attr(X, \"matrix.type\"))) {\n stop(\"compute_XtX not yet implemented for trend filtering matrices\")\n }\n\n # Compute raw X'X\n XtX_raw <- crossprod(X)\n\n # Scale columns and rows by 1/csd\n XtX_scaled <- sweep(sweep(XtX_raw, 1, csd, \"/\"), 2, csd, \"/\")\n\n # Adjust for centering\n XtX_centered_scaled <- XtX_scaled -\n n * outer(cm/csd, cm/csd) -\n outer(cm/csd, (colsums_X - n*cm)/csd) -\n outer((colsums_X - n*cm)/csd, cm/csd)\n\n return(XtX_centered_scaled)\n}\n\n# @title Computes M %* %t(standardized.X) using sparse multiplication trick\n# @param M a L by p matrix\n# @param X an n by p unstandardized matrix with three attributes:\n# attr(X,\"scaled:center\"), attr(X,\"scaled:scale\") and attr(X,\"d\")\n# @return a L by n matrix\n#\n#' @importFrom Matrix t\ncompute_MXt <- function(M, X) {\n cm <- attr(X, \"scaled:center\")\n csd <- attr(X, \"scaled:scale\")\n\n if (!is.null(attr(X, \"matrix.type\"))) {\n\n # When X is a trend filtering matrix.\n return(as.matrix(t(apply(M, 1, function(b) compute_Xb(X, b)))))\n } else {\n\n # When X is an ordinary sparse/dense matrix.\n return(as.matrix(t(X %*% (t(M) / csd)) - drop(M %*% (cm / csd))))\n }\n\n # This should be the same as\n #\n # t(apply(M, 1, function(b) compute_Xb(X, b))))\n #\n # as well as\n #\n # M %*% (t(X)/csd) - drop(tcrossprod(M,t(cm/csd)))\n #\n # but should be more memory-efficient.\n}\n" }, { "path": "R/ss_mixture_methods.R", "content": "# =============================================================================\n# SS MIXTURE PANEL METHODS\n#\n# Class c(\"ss_mixture\", \"ss\"). Inherits ALL SER/ELBO from ss path.\n# Overrides: 5 methods for omega-aware state management.\n#\n# Model: y ~ N(X(omega)*beta, sigma2*I), X'X = (n-1)*R(omega)\n# mu on betahat scale (same as ss). Omega evaluators use z-score scale.\n# =============================================================================\n\n# (n-1)*R(omega)*v using current X_meta (or fallback to data$X)\n#' @keywords internal\ncompute_XtXv_mixture <- function(data, model, v) {\n # Use panel_R for accurate R*v (cov2cor-based, not standardize_X)\n if (!is.null(model$omega) && !is.null(data$panel_R)) {\n Rv <- Reduce(\"+\", Map(function(w, R) w * (R %*% v), model$omega, data$panel_R))\n return(data$nm1 * as.vector(Rv))\n }\n # Fallback: data$X = sqrt(n-1)*X_meta_init\n as.vector(compute_Rv(data, v))\n}\n\n# 1. Initialize fitted values\n#' @keywords internal\ninitialize_fitted.ss_mixture <- function(data, mat_init) {\n list(XtXr = as.vector(compute_Rv(data, colSums(mat_init$alpha * mat_init$mu))))\n}\n\n# 2. Compute residuals using current R(omega)\n#' @keywords internal\ncompute_residuals.ss_mixture <- function(data, params, model, l, ...) {\n sw_l <- get_slot_weight(model, l)\n bl <- model$alpha[l, ] * model$mu[l, ]\n XtXr_without_l <- model$XtXr - sw_l * compute_XtXv_mixture(data, model, bl)\n\n model$residuals <- data$Xty - XtXr_without_l\n model$fitted_without_l <- XtXr_without_l\n model$residual_variance <- model$sigma2\n model$predictor_weights <- rep(data$nm1, data$p)\n\n if (!is.null(data$R_finite_B) && model$sigma2 > .Machine$double.eps) {\n # Region-level scalar lambda_bias is set by fit_R_mismatch once per\n # IBSS sweep; here we just apply it through the slot-specific\n # xi_l = eta_l^2 + v_g,l on z-scale.\n sw <- if (!is.null(model$slot_weights)) model$slot_weights else\n rep(1, nrow(model$alpha))\n b_minus_l <- colSums(sw * model$alpha * model$mu) - sw_l * bl\n nm1 <- data$nm1\n v_g <- max(sum(b_minus_l * XtXr_without_l), 0)\n xi_l <- XtXr_without_l^2 / nm1 + v_g\n lambda_bias <- if (is.null(model$lambda_bias)) 0 else model$lambda_bias\n R_finite_B <- if (!is.null(model$R_finite_B)) model$R_finite_B else data$R_finite_B\n model$shat2_inflation <- 1 + (1 / R_finite_B + lambda_bias) *\n xi_l / model$sigma2\n }\n return(model)\n}\n\n# 3. Update fitted values + precompute z-score quantities for omega\n#' @keywords internal\nupdate_fitted_values.ss_mixture <- function(data, params, model, l, ...) {\n sw_l <- get_slot_weight(model, l)\n bl <- model$alpha[l, ] * model$mu[l, ]\n model$XtXr <- model$fitted_without_l + sw_l * compute_XtXv_mixture(data, model, bl)\n\n # Convert betahat-scale mu to z-score scale for omega evaluators.\n # Weight by slot_weights (c_hat) when active.\n sqnm1 <- sqrt(data$nm1)\n sw <- if (!is.null(model$slot_weights)) model$slot_weights else rep(1, nrow(model$alpha))\n model$Z <- sw * model$alpha * model$mu * sqnm1\n model$zbar <- colSums(model$Z)\n model$diag_postb2 <- colSums(sw * model$alpha * model$mu2 * data$nm1)\n return(model)\n}\n\n# 4. Update variance: sigma2 (via default ss chain) + omega M-step\n#' @keywords internal\nupdate_model_variance.ss_mixture <- function(data, params, model) {\n # Sigma2: reuse default chain (est_residual_variance + bounds)\n if (isTRUE(params$estimate_residual_variance)) {\n model <- update_model_variance.default(data, params, model)\n }\n\n # Omega M-step\n if (!is.null(data$K) && data$K > 1 && !isTRUE(model$omega_converged)) {\n omega_cur <- if (!is.null(model$omega)) model$omega else rep(1 / data$K, data$K)\n\n # Omega-objective ridge: small floor used ONLY inside the Eloglik\n # evaluator to stabilize log|sigma2*A(omega)| near rank-deficient\n # vertices. Without it, small eigenvalues of A(omega) produce a huge\n # -0.5 * log|.| penalty at vertex omegas, pulling the optimizer toward\n # the interior (collapse to ~uniform weights). Matches the behavior\n # of the prev rss_lambda path with auto lambda = 1/(n-1). Does NOT\n # affect the ss-SER update, which still uses lambda = 0 (no FDR\n # inflation in the credible-set inference).\n omega_ridge <- 1 / data$nm1\n eval_omega <- NULL\n if (!is.null(data$omega_cache)) {\n cache <- data$omega_cache\n iter_cache <- precompute_omega_iteration(cache, model$zbar,\n model$diag_postb2, model$Z)\n eval_omega <- function(w) {\n eval_omega_eloglik_reduced(cache, w, iter_cache,\n model$sigma2, omega_ridge, data$K, data$p)\n }\n } else if (!is.null(data$panel_R)) {\n eval_omega <- function(w) {\n eval_omega_eloglik_R(data$panel_R, w, data$z, model$zbar,\n model$diag_postb2, model$Z, model$sigma2,\n omega_ridge, data$K, data$p)\n }\n }\n\n if (!is.null(eval_omega)) {\n opt <- optimize_omega(eval_omega, omega_cur, data$K)\n model$omega <- opt$omega\n if (!is.null(data$R_finite_B) && !is.null(data$B_list))\n model$R_finite_B <- 1 / sum(model$omega^2 / data$B_list)\n # Recompute XtXr with updated R(omega)\n b_bar <- colSums(model$alpha * model$mu)\n model$XtXr <- compute_XtXv_mixture(data, model, b_bar)\n if (opt$converged) model$omega_converged <- TRUE\n }\n }\n return(model)\n}\n\n# 5. ER2 using current R(omega), not stale data$X\n#' @keywords internal\nget_ER2.ss_mixture <- function(data, model) {\n B <- model$alpha * model$mu\n betabar <- colSums(B)\n postb2 <- model$alpha * model$mu2\n\n XtX_betabar <- compute_XtXv_mixture(data, model, betabar)\n XB2 <- 0\n for (l in seq_len(nrow(B))) {\n bl <- B[l, ]\n XB2 <- XB2 + sum(bl * compute_XtXv_mixture(data, model, bl))\n }\n\n data$yty - 2 * sum(betabar * data$Xty) + sum(betabar * XtX_betabar) -\n XB2 + data$nm1 * sum(postb2)\n}\n" }, { "path": "R/sufficient_stats_methods.R", "content": "# =============================================================================\n# DATA INITIALIZATION & CONFIGURATION\n#\n# Functions for data object setup, configuration, and preprocessing.\n# These prepare data objects for model fitting and handle data-specific\n# configurations like unmappable effects.\n#\n# Functions: configure_data, get_var_y\n# =============================================================================\n\n# Configure ss data for specified method\n#' @keywords internal\nconfigure_data.ss <- function(data, params) {\n if (params$unmappable_effects == \"inf\") {\n return(add_eigen_decomposition(data, params))\n } else {\n return(configure_data.default(data, params))\n }\n}\n\n# Get variance of y\n#' @keywords internal\nget_var_y.ss <- function(data, ...) {\n return(data$yty / (data$n - 1))\n}\n\n# =============================================================================\n# MODEL INITIALIZATION & SETUP\n#\n# Functions for initializing model objects and setting up initial states.\n# These create model matrices, initialize fitted values, and prepare\n# the SuSiE model for iterative fitting.\n#\n# Functions: initialize_susie_model, initialize_fitted, validate_prior, track_ibss_fit\n# =============================================================================\n\n# Initialize SuSiE model\n#' @keywords internal\ninitialize_susie_model.ss <- function(data, params, var_y, ...) {\n\n # Base model\n model <- initialize_matrices(data, params, var_y)\n\n # Append predictor weights and initialize non-sparse quantities\n if (params$unmappable_effects == \"inf\") {\n # Initialize omega quantities for unmappable effects\n omega_res <- compute_omega_quantities(data, tau2 = 0, sigma2 = var_y)\n model$omega_var <- omega_res$omega_var\n model$predictor_weights <- omega_res$diagXtOmegaX\n model$XtOmegay <- data$eigen_vectors %*% (data$VtXty / omega_res$omega_var)\n\n # Initialize unmappable variance component and coefficients\n model$tau2 <- 0\n model$theta <- rep(0, data$p)\n\n } else if (params$unmappable_effects == \"ash\") {\n pm <- if (!is.null(data$XtX)) data$XtX else data$X\n model$predictor_weights <- attr(pm, \"d\")\n model <- init_ash_fields(model, data$n, data$p, params$L, is_individual = FALSE)\n } else if (params$unmappable_effects == \"ash_filter_archived\") {\n pm <- if (!is.null(data$XtX)) data$XtX else data$X\n model$predictor_weights <- attr(pm, \"d\")\n model <- init_ash_fields_filter_archived(model, data$n, data$p, params$L, is_individual = FALSE)\n } else {\n pm <- if (!is.null(data$XtX)) data$XtX else data$X\n model$predictor_weights <- attr(pm, \"d\")\n\n # Initialize NIG parameters\n if (params$use_NIG) {\n model$rv <- rep(1, params$L)\n model$marginal_loglik <- rep(as.numeric(NA), params$L)\n }\n }\n\n return(model)\n}\n\n# Initialize fitted values\n#' @keywords internal\ninitialize_fitted.ss <- function(data, mat_init) {\n return(list(XtXr = compute_Rv(data, colSums(mat_init$alpha * mat_init$mu))))\n}\n\n# Validate Prior Variance\n#' @keywords internal\nvalidate_prior.ss <- function(data, params, model, ...) {\n if (isTRUE(params$check_prior)) {\n if (is.null(data$zm)) {\n bhat <- data$Xty / model$predictor_weights\n shat <- sqrt(model$sigma2 / model$predictor_weights)\n z <- bhat / shat\n data$zm <- max(abs(z[!is.nan(z)]))\n }\n if (any(model$V > 100 * (data$zm^2))) {\n stop(\n \"Estimated prior variance is unreasonably large.\\n\",\n \"This usually caused by mismatch between the summary statistics and the R matrix.\\n\",\n \"Please check the input.\"\n )\n }\n }\n return(validate_prior.default(data, params, model, ...))\n}\n\n# Track core parameters across iterations\n#' @keywords internal\ntrack_ibss_fit.ss <- function(data, params, model, tracking, iter, elbo, ...) {\n if (params$unmappable_effects %in% c(\"inf\", \"ash\", \"ash_filter_archived\")) {\n # Append non-sparse variance component to tracking\n tracking <- track_ibss_fit.default(data, params, model, tracking, iter, elbo, ...)\n if (isTRUE(params$track_fit)) {\n tracking[[iter]]$tau2 <- model$tau2\n }\n return(tracking)\n } else {\n # Use default for standard SS case\n return(track_ibss_fit.default(data, params, model, tracking, iter, elbo, ...))\n }\n}\n\n# =============================================================================\n# SINGLE EFFECT REGRESSION & ELBO\n#\n# Core functions for single effect regression computation and ELBO calculation.\n# These handle the mathematical core of SuSiE including residual computation, SER\n# statistics, posterior moments, and log-likelihood calculations for the ELBO.\n#\n# Functions: compute_residuals, compute_ser_statistics, SER_posterior_e_loglik,\n# calculate_posterior_moments, compute_kl, get_ER2, Eloglik, loglik, neg_loglik\n# =============================================================================\n\n# Compute residuals for single effect regression\n#' @keywords internal\ncompute_residuals.ss <- function(data, params, model, l, ...) {\n # Weighted sum of effects excluding l (slot_weights scale each effect's contribution)\n sw_l <- get_slot_weight(model, l)\n sw <- if (!is.null(model$slot_weights)) model$slot_weights else rep(1, nrow(model$alpha))\n b_minus_l <- colSums(sw * model$alpha * model$mu) - sw_l * model$alpha[l, ] * model$mu[l, ]\n\n if (params$unmappable_effects == \"inf\") {\n # SuSiE-inf: Omega-weighted residuals\n omega_res <- compute_omega_quantities(data, model$tau2, model$sigma2)\n XtOmegay <- data$eigen_vectors %*% (data$VtXty / omega_res$omega_var)\n XtOmegaXb <- data$eigen_vectors %*% ((t(data$eigen_vectors) %*% b_minus_l) * data$eigen_values / omega_res$omega_var)\n\n model$residuals <- XtOmegay - XtOmegaXb\n model$predictor_weights <- omega_res$diagXtOmegaX\n model$residual_variance <- 1 # Already incorporated in Omega\n\n # R inflation uses standard (non-Omega) quantities\n XtXr_without_l <- compute_Rv(data, b_minus_l)\n r <- data$Xty - XtXr_without_l\n infl_state <- compute_shat2_inflation(data, model, XtXr_without_l,\n b_minus_l, r)\n model <- apply_inflation_state(model, infl_state, l)\n return(model)\n }\n\n # Below are SuSiE, SuSiE-ASH and SuSiE-SS\n\n # Remove lth effect from fitted values (scaled by slot weight)\n XtXr_without_l <- model$XtXr - sw_l * compute_Rv(data, model$alpha[l, ] * model$mu[l, ])\n\n # Compute residuals (ash subtracts unmappable effect X'X*theta).\n is_ash <- params$unmappable_effects %in% c(\"ash\", \"ash_filter_archived\")\n if (is_ash) {\n model$residuals <- data$Xty - model$XtX_theta - XtXr_without_l\n } else {\n model$residuals <- data$Xty - XtXr_without_l\n }\n\n model$fitted_without_l <- XtXr_without_l\n model$residual_variance <- model$sigma2\n\n # NIG prior: compute residual sum of squares\n if (params$use_NIG) {\n model$yy_residual <- as.numeric(\n data$yty - 2 * sum(b_minus_l * data$Xty) + sum(b_minus_l * XtXr_without_l))\n model$yy_residual <- max(model$yy_residual, .Machine$double.eps)\n }\n\n # ASH path: residual subtracts theta (line 167), so the variance scale\n # s = eta^2 + v_g must also be built from b_minus_l + theta or the\n # data and variance model disagree on what has been removed.\n if (is_ash && !is.null(model$theta)) {\n XtX_theta <- if (!is.null(model$XtX_theta))\n model$XtX_theta\n else compute_Rv(data, model$theta)\n b_for_infl <- b_minus_l + model$theta\n XtXr_for_infl <- XtXr_without_l + XtX_theta\n } else {\n b_for_infl <- b_minus_l\n XtXr_for_infl <- XtXr_without_l\n }\n infl_state <- compute_shat2_inflation(data, model, XtXr_for_infl,\n b_for_infl, model$residuals)\n model <- apply_inflation_state(model, infl_state, l)\n\n return(model)\n}\n\n# compute_shat2_inflation moved to R/rss_mismatch.R.\n\n# Compute SER statistics\n#' @keywords internal\ncompute_ser_statistics.ss <- function(data, params, model, l, ...) {\n betahat <- (1 / model$predictor_weights) * model$residuals\n shat2 <- model$residual_variance / model$predictor_weights\n\n # Inflate shat2 for finite-reference R variance tracking (tau_j^2 / sigma^2)\n if (!is.null(model$shat2_inflation))\n shat2 <- shat2 * model$shat2_inflation\n\n # Optimization parameters\n if (params$unmappable_effects == \"inf\") {\n # SuSiE-inf: optimize on linear scale\n optim_init <- model$V[l]\n optim_bounds <- c(0, 1)\n optim_scale <- \"linear\"\n } else {\n # Standard SuSiE and SuSiE-ash: optimize on log scale\n optim_init <- log(max(c(betahat^2 - shat2, 1), na.rm = TRUE))\n optim_bounds <- c(-30, 15)\n optim_scale <- \"log\"\n }\n\n return(list(\n betahat = betahat,\n shat2 = shat2,\n optim_init = optim_init,\n optim_bounds = optim_bounds,\n optim_scale = optim_scale\n ))\n}\n\n# Posterior expected log-likelihood for a single effect regression\n#' @keywords internal\nSER_posterior_e_loglik.ss <- function(data, params, model, l) {\n Eb <- model$alpha[l, ] * model$mu[l, ]\n Eb2 <- model$alpha[l, ] * model$mu2[l, ]\n\n if (params$unmappable_effects == \"inf\") {\n # SuSiE-inf: Omega-weighted likelihood\n return(-0.5 * (-2 * sum(Eb * model$residuals) + sum(model$predictor_weights * as.vector(Eb2))))\n } else {\n # Standard SuSiE and SuSiE-ash\n return(-0.5 / model$residual_variance * (-2 * sum(Eb * model$residuals) + sum(model$predictor_weights * as.vector(Eb2))))\n }\n}\n\n# Calculate posterior moments for single effect regression\n#' @keywords internal\ncalculate_posterior_moments.ss <- function(data, params, model, V, l, ...) {\n if (params$use_NIG) {\n # NIG posterior moments\n if (V <= 0) {\n post_mean <- rep(0, data$p)\n post_mean2 <- rep(0, data$p)\n model$rv[l] <- 1\n } else {\n nig_ss <- get_nig_sufficient_stats(data, model)\n moments <- compute_posterior_moments_NIG(data$n, model$predictor_weights,\n model$residuals, nig_ss$yy, nig_ss$sxy,\n V, params$alpha0, params$beta0, nig_ss$tau)\n post_mean <- moments$post_mean\n post_mean2 <- moments$post_mean2\n model$rv[l] <- sum(model$alpha[l, ] * moments$rv)\n }\n } else {\n # Standard Gaussian posterior calculations\n shat2 <- model$residual_variance / model$predictor_weights\n if (!is.null(model$shat2_inflation))\n shat2 <- shat2 * model$shat2_inflation\n\n post_var <- V * shat2 / (V + shat2)\n post_mean <- V * (model$residuals / model$predictor_weights) / (V + shat2)\n post_mean2 <- post_var + post_mean^2\n }\n\n # Store posterior moments in model\n model$mu[l, ] <- post_mean\n model$mu2[l, ] <- post_mean2\n\n return(model)\n}\n\n# Calculate KL divergence\n#' @keywords internal\ncompute_kl.ss <- function(data, params, model, l) {\n if (params$use_NIG) {\n # NIG KL only valid for L=1 (gIBSS for L>1 has no coherent ELBO; supp. line 503)\n if (params$L == 1) {\n ki <- nig_kl_inputs(data, params, model, l)\n model$KL[l] <- compute_kl_NIG(model$alpha[l, ], model$mu[l, ], model$mu2[l, ],\n model$pi, model$V[l],\n a0 = params$alpha0 / 2, b0 = params$beta0 / 2,\n a_post = ki$a_post, b_post = ki$b_post,\n s_j_sq = ki$s_j_sq)\n } else {\n model$KL[l] <- 0\n }\n } else {\n model <- compute_kl.default(data, params, model, l)\n }\n return(model)\n}\n\n# Expected Squared Residuals\n#' @keywords internal\nget_ER2.ss <- function(data, model) {\n B <- model$alpha * model$mu\n postb2 <- model$alpha * model$mu2 # Posterior second moment.\n # Slot-weight correction: E[||y - sum_l c_l X beta^(l)||^2] under Bern(chat_l)\n # = y'y - 2 betabar_w' X'y + betabar_w' X'X betabar_w\n # + sum_l chat_l * E[b^(l)' X'X b^(l)] - chat_l^2 * bbar_l' X'X bbar_l\n # When slot_weights is NULL (all weights = 1), reduces to the standard formula.\n sw <- if (!is.null(model$slot_weights)) model$slot_weights else rep(1, nrow(B))\n betabar <- colSums(sw * B) # c_hat-weighted mean\n per_slot_XB2 <- rowSums(compute_BR(data, B) * B) # bbar_l' R bbar_l\n per_slot_Eb2 <- as.vector(postb2 %*% model$predictor_weights) # diag(X'X)' (alpha*mu2)_l\n\n return(data$yty - 2 * sum(betabar * data$Xty) + sum(betabar * compute_Rv(data, betabar)) -\n sum(sw^2 * per_slot_XB2) + sum(sw * per_slot_Eb2))\n}\n\n# Expected log-likelihood for the sufficient-stats path. Without inflation,\n# the standard regression log-likelihood under sigma2 (matches Eloglik.individual).\n# With finite-R inflation, the SER posterior fits a betahat-scale augmented\n# model; switch to the matching data-fit term. Affects ELBO only; PIP/CS/\n# sigma2 (which goes through est_residual_variance, not Eloglik) are unchanged.\n#' @keywords internal\nEloglik.ss <- function(data, model) {\n if (!is.null(model$shat2_inflation))\n return(compute_augmented_eloglik_ss(data, model))\n -data$n / 2 * log(2 * pi * model$sigma2) -\n 1 / (2 * model$sigma2) * get_ER2(data, model)\n}\n\n# Variational expectation of the augmented betahat-scale Gaussian log-\n# likelihood under finite-R inflation. Form derived in\n# ld_mismatch_generativemodel.tex Sec. \"Variational ELBO under the\n# augmented variance\". The Var_q[(X'X beta)_j] correction requires\n# (X'X)^2 element-wise; formed on each call.\n#' @keywords internal\ncompute_augmented_eloglik_ss <- function(data, model) {\n pw <- data$predictor_weights\n infl <- model$shat2_inflation\n sigma2 <- model$sigma2\n p <- length(pw)\n\n sw <- if (!is.null(model$slot_weights)) model$slot_weights else rep(1, nrow(model$alpha))\n am <- model$alpha * model$mu\n am2 <- model$alpha * model$mu2\n betabar <- colSums(sw * am)\n\n res_mean <- data$Xty - compute_Rv(data, betabar)\n\n XtX <- if (!is.null(data$XtX)) data$XtX else crossprod(data$X)\n XtX_sq <- XtX * XtX\n F_mat <- am %*% XtX\n G_mat <- am2 %*% XtX_sq\n var_corr <- as.vector(crossprod(G_mat - F_mat^2, sw^2))\n\n -p / 2 * log(2 * pi) -\n 0.5 * sum(log(sigma2 * infl / pw)) -\n 0.5 * sum((res_mean^2 + var_corr) / (pw * sigma2 * infl))\n}\n\n#' @importFrom Matrix colSums\n#' @importFrom stats dnorm\n#' @keywords internal\nloglik.ss <- function(data, params, model, V, ser_stats, l = NULL, ...) {\n if (params$use_NIG) {\n # NIG log Bayes factors\n nig_ss <- get_nig_sufficient_stats(data, model)\n lbf <- compute_lbf_NIG(data$n, model$predictor_weights,\n model$residuals, nig_ss$yy, nig_ss$sxy,\n V, params$alpha0, params$beta0, nig_ss$tau)\n } else {\n # Standard Gaussian prior log Bayes factors\n lbf <- dnorm(ser_stats$betahat, 0, sqrt(V + ser_stats$shat2), log = TRUE) -\n dnorm(ser_stats$betahat, 0, sqrt(ser_stats$shat2), log = TRUE)\n }\n\n # Stabilize logged Bayes Factor\n stable_res <- lbf_stabilization(lbf, model$pi, ser_stats$shat2)\n\n # Compute posterior weights\n weights_res <- compute_posterior_weights(stable_res$lpo)\n\n # Store in model if l is provided, otherwise return lbf_model for prior variance optimization\n if (!is.null(l)) {\n model$alpha[l, ] <- weights_res$alpha\n model$lbf[l] <- weights_res$lbf_model\n model$lbf_variable[l, ] <- stable_res$lbf\n\n # Compute and store marginal log-likelihood for NIG prior\n if (params$use_NIG) {\n model$marginal_loglik[l] <- compute_marginal_loglik(weights_res$lbf_model, data$n,\n nig_ss$yy, params$alpha0, params$beta0,\n TRUE)\n }\n return(model)\n } else {\n return(weights_res$lbf_model)\n }\n}\n\n#' @keywords internal\nneg_loglik.ss <- function(data, params, model, V_param, ser_stats, ...) {\n # Convert parameter to V based on optimization scale\n V <- if (ser_stats$optim_scale == \"log\") exp(V_param) else V_param\n\n if (params$unmappable_effects == \"inf\") {\n # SuSiE-inf: Omega-weighted objective with logSumExp trick\n # Apply finite-reference R inflation: effective pw = pw / inflation\n pw <- model$predictor_weights\n infl <- if (!is.null(model$shat2_inflation)) model$shat2_inflation else 1\n return(-matrixStats::logSumExp(\n -0.5 * log(1 + V * pw / infl) +\n V * model$residuals^2 / (2 * infl * (1 + V * pw / infl)) +\n log(model$pi + sqrt(.Machine$double.eps))\n ))\n } else {\n # Standard SuSiE and SuSiE-ash: standard objective\n lbf_model <- loglik.ss(data, params, model, V, ser_stats)\n return(-lbf_model)\n }\n}\n\n# =============================================================================\n# MODEL UPDATES & FITTING\n#\n# Functions for iterative model updates and variance component estimation.\n# These handle the dynamic aspects of model fitting including fitted value\n# updates and variance component estimation.\n#\n# Functions: update_fitted_values, update_variance_components, update_derived_quantities\n# =============================================================================\n\n# Update fitted values\n#' @keywords internal\nupdate_fitted_values.ss <- function(data, params, model, l, ...) {\n sw_l <- get_slot_weight(model, l)\n if (params$unmappable_effects == \"inf\") {\n # SuSiE-inf: include theta in fitted values\n sw <- if (!is.null(model$slot_weights)) model$slot_weights else rep(1, nrow(model$alpha))\n model$XtXr <- as.vector(compute_Rv(data, colSums(sw * model$alpha * model$mu) + model$theta))\n } else {\n # Standard SuSiE and SuSiE-ash: sparse component only\n model$XtXr <- model$fitted_without_l + sw_l * as.vector(compute_Rv(data, model$alpha[l, ] * model$mu[l, ]))\n }\n return(model)\n}\n\n# Update variance components for ss data\n#' @keywords internal\nupdate_variance_components.ss <- function(data, params, model, ...) {\n if (params$unmappable_effects == \"inf\") {\n # Calculate omega\n L <- nrow(model$alpha)\n omega_res <- compute_omega_quantities(data, model$tau2, model$sigma2)\n omega <- matrix(rep(omega_res$diagXtOmegaX, L), nrow = L, ncol = data$p, byrow = TRUE) +\n matrix(rep(1 / model$V, data$p), nrow = L, ncol = data$p, byrow = FALSE)\n\n # Compute theta for infinitesimal effects.\n theta <- compute_theta_blup(data, model)\n\n # Sigma2 and tau2 update\n if (params$estimate_residual_method == \"MLE\") {\n mle_result <- mle_unmappable(data, params, model, omega)\n return(list(sigma2 = mle_result$sigma2,\n tau2 = mle_result$tau2,\n theta = theta))\n } else {\n mom_result <- mom_unmappable(data, params, model, omega, model$tau2)\n return(list(sigma2 = mom_result$sigma2,\n tau2 = mom_result$tau2,\n theta = theta))\n }\n } else if (params$unmappable_effects == \"ash_filter_archived\") {\n # Original filter-based masking (archived for internal diagnostics)\n return(update_ash_variance_components_filter_archived(data, model, params))\n } else if (params$unmappable_effects == \"ash\") {\n # c_hat + 3 LD-interference heuristics\n return(update_ash_variance_components(data, model, params))\n } else {\n # Use default method for standard SuSiE\n return(update_variance_components.default(data, params, model))\n }\n}\n\n# Update derived quantities for ss data\n#' @keywords internal\nupdate_derived_quantities.ss <- function(data, params, model) {\n if (params$unmappable_effects == \"inf\") {\n # Update omega quantities for next iteration\n omega_res <- compute_omega_quantities(data, model$tau2, model$sigma2)\n model$omega_var <- omega_res$omega_var\n model$predictor_weights <- omega_res$diagXtOmegaX\n model$XtOmegay <- data$eigen_vectors %*% (data$VtXty / omega_res$omega_var)\n # Update fitted values to include theta\n b <- colSums(model$alpha * model$mu)\n model$XtXr <- compute_Rv(data, b + model$theta)\n return(model)\n } else {\n return(update_derived_quantities.default(data, params, model))\n }\n}\n\n# =============================================================================\n# OUTPUT GENERATION & POST-PROCESSING\n#\n# Functions for generating final results and summary statistics.\n# These process fitted models into interpretable outputs including\n# credible sets, variable names, and fitted values.\n#\n# Functions: get_scale_factors, get_intercept, get_fitted, get_cs,\n# get_variable_names, get_zscore\n# =============================================================================\n\n# Get column scale factors\n#' @keywords internal\nget_scale_factors.ss <- function(data, params) {\n pm <- if (!is.null(data$XtX)) data$XtX else data$X\n return(attr(pm, \"scaled:scale\"))\n}\n\n# Get intercept\n#' @keywords internal\nget_intercept.ss <- function(data, params, model, ...) {\n return(data$y_mean - sum(data$X_colmeans * (colSums(model$alpha * model$mu) / model$X_column_scale_factors)))\n}\n\n# Get Fitted Values\n#' @keywords internal\nget_fitted.ss <- function(data, params, model, ...) {\n return(get_fitted.default(data, params, model, ...))\n}\n\n# Get Credible Sets\n#' @keywords internal\nget_cs.ss <- function(data, params, model, ...) {\n if (is.null(params$coverage) || is.null(params$min_abs_corr)) {\n return(NULL)\n }\n\n if (!is.null(data$X)) {\n # Low-rank X path: data$X is B x p, columns are variables\n return(susie_get_cs(model,\n X = data$X,\n coverage = params$coverage,\n min_abs_corr = params$min_abs_corr,\n n_purity = params$n_purity))\n }\n\n if (any(!(diag(data$XtX) %in% c(0, 1)))) {\n Xcorr <- safe_cov2cor(data$XtX)\n } else {\n Xcorr <- data$XtX\n }\n\n return(susie_get_cs(model,\n Xcorr = Xcorr,\n check_symmetric = FALSE,\n coverage = params$coverage,\n min_abs_corr = params$min_abs_corr,\n n_purity = params$n_purity))\n}\n\n# Get Variable Names\n#' @keywords internal\nget_variable_names.ss <- function(data, model, ...) {\n pm <- if (!is.null(data$XtX)) data$XtX else data$X\n return(assign_names(data, model, colnames(pm)))\n}\n\n# Get univariate z-score\n#' @keywords internal\nget_zscore.ss <- function(data, params, model, ...) {\n return(get_zscore.default(data, params, model))\n}\n\n# Clean up model object for sufficient statistics data\n#' @keywords internal\ncleanup_model.ss <- function(data, params, model, ...) {\n # Remove common fields\n model <- cleanup_model.default(data, params, model, ...)\n\n # FIXME: for non-standard fields please connect them to \"runtime_xx\" where xx is unmappable effect option\n \n # Remove SS-specific fields for unmappable effects\n if (!is.null(params$unmappable_effects) && params$unmappable_effects == \"inf\") {\n unmappable_fields <- c(\"omega_var\", \"XtOmegay\")\n \n for (field in unmappable_fields) {\n if (field %in% names(model)) {\n model[[field]] <- NULL\n }\n }\n } else if (!is.null(params$unmappable_effects) && params$unmappable_effects == \"ash\") {\n model <- cleanup_ash_fields(model)\n } else if (!is.null(params$unmappable_effects) && params$unmappable_effects == \"ash_filter_archived\") {\n model <- cleanup_ash_fields_filter_archived(model)\n }\n \n # Remove NIG specific temporary fields\n if (params$use_NIG) {\n model$marginal_loglik <- NULL\n }\n \n return(model)\n}\n" }, { "path": "R/summary.susie.R", "content": "#' @title Summarize Susie Fit.\n#'\n#' @description \\code{summary} method for the \\dQuote{susie} class.\n#'\n#' @param object A susie fit.\n#'\n#' @param \\dots Additional arguments passed to the generic \\code{summary}\n#' or \\code{print.summary} method.\n#'\n#' @return \\code{summary.susie} returns a list containing a data frame\n#' of variables and a data frame of credible sets.\n#'\n#' @method summary susie\n#'\n#' @export summary.susie\n#'\n#' @export\n#'\nsummary.susie <- function(object, ...) {\n if (is.null(object$sets)) {\n stop(\n \"Cannot summarize SuSiE object because credible set information \",\n \"is not available\"\n )\n }\n variables <- data.frame(cbind(1:length(object$pip), object$pip, -1))\n colnames(variables) <- c(\"variable\", \"variable_prob\", \"cs\")\n rownames(variables) <- NULL\n if (object$null_index > 0) {\n variables <- variables[-object$null_index, ]\n }\n if (!is.null(object$sets$cs)) {\n cs <- data.frame(matrix(NA, length(object$sets$cs), 5))\n colnames(cs) <- c(\"cs\", \"cs_log10bf\", \"cs_avg_r2\", \"cs_min_r2\", \"variable\")\n for (i in 1:length(object$sets$cs)) {\n variables$cs[variables$variable %in% object$sets$cs[[i]]] <-\n object$sets$cs_index[[i]]\n cs$cs[i] <- object$sets$cs_index[[i]]\n cs$cs_log10bf[i] <- object$lbf[cs$cs[i]] / log(10)\n cs$cs_avg_r2[i] <- object$sets$purity$mean.abs.corr[i]^2\n cs$cs_min_r2[i] <- object$sets$purity$min.abs.corr[i]^2\n cs$variable[i] <- paste(object$sets$cs[[i]], collapse = \",\")\n }\n variables <- variables[order(variables$variable_prob, decreasing = TRUE), ]\n } else {\n cs <- NULL\n }\n out <- list(vars = variables, cs = cs)\n class(out) <- c(\"summary.susie\", \"list\")\n return(out)\n}\n\n#' @rdname summary.susie\n#'\n#' @param x A susie summary.\n#'\n#' @method print summary.susie\n#'\n#' @export print.summary.susie\n#'\n#' @export\n#'\nprint.summary.susie <- function(x, ...) {\n message(\"\\nVariables in credible sets:\\n\")\n print.data.frame(x$vars[which(x$vars$cs > 0), ], row.names = FALSE)\n message(\"\\nCredible sets summary:\\n\")\n print.data.frame(x$cs, row.names = FALSE)\n}\n" }, { "path": "R/susie.R", "content": "# =============================================================================\n# SuSiE WITH INDIVIDUAL-LEVEL DATA\n# =============================================================================\n\n#' @title Sum of Single Effects (SuSiE) Regression\n#'\n#' @description Performs a sparse Bayesian multiple linear regression\n#' of y on X, using the \"Sum of Single Effects\" model from Wang et al\n#' (2020). In brief, this function fits the regression model \\eqn{y =\n#' \\mu + X b + e}, where elements of \\eqn{e} are \\emph{i.i.d.} normal\n#' with zero mean and variance \\code{residual_variance}, \\eqn{\\mu} is\n#' an intercept term and \\eqn{b} is a vector of length p representing\n#' the effects to be estimated. The \\dQuote{susie assumption} is that\n#' \\eqn{b = \\sum_{l=1}^L b_l} where each \\eqn{b_l} is a vector of\n#' length p with exactly one non-zero element. The prior on the\n#' non-zero element is normal with zero mean and variance \\code{var(y)\n#' * scaled_prior_variance}. The value of \\code{L} is fixed, and\n#' should be chosen to provide a reasonable upper bound on the number\n#' of non-zero effects to be detected. Typically, the hyperparameters\n#' \\code{residual_variance} and \\code{scaled_prior_variance} will be\n#' estimated during model fitting, although they can also be fixed as\n#' specified by the user. See functions \\code{\\link{susie_get_cs}} and\n#' other functions of form \\code{susie_get_*} to extract the most\n#' commonly-used results from a susie fit.\n#'\n#' #' @details The function \\code{susie} implements the IBSS algorithm\n#' from Wang et al (2020). The option \\code{refine = TRUE} implements\n#' an additional step to help reduce problems caused by convergence of\n#' the IBSS algorithm to poor local optima (which is rare in our\n#' experience, but can provide misleading results when it occurs). The\n#' refinement step incurs additional computational expense that\n#' increases with the number of CSs found in the initial run.\n#'\n#' The function \\code{susie_ss} implements essentially the same\n#' algorithms, but using sufficient statistics. (The statistics are\n#' sufficient for the regression coefficients \\eqn{b}, but not for the\n#' intercept \\eqn{\\mu}; see below for how the intercept is treated.)\n#' If the sufficient statistics are computed correctly then the\n#' results from \\code{susie_ss} should be the same as (or very\n#' similar to) \\code{susie}, although runtimes will differ as\n#' discussed below. The sufficient statistics are the sample\n#' size \\code{n}, and then the p by p matrix \\eqn{X'X}, the p-vector\n#' \\eqn{X'y}, and the sum of squared y values \\eqn{y'y}, all computed\n#' after centering the columns of \\eqn{X} and the vector \\eqn{y} to\n#' have mean 0; these can be computed using \\code{compute_suff_stat}.\n#'\n#' The handling of the intercept term in \\code{susie_ss} needs\n#' some additional explanation. Computing the summary data after\n#' centering \\code{X} and \\code{y} effectively ensures that the\n#' resulting posterior quantities for \\eqn{b} allow for an intercept\n#' in the model; however, the actual value of the intercept cannot be\n#' estimated from these centered data. To estimate the intercept term\n#' the user must also provide the column means of \\eqn{X} and the mean\n#' of \\eqn{y} (\\code{X_colmeans} and \\code{y_mean}). If these are not\n#' provided, they are treated as \\code{NA}, which results in the\n#' intercept being \\code{NA}. If for some reason you prefer to have\n#' the intercept be 0 instead of \\code{NA} then set\n#' \\code{X_colmeans = 0,y_mean = 0}.\n#'\n#' For completeness, we note that if \\code{susie_ss} is run on\n#' \\eqn{X'X, X'y, y'y} computed \\emph{without} centering \\eqn{X} and\n#' \\eqn{y}, and with \\code{X_colmeans = 0,y_mean = 0}, this is\n#' equivalent to \\code{susie} applied to \\eqn{X, y} with\n#' \\code{intercept = FALSE} (although results may differ due to\n#' different initializations of \\code{residual_variance} and\n#' \\code{scaled_prior_variance}). However, this usage is not\n#' recommended for for most situations.\n#'\n#' The computational complexity of \\code{susie} is \\eqn{O(npL)} per\n#' iteration, whereas \\code{susie_ss} is \\eqn{O(p^2L)} per\n#' iteration (not including the cost of computing the sufficient\n#' statistics, which is dominated by the \\eqn{O(np^2)} cost of\n#' computing \\eqn{X'X}). Because of the cost of computing \\eqn{X'X},\n#' \\code{susie} will usually be faster. However, if \\eqn{n >> p},\n#' and/or if \\eqn{X'X} is already computed, then\n#' \\code{susie_ss} may be faster.\n#'\n#' @param X An n by p matrix of covariates.\n#'\n#' @param y The observed responses, a vector of length n.\n#'\n#' @param L Maximum number of non-zero effects in the model. If L is larger than\n#' the number of covariates, p, L is set to p.\n#'\n#' @param scaled_prior_variance The prior variance, divided by\n#' \\code{var(y)} (or by \\code{(1/(n-1))yty} for\n#' \\code{susie_ss}); that is, the prior variance of each\n#' non-zero element of b is \\code{var(y) * scaled_prior_variance}. The\n#' value provided should be either a scalar or a vector of length\n#' \\code{L}. If \\code{estimate_prior_variance = TRUE}, this provides\n#' initial estimates of the prior variances.\n#'\n#' @param residual_variance Variance of the residual. If\n#' \\code{estimate_residual_variance = TRUE}, this value provides the\n#' initial estimate of the residual variance. By default, it is set to\n#' \\code{var(y)} in \\code{susie} and \\code{(1/(n-1))yty} in\n#' \\code{susie_ss}.\n#'\n#' @param prior_weights A vector of length p, in which each entry\n#' gives the prior probability that corresponding column of X has a\n#' nonzero effect on the outcome, y. The weights are internally\n#' normalized to sum to 1. When \\code{NULL} (the default), uniform\n#' prior weights are used (each variable is assigned probability\n#' \\code{1/p}).\n#'\n#' @param null_weight Prior probability of no effect (a number between 0 and 1,\n#' and cannot be exactly 1).\n#'\n#' @param standardize If \\code{standardize = TRUE}, standardize the\n#' columns of X to unit variance prior to fitting (or equivalently\n#' standardize XtX and Xty to have the same effect). Note that\n#' \\code{scaled_prior_variance} specifies the prior on the\n#' coefficients of X \\emph{after} standardization (if it is\n#' performed). If you do not standardize, you may need to think more\n#' carefully about specifying \\code{scaled_prior_variance}. Whatever\n#' your choice, the coefficients returned by \\code{coef} are given for\n#' \\code{X} on the original input scale. Any column of \\code{X} that\n#' has zero variance is not standardized.\n#'\n#' @param intercept If \\code{intercept = TRUE}, the intercept is\n#' fitted; it \\code{intercept = FALSE}, the intercept is set to\n#' zero. Setting \\code{intercept = FALSE} is generally not\n#' recommended.\n#'\n#' @param estimate_residual_variance If\n#' \\code{estimate_residual_variance = TRUE}, the residual variance is\n#' estimated, using \\code{residual_variance} as an initial value. If\n#' \\code{estimate_residual_variance = FALSE}, the residual variance is\n#' fixed to the value supplied by \\code{residual_variance}.\n#'\n#' @param estimate_residual_method The method used for estimating residual variance.\n#' For the original SuSiE model, \"MLE\" and \"MoM\" estimation is equivalent, but for\n#' the infinitesimal model, \"MoM\" is more stable. We recommend using \"NIG\"\n#' when n < 80 for improved coverage, although it is currently only implemented\n#' for individual-level data.\n#'\n#' @param estimate_prior_variance If \\code{estimate_prior_variance =\n#' TRUE}, the prior variance is estimated (this is a separate\n#' parameter for each of the L effects). If provided,\n#' \\code{scaled_prior_variance} is then used as an initial value for\n#' the optimization. When \\code{estimate_prior_variance = FALSE}, the\n#' prior variance for each of the L effects is determined by the\n#' value supplied to \\code{scaled_prior_variance}.\n#'\n#' @param estimate_prior_method The method used for estimating prior\n#' variance. When \\code{estimate_prior_method = \"simple\"} is used, the\n#' likelihood at the specified prior variance is compared to the\n#' likelihood at a variance of zero, and the setting with the larger\n#' likelihood is retained. When \\code{prior_variance_grid} is provided,\n#' this is automatically set to \\code{\"fixed_mixture\"}.\n#'\n#' @param prior_variance_grid Numeric vector of K prior variances defining\n#' a mixture-of-normals prior on effect sizes. When provided, the SER\n#' evaluates Bayes factors at each grid point and forms a mixture BF\n#' weighted by \\code{mixture_weights}. This bypasses the scalar prior\n#' variance optimization. Default is \\code{NULL} (standard scalar V path).\n#'\n#' @param mixture_weights Numeric vector of K non-negative weights summing\n#' to 1, giving the mixture proportions for the variance grid. Default is\n#' \\code{NULL}, which uses uniform weights when \\code{prior_variance_grid}\n#' is provided.\n#'\n#' @param unmappable_effects The method for modeling unmappable effects:\n#' \"none\", \"inf\", \"ash\".\n#'\n#' @param check_null_threshold When the prior variance is estimated,\n#' compare the estimate with the null, and set the prior variance to\n#' zero unless the log-likelihood using the estimate is larger by this\n#' threshold amount. For example, if you set\n#' \\code{check_null_threshold = 0.1}, this will \"nudge\" the estimate\n#' towards zero when the difference in log-likelihoods is small. A\n#' note of caution that setting this to a value greater than zero may\n#' lead the IBSS fitting procedure to occasionally decrease the ELBO. This\n#' setting is disabled when using \\code{unmappable_effects = \"inf\"} or\n#' \\code{unmappable_effects = \"ash\"}.\n#'\n#' @param prior_tol When the prior variance is estimated, compare the\n#' estimated value to \\code{prior_tol} at the end of the computation,\n#' and exclude a single effect from PIP computation if the estimated\n#' prior variance is smaller than this tolerance value.\n#'\n#' @param residual_variance_upperbound Upper limit on the estimated\n#' residual variance. It is only relevant when\n#' \\code{estimate_residual_variance = TRUE}.\n#'\n#' @param model_init A previous susie fit with which to initialize.\n#'\n#' @param s_init Deprecated alias for \\code{model_init}.\n#'\n#' @param coverage A number between 0 and 1 specifying the\n#' \\dQuote{coverage} of the estimated confidence sets.\n#'\n#' @param min_abs_corr Minimum absolute correlation allowed in a\n#' credible set. The default, 0.5, corresponds to a squared\n#' correlation of 0.25, which is a commonly used threshold for\n#' genotype data in genetic studies. This \"purity\" filter is\n#' applied to the CSs reported in the fit object, so the CS list\n#' returned here may be a subset of the one produced by calling\n#' \\code{\\link{susie_get_cs}} on the same fit without passing\n#' \\code{X} or \\code{Xcorr} (in which case the purity filter is\n#' skipped).\n#'\n#' @param compute_univariate_zscore If \\code{compute_univariate_zscore\n#' = TRUE}, the univariate regression z-scores are outputted for each\n#' variable.\n#'\n#' @param na.rm Drop any missing values in y from both X and y.\n#'\n#' @param max_iter Maximum number of IBSS iterations to perform.\n#'\n#' @param L_greedy Integer or \\code{NULL}. When non-\\code{NULL}, run a\n#' greedy outer loop that grows the number of effects from\n#' \\code{L_greedy} up to \\code{L} in linear steps until the fit\n#' saturates. The default \\code{NULL} runs the usual fixed-\\code{L}\n#' fit.\n#'\n#' @param greedy_lbf_cutoff Numeric saturation threshold for the\n#' \\code{L_greedy} outer loop. Default is 0.1.\n#'\n#' @param tol tol A small, non-negative number specifying the convergence\n#' tolerance for the IBSS fitting procedure.\n#'\n#' @param convergence_method When \\code{converge_method = \"elbo\"} the fitting\n#' procedure halts when the difference in the variational lower bound, or\n#' \\dQuote{ELBO} (the objective function to be maximized), is\n#' less than \\code{tol}. When \\code{converge_method = \"pip\"} the fitting\n#' procedure halts when the maximum absolute difference in \\code{alpha} is less\n#' than \\code{tol}.\n#'\n#' @param verbose If \\code{verbose = TRUE}, the algorithm's progress,\n#' a summary of the optimization settings, and refinement progress (if\n#' \\code{refine = TRUE}) are printed to the console.\n#'\n#' @param track_fit If \\code{track_fit = TRUE}, \\code{trace}\n#' is also returned containing detailed information about the\n#' estimates at each iteration of the IBSS fitting procedure.\n#'\n#' @param residual_variance_lowerbound Lower limit on the estimated\n#' residual variance. It is only relevant when\n#' \\code{estimate_residual_variance = TRUE}.\n#'\n#' @param refine If \\code{refine = TRUE}, then an additional\n#' iterative refinement procedure is used, after the IBSS algorithm,\n#' to check and escape from local optima (see details).\n#'\n#' @param n_purity Passed as argument \\code{n_purity} to\n#' \\code{\\link{susie_get_cs}}.\n#'\n#' @param alpha0 Numerical parameter for the NIG prior when using\n#' \\code{estimate_residual_method = \"NIG\"}. Defaults to\n#' \\code{1/sqrt(n)}, where \\code{n} is the sample size. When calling\n#' \\code{susie_rss} with NIG, \\code{n} must be supplied; otherwise\n#' validation errors.\n#'\n#' @param beta0 Numerical parameter for the NIG prior when using\n#' \\code{estimate_residual_method = \"NIG\"}. Defaults to\n#' \\code{1/sqrt(n)}, where \\code{n} is the sample size. When calling\n#' \\code{susie_rss} with NIG, \\code{n} must be supplied; otherwise\n#' validation errors.\n#'\n#' @param slot_prior Optional slot activity prior created by\n#' \\code{\\link{slot_prior_betabinom}} or \\code{\\link{slot_prior_poisson}}.\n#' Use \\code{slot_prior_betabinom(a_beta, b_beta)} for the usual\n#' single-locus setting; it places a Beta-Binomial prior on the\n#' number of active effects and gives an adaptive multiplicity\n#' correction. Use \\code{slot_prior_poisson(C, nu)} when you want a\n#' Gamma-Poisson prior centered on an expected number \\code{C} of\n#' active effects. When supplied, each single-effect slot has an\n#' estimated activity probability \\code{c_hat}; fitted values and\n#' PIPs are weighted by these activity probabilities, and convergence\n#' is checked using \\code{convergence_method = \"pip\"}.\n#'\n#' @param init_only Logical. If \\code{TRUE}, return a list with\n#' \\code{data} and \\code{params} objects without running the IBSS\n#' algorithm. Used by packages like susieAnn that implement their own\n#' outer loop around SuSiE's building blocks. Default is \\code{FALSE}.\n#'\n#' @return A \\code{\"susie\"} object with some or all of the following elements:\n#'\n#' \\item{alpha}{An L by p matrix of posterior inclusion probabilities.}\n#'\n#' \\item{mu}{An L by p matrix of posterior means, conditional on inclusion.}\n#'\n#' \\item{mu2}{An L by p matrix of posterior second moments, conditional on\n#' inclusion.}\n#'\n#' \\item{Xr}{A vector of length n, equal to \\code{X \\%*\\% colSums(alpha * mu)}.}\n#'\n#' \\item{lbf}{Log-Bayes Factor for each single effect.}\n#'\n#' \\item{lbf_variable}{Log-Bayes Factor for each variable and single effect.}\n#'\n#' \\item{intercept}{Intercept (fixed or estimated).}\n#'\n#' \\item{sigma2}{Residual variance (fixed or estimated).}\n#'\n#' \\item{V}{Prior variance of the non-zero elements of b.}\n#'\n#' \\item{elbo}{The variational lower bound (or ELBO) achieved at each iteration.}\n#'\n#' \\item{fitted}{Vector of length n containing the fitted values.}\n#'\n#' \\item{sets}{Credible sets estimated from model fit.}\n#'\n#' \\item{pip}{A vector of length p giving the marginal posterior inclusion\n#' probabilities.}\n#'\n#' \\item{z}{A vector of univariate z-scores.}\n#'\n#' \\item{niter}{Number of IBSS iterations performed.}\n#'\n#' \\item{converged}{\\code{TRUE} or \\code{FALSE} indicating whether\n#' the IBSS converged to a solution within the chosen tolerance\n#' level.}\n#'\n#' \\item{theta}{If \\code{unmappable_effects = \"inf\"} or\n#' \\code{unmappable_effects = \"ash\"}, then \\code{theta} is a p-vector of posterior\n#' means for the unmappable effects.}\n#'\n#' \\item{tau2}{If \\code{unmappable_effects = \"inf\"} or\n#' \\code{unmappable_effects = \"ash\"}, then \\code{tau2} is the unmappable variance.}\n#'\n#' @importFrom stats var\n#' \n#' @export\n#' \nsusie <- function(X, y, L = min(10, ncol(X)),\n scaled_prior_variance = 0.2,\n residual_variance = NULL,\n prior_weights = NULL,\n null_weight = 0,\n standardize = TRUE,\n intercept = TRUE,\n estimate_residual_variance = TRUE,\n estimate_residual_method = c(\"MoM\", \"MLE\", \"NIG\"),\n estimate_prior_variance = TRUE,\n estimate_prior_method = c(\"optim\", \"EM\", \"simple\"),\n prior_variance_grid = NULL,\n mixture_weights = NULL,\n unmappable_effects = c(\"none\", \"inf\", \"ash\", \"ash_filter_archived\"),\n check_null_threshold = 0,\n prior_tol = 1e-9,\n residual_variance_upperbound = Inf,\n model_init = NULL,\n s_init = NULL,\n coverage = 0.95,\n min_abs_corr = 0.5,\n compute_univariate_zscore = FALSE,\n na.rm = FALSE,\n max_iter = 100,\n L_greedy = NULL,\n greedy_lbf_cutoff = 0.1,\n tol = 1e-4,\n convergence_method = c(\"elbo\", \"pip\"),\n verbose = FALSE,\n track_fit = FALSE,\n residual_variance_lowerbound = NULL,\n refine = FALSE,\n n_purity = 100,\n alpha0 = 1/sqrt(nrow(X)),\n beta0 = 1/sqrt(nrow(X)),\n init_only = FALSE,\n slot_prior = NULL) {\n\n # Validate method arguments\n unmappable_effects <- match.arg(unmappable_effects)\n estimate_residual_method <- match.arg(estimate_residual_method)\n convergence_method <- match.arg(convergence_method)\n mp <- resolve_mixture_prior(estimate_prior_method, estimate_prior_variance,\n prior_variance_grid, mixture_weights)\n estimate_prior_method <- mp$estimate_prior_method\n estimate_prior_variance <- mp$estimate_prior_variance\n prior_variance_grid <- mp$prior_variance_grid\n mixture_weights <- mp$mixture_weights\n\n # See vignette \"finemapping_summary_statistics\" for the recommended workflow\n if (verbose && nrow(X) >= 2 * ncol(X)) {\n warning_message(\n \"nrow(X) = \", nrow(X), \" >= 2 * ncol(X) = \", 2 * ncol(X), \". \",\n \"Consider precomputing sufficient statistics with compute_suff_stat() \",\n \"and fitting with susie_ss() instead -- this avoids holding X in \",\n \"memory at every iteration and lets you reuse XtX across multiple y.\",\n style = \"hint\"\n )\n }\n\n # Construct data and params objects\n susie_objects <- individual_data_constructor(\n X, y, L, scaled_prior_variance, residual_variance,\n prior_weights, null_weight, standardize, intercept,\n estimate_residual_variance, estimate_residual_method,\n estimate_prior_variance, estimate_prior_method,\n prior_variance_grid, mixture_weights,\n unmappable_effects, check_null_threshold, prior_tol,\n residual_variance_upperbound, model_init, s_init, coverage,\n min_abs_corr, compute_univariate_zscore, na.rm,\n max_iter, tol, convergence_method, verbose, track_fit,\n residual_variance_lowerbound, refine, n_purity,\n alpha0, beta0, slot_prior, L_greedy, greedy_lbf_cutoff\n )\n\n # Return data and params without fitting if init_only is TRUE.\n # The caller is responsible for calling ibss_initialize() on these.\n if (init_only) {\n return(susie_objects)\n }\n\n # Run main SuSiE algorithm\n model <- susie_workhorse(susie_objects$data, susie_objects$params)\n\n return(model)\n}\n\n# =============================================================================\n# SuSiE WITH SUFFICIENT STATISTICS\n# =============================================================================\n\n#' @title SuSiE using Sufficient Statistics\n#'\n#' @inheritParams susie\n#' \n#' @description Performs SuSiE regression using sufficient statistics (XtX, Xty,\n#' yty, n) instead of individual-level data (X, y).\n#'\n#' @param XtX A p by p matrix, X'X, with columns of X centered to have mean zero.\n#'\n#' @param Xty A p-vector, X'y, with y and columns of X centered to have mean zero.\n#'\n#' @param yty A scalar, y'y, with y centered to have mean zero.\n#'\n#' @param n The sample size.\n#'\n#' @param X_colmeans A p-vector of column means of \\code{X}. If both\n#' \\code{X_colmeans} and \\code{y_mean} are provided, the intercept\n#' is estimated; otherwise, the intercept is NA.\n#'\n#' @param y_mean A scalar containing the mean of \\code{y}. If both\n#' \\code{X_colmeans} and \\code{y_mean} are provided, the intercept\n#' is estimated; otherwise, the intercept is NA.\n#'\n#' @param maf A p-vector of minor allele frequencies; to be used along with\n#' \\code{maf_thresh} to filter input summary statistics.\n#'\n#' @param maf_thresh Variants with MAF smaller than this threshold are not used.\n#'\n#' @param check_input If \\code{check_input = TRUE}, \\code{susie_ss} performs\n#' additional checks on \\code{XtX} and \\code{Xty}. The checks are:\n#' (1) check that \\code{XtX} is positive semidefinite; (2) check that\n#' \\code{Xty} is in the space spanned by the non-zero eigenvectors of \\code{XtX}.\n#'\n#' @param r_tol Tolerance level for eigenvalue check of positive semidefinite\n#' matrix \\code{XtX}.\n#'\n#' @param check_prior If \\code{check_prior = TRUE}, it checks if the\n#' estimated prior variance becomes unreasonably large (comparing with\n#' 10 * max(abs(z))^2).\n#'\n#' @export\n#' \nsusie_ss <- function(XtX, Xty, yty, n,\n L = min(10, ncol(XtX)),\n X_colmeans = NA, y_mean = NA,\n maf = NULL, maf_thresh = 0,\n check_input = FALSE,\n r_tol = 1e-8,\n standardize = TRUE,\n scaled_prior_variance = 0.2,\n residual_variance = NULL,\n prior_weights = NULL,\n null_weight = 0,\n model_init = NULL,\n s_init = NULL,\n estimate_residual_variance = TRUE,\n estimate_residual_method = c(\"MoM\", \"MLE\", \"NIG\"),\n residual_variance_lowerbound = 0,\n residual_variance_upperbound = Inf,\n estimate_prior_variance = TRUE,\n estimate_prior_method = c(\"optim\", \"EM\", \"simple\"),\n prior_variance_grid = NULL,\n mixture_weights = NULL,\n unmappable_effects = c(\"none\", \"inf\", \"ash\", \"ash_filter_archived\"),\n check_null_threshold = 0,\n prior_tol = 1e-9,\n max_iter = 100,\n L_greedy = NULL,\n greedy_lbf_cutoff = 0.1,\n tol = 1e-4,\n convergence_method = c(\"elbo\", \"pip\"),\n coverage = 0.95,\n min_abs_corr = 0.5,\n n_purity = 100,\n verbose = FALSE,\n track_fit = FALSE,\n check_prior = FALSE,\n refine = FALSE,\n alpha0 = 1/sqrt(n),\n beta0 = 1/sqrt(n),\n slot_prior = NULL) {\n\n # Validate method arguments\n unmappable_effects <- match.arg(unmappable_effects)\n estimate_residual_method <- match.arg(estimate_residual_method)\n convergence_method <- match.arg(convergence_method)\n mp <- resolve_mixture_prior(estimate_prior_method, estimate_prior_variance,\n prior_variance_grid, mixture_weights)\n estimate_prior_method <- mp$estimate_prior_method\n estimate_prior_variance <- mp$estimate_prior_variance\n prior_variance_grid <- mp$prior_variance_grid\n mixture_weights <- mp$mixture_weights\n\n # Construct data and params objects\n susie_objects <- sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = n, XtX = XtX,\n L = L, X_colmeans = X_colmeans, y_mean = y_mean,\n maf = maf, maf_thresh = maf_thresh,\n check_input = check_input, r_tol = r_tol, standardize = standardize,\n scaled_prior_variance = scaled_prior_variance,\n residual_variance = residual_variance,\n prior_weights = prior_weights, null_weight = null_weight,\n model_init = model_init, s_init = s_init,\n estimate_residual_variance = estimate_residual_variance,\n estimate_residual_method = estimate_residual_method,\n residual_variance_lowerbound = residual_variance_lowerbound,\n residual_variance_upperbound = residual_variance_upperbound,\n estimate_prior_variance = estimate_prior_variance,\n estimate_prior_method = estimate_prior_method,\n prior_variance_grid = prior_variance_grid,\n mixture_weights = mixture_weights,\n unmappable_effects = unmappable_effects,\n check_null_threshold = check_null_threshold, prior_tol = prior_tol,\n max_iter = max_iter, tol = tol, convergence_method = convergence_method,\n coverage = coverage, min_abs_corr = min_abs_corr, n_purity = n_purity,\n verbose = verbose, track_fit = track_fit, check_prior = check_prior,\n refine = refine, alpha0 = alpha0, beta0 = beta0,\n slot_prior = slot_prior, L_greedy = L_greedy,\n greedy_lbf_cutoff = greedy_lbf_cutoff\n )\n\n # Run main SuSiE algorithm\n model <- susie_workhorse(susie_objects$data, susie_objects$params)\n\n return(model)\n}\n\n# =============================================================================\n# SuSiE WITH REGRESSION SUMMARY STATISTICS\n# =============================================================================\n\n#' @title SuSiE with Regression Summary Statistics (RSS)\n#'\n#' @inheritParams susie_ss\n#' \n#' @description Performs SuSiE regression using z-scores and correlation matrix.\n#' This is the sufficient-statistics RSS interface. For the specialized\n#' regularized eigendecomposition likelihood with \\code{lambda > 0}, use\n#' \\code{\\link{susie_rss_lambda}}.\n#'\n#' @param z A p-vector of z-scores.\n#'\n#' @param R A p by p correlation matrix. Exactly one of \\code{R} or\n#' \\code{X} must be provided.\n#'\n#' @param n The sample size, not required but recommended.\n#'\n#' @param X A factor matrix (B x p) such that \\code{R = crossprod(X) /\n#' nrow(X)} approximates the R (correlation) matrix. When\n#' \\code{nrow(X) >= ncol(X)}, the correlation matrix \\code{R} is\n#' formed explicitly and the standard path is used. When\n#' \\code{nrow(X) < ncol(X)}, a low-rank path is used that avoids\n#' forming the p x p matrix, reducing per-iteration cost from\n#' O(Lp^2) to O(LBp). Columns of \\code{X} are standardized\n#' internally.\n#'\n#' @param bhat Alternative summary data giving the estimated effects\n#' (a vector of length p). This, together with \\code{shat}, may be\n#' provided instead of \\code{z}.\n#'\n#' @param shat Alternative summary data giving the standard errors of\n#' the estimated effects (a vector of length p). This, together with\n#' \\code{bhat}, may be provided instead of \\code{z}.\n#'\n#' @param var_y The sample variance of y, defined as \\eqn{y'y/(n-1)}.\n#' When the sample variance is not provided, the coefficients\n#' (returned from \\code{coef}) are computed on the\n#' \\dQuote{standardized} X, y scale.\n#' \n#' @param estimate_residual_variance The default is FALSE, the\n#' residual variance is fixed to 1 or variance of y. If the in-sample\n#' R matrix is provided, we recommend setting\n#' \\code{estimate_residual_variance = TRUE}.\n#'\n#' @param R_finite Controls variance inflation to account\n#' for estimating the R matrix from a finite reference panel. Accepts three\n#' types of input:\n#' \\describe{\n#' \\item{\\code{NULL} (default)}{The R matrix is treated as trusted, and no\n#' finite-reference variance inflation is applied.}\n#' \\item{\\code{TRUE}}{Infer the reference sample size B from the input\n#' \\code{X}. Sets \\code{B = nrow(X)} for single-panel input,\n#' or \\code{B = min(nrow(X_k))} across panels for multi-panel\n#' input. Requires \\code{X} to be provided (errors if only\n#' \\code{R} is given, since B cannot be inferred).}\n#' \\item{Number}{Explicit reference sample size B.}\n#' }\n#' When active, this dynamically inflates the null variance of each\n#' variable's score statistic at every IBSS iteration to account for\n#' finite-reference uncertainty in the Single Effect Regression (SER).\n#' When provided, the output includes a\n#' \\code{R_finite_diagnostics} element with per-region and\n#' per-variable quality metrics.\n#'\n#' @param R_mismatch R-bias correction mode. \\code{\"none\"} (default) is off.\n#' \\code{\"map\"} adds a region-level population-mismatch variance\n#' component on top of the finite-reference correction; recommended\n#' whenever \\code{R} comes from a different cohort than the GWAS.\n#' \\code{\"map_qc\"} is \\code{\"map\"} plus a QC score (\\code{Q_art}) that\n#' warns when the fitted residual carries energy in directions where\n#' the supplied \\code{R} indicates signal should be weak. For\n#' allele-coding / strand-flip checks, see the kriging diagnostic in\n#' \\code{susie_rss}'s companion utilities.\n#' Requires \\code{R_finite}; auto-disables \\code{estimate_residual_variance}\n#' with a warning.\n#'\n#' @param eig_delta_rel,eig_delta_abs Cutoffs for \"low-eigenvalue\"\n#' directions of \\code{R} used by the QC diagnostic\n#' (\\code{R_mismatch = \"map_qc\"}). Default \\code{eig_delta_rel = 1e-3},\n#' \\code{eig_delta_abs = 0}; the threshold is\n#' \\code{max(eig_delta_abs, eig_delta_rel * max_eigenvalue(R))}. Tighter\n#' (smaller) values flag fewer regions.\n#'\n#' @param artifact_threshold Flag threshold on the QC score \\code{Q_art}\n#' (a fraction in [0, 1]). Default \\code{0.1}; flag fires when\n#' \\code{Q_art > artifact_threshold}. Heuristic, not a calibrated test.\n#'\n#' @param init_only Logical. If \\code{TRUE}, return a list with\n#' \\code{data} and \\code{params} objects without running the IBSS\n#' algorithm. Default is \\code{FALSE}.\n#'\n#' @return In addition to the standard \\code{\"susie\"} output (see\n#' \\code{\\link{susie}}), the returned object may contain:\n#'\n#' \\item{R_finite_diagnostics}{A list of diagnostics for the\n#' finite-reference correction (only present when\n#' \\code{R_finite} is provided), containing:\n#' \\code{B} (the reference sample size);\n#' \\code{p} (number of variables);\n#' \\code{effective_rank} (debiased \\eqn{\\tilde{r} = p^2 / \\|R\\|_F^2});\n#' \\code{r_over_B} (\\eqn{\\tilde{r}/B}, one number per region; values\n#' \\eqn{\\le 0.2} indicate the reference panel is adequate);\n#' \\code{Rhat_diag_deviation} (\\eqn{|\\hat{R}_{jj} - 1|}, one number\n#' per variable);\n#' \\code{lambda_bias} (region-level scalar on the default\n#' \\code{lambda = 0} sufficient-statistics path when\n#' \\code{R_mismatch != \"none\"});\n#' \\code{B_corrected} (effective reference sample size after the\n#' R-bias correction, \\eqn{1/(1/B + \\lambda_{\\mathrm{bias}})};\n#' substantially\n#' smaller than the input \\code{B} flags a dominant population\n#' mismatch component);\n#' \\code{per_variable_penalty} (final-iteration\n#' \\eqn{v_j / \\sigma^2 = \\tau_j^2 / \\sigma^2 - 1}, one number per\n#' variable; values \\eqn{\\le 0.2} indicate minimal power loss,\n#' values \\eqn{\\gg 1} flag variables where the correction is doing\n#' heavy lifting).}\n#'\n#' @export\n#' \nsusie_rss <- function(z = NULL, R = NULL, n = NULL,\n X = NULL,\n bhat = NULL, shat = NULL, var_y = NULL,\n L = min(10, if (is.list(R) && !is.matrix(R)) ncol(R[[1]])\n else if (!is.null(R)) ncol(R)\n else if (is.list(X) && !is.matrix(X)) ncol(X[[1]])\n else ncol(X)),\n maf = NULL,\n maf_thresh = 0,\n scaled_prior_variance = 0.2,\n residual_variance = NULL,\n prior_weights = NULL,\n null_weight = 0,\n standardize = TRUE,\n estimate_residual_variance = FALSE,\n estimate_residual_method = c(\"MoM\", \"MLE\", \"NIG\"),\n estimate_prior_variance = TRUE,\n estimate_prior_method = c(\"optim\", \"EM\", \"simple\"),\n prior_variance_grid = NULL,\n mixture_weights = NULL,\n unmappable_effects = c(\"none\", \"inf\", \"ash\", \"ash_filter_archived\"),\n check_null_threshold = 0,\n prior_tol = 1e-9,\n residual_variance_lowerbound = 0,\n residual_variance_upperbound = Inf,\n model_init = NULL,\n s_init = NULL,\n coverage = 0.95,\n min_abs_corr = 0.5,\n max_iter = 100,\n L_greedy = NULL,\n greedy_lbf_cutoff = 0.1,\n tol = 1e-4,\n convergence_method = c(\"elbo\", \"pip\"),\n verbose = FALSE,\n track_fit = FALSE,\n check_input = FALSE,\n check_prior = TRUE,\n n_purity = 100,\n r_tol = 1e-8,\n refine = FALSE,\n R_finite = NULL,\n R_mismatch = c(\"none\", \"map\", \"map_qc\"),\n eig_delta_rel = 1e-3,\n eig_delta_abs = 0,\n artifact_threshold = 0.1,\n alpha0 = if (is.null(n)) NULL else 1/sqrt(n),\n beta0 = if (is.null(n)) NULL else 1/sqrt(n),\n init_only = FALSE,\n slot_prior = NULL) {\n\n # Validate: exactly one of R or X must be provided\n if (is.null(R) && is.null(X))\n stop(\"Please provide either R (correlation matrix) or X (factor matrix).\")\n if (!is.null(R) && !is.null(X))\n stop(\"Please provide either R or X, but not both.\")\n is_multi_panel <- (is.list(X) && !is.matrix(X)) ||\n (is.list(R) && !is.matrix(R))\n\n R_mismatch <- match.arg(R_mismatch)\n\n if (!is.numeric(eig_delta_rel) || length(eig_delta_rel) != 1L ||\n eig_delta_rel < 0)\n stop(\"eig_delta_rel must be a single nonnegative numeric.\")\n if (!is.numeric(eig_delta_abs) || length(eig_delta_abs) != 1L ||\n eig_delta_abs < 0)\n stop(\"eig_delta_abs must be a single nonnegative numeric.\")\n if (!is.numeric(artifact_threshold) || length(artifact_threshold) != 1L ||\n artifact_threshold < 0 || artifact_threshold > 1)\n stop(\"artifact_threshold must be a single numeric in [0, 1].\")\n\n # Resolve R_finite BEFORE any X -> R conversion.\n if (isTRUE(R_finite) && is.null(X))\n stop(\"R_finite = TRUE requires X input. When using precomputed R, \",\n \"provide the reference sample size explicitly.\")\n R_finite <- resolve_R_finite(R_finite, if (!is.null(X)) X else R,\n is_multi_panel)\n if (R_mismatch != \"none\" && is.null(R_finite))\n stop(\"R_mismatch requires R_finite because lambda_bias is estimated \",\n \"as extra R bias beyond finite-reference uncertainty.\")\n\n # sigma^2 and lambda_bias both inflate the residual variance and are\n # only weakly jointly identified; we follow Zou et al. (2022) and fix\n # sigma^2 when R_mismatch is active.\n if (R_mismatch != \"none\" && isTRUE(estimate_residual_variance)) {\n warning_message(\n \"R_mismatch = '\", R_mismatch, \"' is incompatible with \",\n \"estimate_residual_variance = TRUE; disabling sigma^2 estimation.\"\n )\n estimate_residual_variance <- FALSE\n }\n\n # Multi-panel: shared validation, PIP-switch, and per-panel sub-fit\n # machinery. The R-input and X-input branches differ only in (i) what\n # \"valid\" means for an element and (ii) whether the panels need\n # centering. They share everything else: the n requirement, the\n # PIP-convergence switch, and the per-panel single-panel sub-fits used\n # to pick the best mixture init via attr(., \".init_panel\").\n if (is_multi_panel) {\n if (is.null(n))\n stop(\"Sample size 'n' is required for multi-panel mode.\")\n if (convergence_method[1] == \"elbo\") {\n convergence_method <- \"pip\"\n warning_message(\"Switching to PIP-based convergence for multi-panel mixture \",\n \"as mixture weights updates change R(omega) each iteration, which prevents \",\n \"ELBO monotonicity.\")\n }\n\n # Capture the user's call frame here so the per-panel recursive call\n # can resolve any unevaluated arguments in the original caller env.\n user_env <- parent.frame()\n sp_call <- match.call()\n sp_call[[1]] <- quote(susie_rss)\n sp_call$verbose <- FALSE\n sp_call$s_init <- NULL\n sp_call$model_init <- NULL\n\n # Returns the index of the panel with the highest single-panel ELBO.\n # `panel_arg` selects which call slot to substitute (`\"R\"` or `\"X\"`).\n pick_init_panel <- function(panels, panel_arg) {\n sp_fits <- lapply(seq_along(panels), function(k) {\n sp_call[[panel_arg]] <- panels[[k]]\n sp_call$R_finite <- if (is.null(R_finite)) NULL else R_finite[k]\n tryCatch(eval(sp_call, user_env), error = function(e) NULL)\n })\n sp_elbos <- vapply(sp_fits, function(f)\n if (!is.null(f)) tail(f$elbo, 1) else -Inf, numeric(1))\n which.max(sp_elbos)\n }\n\n if (!is.null(R)) {\n for (k in seq_along(R)) {\n if (!is.matrix(R[[k]]) || !is.numeric(R[[k]]))\n stop(\"Each element of R list must be a numeric matrix.\")\n if (nrow(R[[k]]) != ncol(R[[k]]))\n stop(\"Each element of R list must be square.\")\n }\n attr(R, \".init_panel\") <- pick_init_panel(R, \"R\")\n } else {\n for (k in seq_along(X)) {\n if (!is.matrix(X[[k]]) || !is.numeric(X[[k]]))\n stop(\"Each element of X list must be a numeric matrix.\")\n }\n # Center each panel before sub-fits so that crossprod(Xk) gives a\n # covariance-like quantity, matching the ss_mixture_constructor's\n # downstream expectation.\n X <- lapply(X, function(Xk) {\n cm <- colMeans(Xk)\n if (max(abs(cm)) > 1e-10 * max(abs(Xk)))\n Xk <- t(t(Xk) - cm)\n Xk\n })\n attr(X, \".init_panel\") <- pick_init_panel(X, \"X\")\n }\n }\n\n # Handle single-panel X input.\n if (!is.null(X) && !is_multi_panel) {\n if (!is.matrix(X) || !is.numeric(X))\n stop(\"X must be a numeric matrix.\")\n\n # Center columns of X so that crossprod gives covariance-like quantities.\n cm <- colMeans(X)\n if (max(abs(cm)) > 1e-10 * max(abs(X)))\n X <- t(t(X) - cm)\n\n # Features incompatible with the low-rank path: fall back to forming R\n needs_R <- !is.null(var_y) && !is.null(shat)\n if (needs_R && nrow(X) < ncol(X)) {\n warning_message(\n \"X is provided as a low-rank factor matrix, but var_y/shat \",\n \"requires the full correlation matrix R. Forming \",\n \"R = cov2cor(crossprod(X)/nrow(X)) and using the standard path.\")\n }\n\n # If nrow(X) >= ncol(X) or features require R, form R and use standard path\n if (nrow(X) >= ncol(X) || needs_R) {\n R <- safe_cor(X)\n X <- NULL\n }\n }\n\n # Validate method arguments\n unmappable_effects <- match.arg(unmappable_effects)\n estimate_residual_method <- match.arg(estimate_residual_method)\n convergence_method <- match.arg(convergence_method)\n mp <- resolve_mixture_prior(estimate_prior_method, estimate_prior_variance,\n prior_variance_grid, mixture_weights)\n estimate_prior_method <- mp$estimate_prior_method\n estimate_prior_variance <- mp$estimate_prior_variance\n prior_variance_grid <- mp$prior_variance_grid\n mixture_weights <- mp$mixture_weights\n\n # Auto-switch to PIP convergence for finite-reference R inflation.\n # (R_finite was already resolved to an integer above)\n if (!is.null(R_finite) && convergence_method[1] == \"elbo\") {\n convergence_method <- \"pip\"\n warning_message(\"Switching to PIP-based convergence because finite-reference R inflation \",\n \"modifies per-variant SER likelihoods which prevents a consistent model-level ELBO.\")\n }\n\n # Construct data and params objects with ALL parameters\n susie_objects <- summary_stats_constructor(\n z = z, R = R, X = X, n = n,\n bhat = bhat, shat = shat, var_y = var_y,\n L = L, maf = maf, maf_thresh = maf_thresh,\n scaled_prior_variance = scaled_prior_variance,\n residual_variance = residual_variance,\n prior_weights = prior_weights, null_weight = null_weight,\n standardize = standardize,\n estimate_residual_variance = estimate_residual_variance,\n estimate_residual_method = estimate_residual_method,\n estimate_prior_variance = estimate_prior_variance,\n estimate_prior_method = estimate_prior_method,\n prior_variance_grid = prior_variance_grid,\n mixture_weights = mixture_weights,\n unmappable_effects = unmappable_effects,\n check_null_threshold = check_null_threshold, prior_tol = prior_tol,\n residual_variance_lowerbound = residual_variance_lowerbound,\n residual_variance_upperbound = residual_variance_upperbound,\n model_init = model_init, s_init = s_init,\n coverage = coverage, min_abs_corr = min_abs_corr,\n max_iter = max_iter, tol = tol, convergence_method = convergence_method,\n verbose = verbose, track_fit = track_fit, check_input = check_input,\n check_prior = check_prior,\n n_purity = n_purity, r_tol = r_tol, refine = refine,\n R_finite = R_finite, R_mismatch = R_mismatch,\n eig_delta_rel = eig_delta_rel, eig_delta_abs = eig_delta_abs,\n artifact_threshold = artifact_threshold,\n alpha0 = alpha0, beta0 = beta0,\n slot_prior = slot_prior, L_greedy = L_greedy,\n greedy_lbf_cutoff = greedy_lbf_cutoff\n )\n\n # Return constructed data and params without running IBSS (for susieAnn\n # and other packages that implement their own outer loop). The caller\n # is responsible for calling ibss_initialize() on the returned objects.\n if (init_only) {\n return(susie_objects)\n }\n\n # Run main SuSiE algorithm\n model <- susie_workhorse(susie_objects$data, susie_objects$params)\n\n # Store single-panel fits inside the mixture result so users can compare.\n # Always return the mixture result; users can choose a single-panel fit\n # from model$single_panel_fits if they prefer.\n if (exists(\"sp_fits\") && !is.null(sp_fits)) {\n if (verbose) {\n mix_elbo <- tail(model$elbo, 1)\n best_k <- which.max(sp_elbos)\n omega_str <- paste(round(model$omega_weights, 3), collapse = \", \")\n message(sprintf(\n \"Multi-panel: mixture ELBO = %.2f (omega = %s), best single-panel ELBO = %.2f (panel %d).\",\n mix_elbo, omega_str, sp_elbos[best_k], best_k))\n }\n model$single_panel_fits <- sp_fits\n }\n\n return(model)\n}\n\n#' Sum of Single Effects Regression using the RSS-lambda likelihood\n#'\n#' @description Specialized interface for the regularized eigendecomposition\n#' RSS likelihood of Zou et al. (2022). This path accepts a single reference\n#' matrix or a single factor matrix and does not support multi-panel mixture,\n#' finite-reference inflation, or R-bias correction.\n#'\n#' @inheritParams susie_rss\n#'\n#' @param lambda Regularization parameter for the RSS-lambda likelihood.\n#' Must be supplied. \\code{lambda = \"estimate\"} estimates lambda from\n#' the null-space residual.\n#' @param prior_variance Prior variance for each non-zero effect on the\n#' z-score scale. Replaces \\code{scaled_prior_variance} from\n#' \\code{\\link{susie_rss}}. Default \\code{50}.\n#' @param intercept_value Intercept used by the RSS-lambda likelihood.\n#' Default \\code{0}.\n#' @param estimate_residual_method Variance-component estimator. The\n#' RSS-lambda path supports \\code{\"MLE\"} only; any other value errors.\n#' @param estimate_prior_variance If \\code{estimate_prior_variance = TRUE},\n#' the prior variance is estimated (a separate parameter for each of\n#' the L effects). When \\code{TRUE}, \\code{prior_variance} provides the\n#' initial value; when \\code{FALSE}, it is held fixed.\n#' @param check_null_threshold When the prior variance is estimated,\n#' compare its likelihood to the likelihood at zero and use zero\n#' unless the larger value exceeds it by at least\n#' \\code{check_null_threshold}. \\code{0} (default) takes the larger\n#' likelihood at face value.\n#' @param check_R If TRUE, verify that \\code{R} is positive semidefinite.\n#' @param check_z If TRUE, verify that \\code{z} lies in the column space\n#' of \\code{R}.\n#'\n#' @return A \\code{\"susie\"} fit (or, with \\code{init_only = TRUE}, the\n#' constructed data and params objects).\n#'\n#' @export\nsusie_rss_lambda <- function(z = NULL, R = NULL, n = NULL,\n X = NULL,\n L = min(10, if (!is.null(R)) ncol(R)\n else ncol(X)),\n lambda,\n maf = NULL,\n maf_thresh = 0,\n prior_variance = 50,\n residual_variance = NULL,\n prior_weights = NULL,\n null_weight = 0,\n intercept_value = 0,\n estimate_residual_variance = FALSE,\n estimate_residual_method = \"MLE\",\n estimate_prior_variance = TRUE,\n estimate_prior_method = c(\"optim\", \"EM\", \"simple\"),\n prior_variance_grid = NULL,\n mixture_weights = NULL,\n check_null_threshold = 0,\n prior_tol = 1e-9,\n residual_variance_lowerbound = 0,\n model_init = NULL,\n coverage = 0.95,\n min_abs_corr = 0.5,\n max_iter = 100,\n L_greedy = NULL,\n greedy_lbf_cutoff = 0.1,\n tol = 1e-4,\n convergence_method = c(\"elbo\", \"pip\"),\n verbose = FALSE,\n track_fit = FALSE,\n check_prior = TRUE,\n check_R = TRUE,\n check_z = FALSE,\n n_purity = 100,\n r_tol = 1e-8,\n refine = FALSE,\n init_only = FALSE,\n slot_prior = NULL) {\n if (missing(lambda))\n stop(\"susie_rss_lambda() requires lambda.\")\n if (is.null(R) && is.null(X))\n stop(\"Please provide either R (correlation matrix) or X (factor matrix).\")\n if (!is.null(R) && !is.null(X))\n stop(\"Please provide either R or X, but not both.\")\n if (is.list(R) && !is.matrix(R))\n stop(\"susie_rss_lambda() accepts only a single R matrix.\")\n if (is.list(X) && !is.matrix(X))\n stop(\"susie_rss_lambda() accepts only a single X matrix.\")\n if (!identical(estimate_residual_method, \"MLE\"))\n stop(\"susie_rss_lambda() supports estimate_residual_method = \\\"MLE\\\" only.\")\n\n convergence_method <- match.arg(convergence_method)\n mp <- resolve_mixture_prior(estimate_prior_method, estimate_prior_variance,\n prior_variance_grid, mixture_weights)\n estimate_prior_method <- mp$estimate_prior_method\n estimate_prior_variance <- mp$estimate_prior_variance\n prior_variance_grid <- mp$prior_variance_grid\n mixture_weights <- mp$mixture_weights\n\n susie_objects <- rss_lambda_constructor(\n z = z, R = R, X = X, n = n,\n L = L, lambda = lambda, maf = maf, maf_thresh = maf_thresh,\n prior_variance = prior_variance,\n residual_variance = residual_variance,\n prior_weights = prior_weights, null_weight = null_weight,\n intercept_value = intercept_value,\n estimate_residual_variance = estimate_residual_variance,\n estimate_residual_method = estimate_residual_method,\n estimate_prior_variance = estimate_prior_variance,\n estimate_prior_method = estimate_prior_method,\n prior_variance_grid = prior_variance_grid,\n mixture_weights = mixture_weights,\n check_null_threshold = check_null_threshold, prior_tol = prior_tol,\n residual_variance_lowerbound = residual_variance_lowerbound,\n model_init = model_init, coverage = coverage, min_abs_corr = min_abs_corr,\n max_iter = max_iter, tol = tol, convergence_method = convergence_method,\n verbose = verbose, track_fit = track_fit,\n check_prior = check_prior, check_R = check_R, check_z = check_z,\n n_purity = n_purity, r_tol = r_tol, refine = refine,\n slot_prior = slot_prior, L_greedy = L_greedy,\n greedy_lbf_cutoff = greedy_lbf_cutoff\n )\n\n if (init_only)\n return(susie_objects)\n\n susie_workhorse(susie_objects$data, susie_objects$params)\n}\n" }, { "path": "R/susieR-package.R", "content": "#' @keywords internal\n\"_PACKAGE\"\n\n# The following block is used by usethis to automatically manage\n# roxygen namespace tags. Modify with care!\n## usethis namespace: start\n## usethis namespace: end\nNULL\n" }, { "path": "R/susie_auto.R", "content": "#' @title Attempt at Automating SuSiE for Hard Problems\n#'\n#' @description \\code{susie_auto} is an attempt to automate reliable\n#' running of susie even on hard problems. It implements a three-stage\n#' strategy for each L: first, fit susie with very small residual\n#' error; next, estimate residual error; finally, estimate the prior\n#' variance. If the last step estimates some prior variances to be\n#' zero, stop. Otherwise, double L, and repeat. Initial runs are\n#' performed with relaxed tolerance; the final run is performed using\n#' the default susie tolerance.\n#'\n#' @param X An n by p matrix of covariates.\n#'\n#' @param y The observed responses, a vector of length n.\n#'\n#' @param L_init The initial value of L.\n#'\n#' @param L_max The largest value of L to consider.\n#'\n#' @param verbose If \\code{verbose = TRUE}, the algorithm's progress,\n#' and a summary of the optimization settings, are printed to the\n#' console.\n#'\n#' @param init_tol The tolerance to passed to \\code{susie} during\n#' early runs (set large to shorten the initial runs).\n#'\n#' @param standardize If \\code{standardize = TRUE}, standardize the\n#' columns of X to unit variance prior to fitting. Note that\n#' \\code{scaled_prior_variance} specifies the prior on the\n#' coefficients of X \\emph{after} standardization (if it is\n#' performed). If you do not standardize, you may need to think more\n#' carefully about specifying \\code{scaled_prior_variance}. Whatever\n#' your choice, the coefficients returned by \\code{coef} are given for\n#' \\code{X} on the original input scale. Any column of \\code{X} that\n#' has zero variance is not standardized.\n#'\n#' @param intercept If \\code{intercept = TRUE}, the intercept is\n#' fitted; it \\code{intercept = FALSE}, the intercept is set to\n#' zero. Setting \\code{intercept = FALSE} is generally not\n#' recommended.\n#'\n#' @param max_iter Maximum number of IBSS iterations to perform.\n#'\n#' @param tol A small, non-negative number specifying the convergence\n#' tolerance for the IBSS fitting procedure. The fitting procedure\n#' will halt when the difference in the variational lower bound, or\n#' \\dQuote{ELBO} (the objective function to be maximized), is\n#' less than \\code{tol}.\n#'\n#' @param \\dots Additional arguments passed to \\code{\\link{susie}}.\n#'\n#' @return See \\code{\\link{susie}} for a description of return values.\n#'\n#' @seealso \\code{\\link{susie}}\n#'\n#' @examples\n#' set.seed(1)\n#' n = 1000\n#' p = 1000\n#' beta = rep(0,p)\n#' beta[1:4] = 1\n#' X = matrix(rnorm(n*p),nrow = n,ncol = p)\n#' X = scale(X,center = TRUE,scale = TRUE)\n#' y = drop(X %*% beta + rnorm(n))\n#' res = susie_auto(X,y)\n#' plot(beta,coef(res)[-1])\n#' abline(a = 0,b = 1,col = \"skyblue\",lty = \"dashed\")\n#' plot(y,predict(res))\n#' abline(a = 0,b = 1,col = \"skyblue\",lty = \"dashed\")\n#'\n#' @importFrom stats sd\n#'\n#' @export\n#'\nsusie_auto = function (X, y, L_init = 1, L_max = 512, verbose = FALSE,\n init_tol = 1, standardize = TRUE, intercept = TRUE,\n max_iter = 100,tol = 1e-2, ...) {\n L = L_init\n if (verbose)\n message(paste0(\"Trying L=\",L))\n s.0 = susie(X,y,L = L,residual_variance = 0.01*sd(y)^2,tol = init_tol,\n scaled_prior_variance = 1,estimate_residual_variance = FALSE,\n estimate_prior_variance = FALSE,standardize = standardize,\n intercept = intercept,max_iter = max_iter,...)\n s.1 = susie(X,y,L = nrow(s.0$alpha),model_init = s.0,tol = init_tol,\n estimate_residual_variance = TRUE,\n estimate_prior_variance = FALSE,\n standardize = standardize,intercept = intercept,\n max_iter = max_iter,...)\n s.2 = susie(X,y,L = nrow(s.1$alpha),model_init = s.1,tol = init_tol,\n estimate_residual_variance = TRUE,\n estimate_prior_variance = TRUE,\n standardize = standardize,intercept = intercept,\n max_iter = max_iter,...)\n\n # We call it converged---i.e., L is \"big enough\"---if there are any\n # prior variances set to zero.\n converged = !all(s.2$V > 0)\n while (!converged & (L <= L_max)) {\n for (i in 1:L) {\n s.2 = add_null_effect(s.2,1) # Add in L more effects.\n s.2$sigma2 = 0.01*sd(y)^2 # Set residual variance to be small\n # again for next iteration.\n }\n L = 2*L\n if (verbose)\n message(paste0(\"Trying L=\",L))\n s.0 = susie(X,y,L = nrow(s.2$alpha),model_init = s.2,tol = init_tol,\n estimate_residual_variance = FALSE,\n estimate_prior_variance = FALSE,\n standardize = standardize,intercept = intercept,\n max_iter = max_iter,...)\n s.1 = susie(X,y,L = nrow(s.0$alpha),model_init = s.0,tol = init_tol,\n estimate_residual_variance = TRUE,\n estimate_prior_variance = FALSE,\n standardize = standardize,intercept = intercept,\n max_iter = max_iter,...)\n s.2 = susie(X,y,L = nrow(s.1$alpha),model_init = s.1,tol = init_tol,\n estimate_residual_variance = TRUE,\n estimate_prior_variance = TRUE,\n standardize = standardize,intercept = intercept,\n max_iter = max_iter,...)\n\n # We call it converged---i.e., L is \"big enough\"---if there are\n # any prior variances set to zero.\n converged = !all(s.2$V > 0)\n }\n\n # Final run at default tolerance to improve fit.\n s.2 = susie(X,y,L = nrow(s.2$alpha),model_init = s.2,estimate_residual_variance = TRUE,\n estimate_prior_variance = TRUE,tol = tol,\n standardize = standardize,intercept = intercept,\n max_iter = max_iter,...)\n return(s.2)\n}\n" }, { "path": "R/susie_constructors.R", "content": "# =============================================================================\n# INDIVIDUAL-LEVEL DATA CONSTRUCTOR\n#\n# Constructs data and params objects for SuSiE from individual-level data (X, y).\n# Handles data preprocessing, parameter validation, and object creation.\n# =============================================================================\n#'\n#' @return A list containing:\n#' \\item{data}{A processed list containing X and y matrices with appropriate scaling\n#' attributes and sample dimensions}\n#' \\item{params}{Validated params object with all input algorithm parameters}\n#'\n#' @keywords internal\n#' @importFrom stats var\n#' @noRd\nindividual_data_constructor <- function(X, y, L = min(10, ncol(X)),\n scaled_prior_variance = 0.2,\n residual_variance = NULL,\n prior_weights = NULL,\n null_weight = 0,\n standardize = TRUE,\n intercept = TRUE,\n estimate_residual_variance = TRUE,\n estimate_residual_method = \"MoM\",\n estimate_prior_variance = TRUE,\n estimate_prior_method = \"optim\",\n prior_variance_grid = NULL,\n mixture_weights = NULL,\n unmappable_effects = \"none\",\n check_null_threshold = 0,\n prior_tol = 1e-9,\n residual_variance_upperbound = Inf,\n model_init = NULL,\n s_init = NULL,\n coverage = 0.95,\n min_abs_corr = 0.5,\n compute_univariate_zscore = FALSE,\n na.rm = FALSE,\n max_iter = 100,\n tol = 1e-3,\n convergence_method = \"elbo\",\n verbose = FALSE,\n track_fit = FALSE,\n residual_variance_lowerbound = NULL,\n refine = FALSE,\n n_purity = 100,\n alpha0 = 0,\n beta0 = 0,\n slot_prior = NULL,\n L_greedy = NULL,\n greedy_lbf_cutoff = 0.1) {\n\n # Handle deprecated s_init argument\n if (!is.null(s_init)) {\n if (!is.null(model_init))\n stop(\"Cannot specify both 's_init' and 'model_init'.\")\n warning_message(\"s_init is deprecated and will be removed in a future \",\n \"version of susieR. Please use model_init instead.\")\n model_init <- s_init\n }\n\n # Validate input X\n if (!(is.double(X) & is.matrix(X)) &\n !inherits(X, \"sparseMatrix\") &\n is.null(attr(X, \"matrix.type\"))) {\n stop(\"Input X must be a double-precision matrix, or a sparse matrix, or \",\n \"a trend filtering matrix.\")\n }\n\n if (anyNA(X)) {\n stop(\"X contains NA values.\")\n }\n\n # Constant column check for regular matrix\n if (is.null(attr(X, \"matrix.type\")) || attr(X, \"matrix.type\") != \"tfmatrix\") {\n col_vars <- apply(X, 2, var)\n const_cols <- which(col_vars == 0 | is.na(col_vars))\n if (length(const_cols) > 0) {\n warning_message(sprintf(\"X contains %d constant columns (first few cols: %s).\",\n length(const_cols), paste(head(const_cols, 10), collapse = \", \")))\n }\n }\n\n # Handle missing values in y\n if (anyNA(y)) {\n if (na.rm) {\n samples_kept <- which(!is.na(y))\n y <- y[samples_kept]\n X <- X[samples_kept, , drop = FALSE]\n } else {\n stop(\"Input y must not contain missing values.\")\n }\n }\n\n # Set residual_variance_lowerbound\n if (is.null(residual_variance_lowerbound)) {\n residual_variance_lowerbound <- var(drop(y)) / 1e4\n }\n\n mean_y <- mean(y)\n\n # Force required preprocessing for unmappable effects methods\n if (unmappable_effects != \"none\") {\n if (!intercept) {\n warning_message(\"Unmappable effects methods require centered data. Setting intercept=TRUE.\")\n intercept <- TRUE\n }\n if (!standardize) {\n warning_message(\"Unmappable effects methods require scaled data. Setting standardize=TRUE.\")\n standardize <- TRUE\n }\n }\n\n # Check for incompatible parameter combination\n if (unmappable_effects != \"none\" &&\n estimate_residual_method == \"NIG\") {\n stop(\"The combination of unmappable_effects = '\", unmappable_effects,\n \"' with estimate_residual_method = 'NIG' is not supported. \",\n \"Please use estimate_residual_method = 'MoM' or 'MLE' instead.\")\n }\n\n # Check for incompatible parameter combination\n if (unmappable_effects %in% c(\"ash\", \"ash_filter_archived\") && estimate_prior_method == \"EM\") {\n stop(\"The combination of unmappable_effects = 'ash' with \",\n \"estimate_prior_method = 'EM' is not supported. \",\n \"Please use estimate_prior_method = 'optim' instead.\")\n }\n\n # Handle null weights\n if (is.numeric(null_weight) && null_weight == 0) {\n null_weight <- NULL\n }\n\n if (!is.null(null_weight)) {\n if (!is.numeric(null_weight)) {\n stop(\"Null weight must be numeric.\")\n }\n if (null_weight < 0 || null_weight >= 1) {\n stop(\"Null weight must be between 0 and 1.\")\n }\n\n if (is.null(prior_weights)) {\n prior_weights <- c(rep(1 / ncol(X) * (1 - null_weight), ncol(X)), null_weight)\n } else {\n prior_weights <- c(prior_weights * (1 - null_weight), null_weight)\n }\n\n # add the extra 0 column to X\n X <- cbind(X, 0)\n }\n\n # Store dimensions\n n <- nrow(X)\n p <- ncol(X)\n\n # Set uniform prior weights if not provided\n if (is.null(prior_weights)) {\n prior_weights <- rep(1 / p, p)\n }\n\n # Validate and normalize prior_weights\n if (length(prior_weights) != p) {\n stop(\"Prior weights must have length p.\")\n }\n if (all(prior_weights == 0)) {\n stop(\"Prior weight should be greater than 0 for at least one variable.\")\n }\n prior_weights <- prior_weights / sum(prior_weights)\n\n # nocov start\n if (p > 1000 & !requireNamespace(\"Rfast\", quietly = TRUE)) {\n warning_message(\"For an X with many columns, please consider installing \",\n \"the Rfast package for more efficient credible set (CS) \",\n \"calculations.\",\n style = \"hint\")\n }\n # nocov end\n\n # Center y if intercept is included\n if (intercept) {\n y <- y - mean_y\n }\n\n # Compute and set X matrix attributes\n out <- compute_colstats(X, center = intercept, scale = standardize)\n attr(X, \"scaled:center\") <- out$cm\n attr(X, \"scaled:scale\") <- out$csd\n attr(X, \"d\") <- out$d\n\n # Create params object with all input parameters\n params_object <- list(\n L = L,\n scaled_prior_variance = scaled_prior_variance,\n residual_variance = residual_variance,\n prior_weights = prior_weights,\n null_weight = null_weight,\n estimate_residual_variance = estimate_residual_variance,\n estimate_residual_method = estimate_residual_method,\n estimate_prior_variance = estimate_prior_variance,\n estimate_prior_method = estimate_prior_method,\n prior_variance_grid = prior_variance_grid,\n mixture_weights = mixture_weights,\n unmappable_effects = unmappable_effects,\n check_null_threshold = check_null_threshold,\n prior_tol = prior_tol,\n residual_variance_upperbound = residual_variance_upperbound,\n model_init = model_init,\n coverage = coverage,\n min_abs_corr = min_abs_corr,\n compute_univariate_zscore = compute_univariate_zscore,\n max_iter = max_iter,\n tol = tol,\n convergence_method = convergence_method,\n verbose = verbose,\n track_fit = track_fit,\n residual_variance_lowerbound = residual_variance_lowerbound,\n refine = refine,\n n_purity = n_purity,\n alpha0 = alpha0,\n beta0 = beta0,\n n = n,\n use_NIG = FALSE, # Will be set by validation function\n intercept = intercept,\n standardize = standardize,\n slot_prior = slot_prior,\n L_greedy = L_greedy,\n greedy_lbf_cutoff = greedy_lbf_cutoff\n )\n\n # Validate and apply parameter overrides\n params_object <- validate_and_override_params(params_object)\n data_object <- structure(\n list(\n X = X,\n y = y,\n mean_y = mean_y,\n n = n,\n p = p\n ),\n class = \"individual\"\n )\n\n # Configure data object based on params\n data_object <- configure_data(data_object, params_object)\n\n return(list(data = data_object, params = params_object))\n}\n\n# =============================================================================\n# SUFFICIENT STATISTICS DATA CONSTRUCTOR\n#\n# Constructs data and params objects for SuSiE from sufficient statistics (XtX, Xty, yty).\n# Handles data preprocessing, parameter validation, and object creation.\n# =============================================================================\n#'\n#' @return A list containing:\n#' \\item{data}{A processed list containing XtX, Xty, yty matrices with appropriate scaling\n#' attributes and sample dimensions}\n#' \\item{params}{Validated params object with all input algorithm parameters}\n#'\n#' @keywords internal\n#' @noRd\nsufficient_stats_constructor <- function(Xty, yty, n,\n XtX = NULL, X = NULL,\n L = min(10, if (!is.null(XtX)) ncol(XtX) else ncol(X)),\n X_colmeans = NA, y_mean = NA,\n maf = NULL, maf_thresh = 0,\n check_input = FALSE,\n r_tol = 1e-8,\n standardize = TRUE,\n scaled_prior_variance = 0.2,\n residual_variance = NULL,\n prior_weights = NULL,\n null_weight = 0,\n model_init = NULL,\n s_init = NULL,\n estimate_residual_variance = TRUE,\n estimate_residual_method = \"MoM\",\n residual_variance_lowerbound = 0,\n residual_variance_upperbound = Inf,\n estimate_prior_variance = TRUE,\n estimate_prior_method = \"optim\",\n prior_variance_grid = NULL,\n mixture_weights = NULL,\n unmappable_effects = \"none\",\n check_null_threshold = 0,\n prior_tol = 1e-9,\n max_iter = 100,\n tol = 1e-3,\n convergence_method = \"elbo\",\n coverage = 0.95,\n min_abs_corr = 0.5,\n n_purity = 100,\n verbose = FALSE,\n track_fit = FALSE,\n check_prior = FALSE,\n refine = FALSE,\n alpha0 = 0.1,\n beta0 = 0.1,\n slot_prior = NULL,\n L_greedy = NULL,\n greedy_lbf_cutoff = 0.1) {\n\n # Handle deprecated s_init argument\n if (!is.null(s_init)) {\n if (!is.null(model_init))\n stop(\"Cannot specify both 's_init' and 'model_init'.\")\n warning_message(\"s_init is deprecated and will be removed in a future \",\n \"version of susieR. Please use model_init instead.\")\n model_init <- s_init\n }\n\n # Validate required inputs\n if (missing(n)) {\n stop(\"n must be provided.\")\n }\n if (n <= 1) {\n stop(\"n must be greater than 1.\")\n }\n\n if (is.null(X)) {\n # XtX path: validate XtX\n if (is.null(XtX) || missing(Xty) || missing(yty)) {\n stop(\"XtX, Xty, yty must all be provided.\")\n }\n\n if (!(is.double(XtX) && is.matrix(XtX)) &&\n !inherits(XtX, \"sparseMatrix\")) {\n stop(\"XtX must be a numeric dense or sparse matrix.\")\n }\n\n if (ncol(XtX) != length(Xty)) {\n stop(paste0(\n \"The dimension of XtX (\", nrow(XtX), \" by \", ncol(XtX),\n \") does not agree with expected (\", length(Xty), \" by \",\n length(Xty), \").\"\n ))\n }\n\n # nocov start\n if (ncol(XtX) > 1000 & !requireNamespace(\"Rfast\", quietly = TRUE)) {\n warning_message(\"For large R or large XtX, consider installing the \",\n \"Rfast package for better performance.\",\n style = \"hint\")\n }\n # nocov end\n\n # Ensure XtX is symmetric\n if (!is_symmetric_matrix(XtX)) {\n warning_message(\"XtX not symmetric; using (XtX + t(XtX))/2.\")\n XtX <- (XtX + t(XtX)) / 2\n }\n\n # Apply MAF filter if provided\n if (!is.null(maf)) {\n if (length(maf) != length(Xty)) {\n stop(paste(\"The length of maf does not agree with expected\", length(Xty), \".\"))\n }\n id <- which(maf > maf_thresh)\n XtX <- XtX[id, id]\n Xty <- Xty[id]\n }\n\n # Additional validation\n if (anyNA(XtX)) {\n stop(\"Input XtX matrix contains NAs.\")\n }\n\n # Positive-semidefinite check\n if (check_input) {\n semi_pd <- check_semi_pd(XtX, r_tol)\n if (!semi_pd$status) {\n stop(\"XtX is not a positive semidefinite matrix.\")\n }\n\n # Check whether Xty lies in space spanned by non-zero eigenvectors of XtX\n proj <- check_projection(semi_pd$matrix, Xty)\n if (!proj$status) {\n warning_message(\"Xty does not lie in the space of the non-zero eigenvectors \",\n \"of XtX.\")\n }\n }\n } else {\n # X low-rank path: validate X\n if (ncol(X) != length(Xty)) {\n stop(paste0(\n \"The number of columns of X (\", ncol(X),\n \") does not agree with the length of Xty (\", length(Xty), \").\"\n ))\n }\n }\n\n # Common validation for Xty\n if (any(is.infinite(Xty))) {\n stop(\"Input Xty contains infinite values.\")\n }\n if (anyNA(Xty)) {\n warning_message(\"NA values in Xty are replaced with 0.\")\n Xty[is.na(Xty)] <- 0\n }\n\n # Define p before null_weight handling\n p <- if (!is.null(XtX)) ncol(XtX) else ncol(X)\n\n # Handle null weights\n if (is.numeric(null_weight) && null_weight == 0) {\n null_weight <- NULL\n }\n\n if (!is.null(null_weight)) {\n if (!is.numeric(null_weight)) {\n stop(\"Null weight must be numeric.\")\n }\n if (null_weight < 0 || null_weight >= 1) {\n stop(\"Null weight must be between 0 and 1.\")\n }\n if (is.null(prior_weights)) {\n prior_weights <- c(rep(1 / p * (1 - null_weight), p), null_weight)\n } else {\n prior_weights <- c(prior_weights * (1 - null_weight), null_weight)\n }\n if (!is.null(XtX)) {\n XtX <- cbind(rbind(XtX, 0), 0)\n }\n if (!is.null(X)) {\n X <- cbind(X, 0)\n }\n Xty <- c(Xty, 0)\n if (length(X_colmeans) == 1) {\n X_colmeans <- rep(X_colmeans, p)\n }\n if (length(X_colmeans) != p) {\n stop(\"The length of X_colmeans does not agree with number of variables.\")\n }\n # Add 0 for null column\n X_colmeans <- c(X_colmeans, 0)\n # Update p after adding null column\n p <- p + 1\n }\n\n # Set uniform prior weights if not provided\n if (is.null(prior_weights)) {\n prior_weights <- rep(1 / p, p)\n }\n\n # Validate and normalize prior_weights\n if (length(prior_weights) != p) {\n stop(\"Prior weights must have length p.\")\n }\n if (all(prior_weights == 0)) {\n stop(\"Prior weight should be greater than 0 for at least one variable.\")\n }\n prior_weights <- prior_weights / sum(prior_weights)\n\n # Standardize if requested\n if (!is.null(X)) {\n # Low-rank X path: standardize columns of X\n if (standardize) {\n dXtX <- colSums(X^2)\n csd <- sqrt(dXtX / (n - 1))\n csd[csd == 0] <- 1\n X <- t(t(X) / csd)\n Xty <- Xty / csd\n } else {\n csd <- rep(1, length = p)\n }\n attr(X, \"d\") <- colSums(X^2)\n attr(X, \"scaled:scale\") <- csd\n colnames(X) <- names(Xty)\n } else {\n # XtX path: standardize XtX\n if (standardize) {\n dXtX <- diag(XtX)\n csd <- sqrt(dXtX / (n - 1))\n csd[csd == 0] <- 1\n XtX <- t((1 / csd) * XtX) / csd\n Xty <- Xty / csd\n } else {\n csd <- rep(1, length = p)\n }\n attr(XtX, \"d\") <- diag(XtX)\n attr(XtX, \"scaled:scale\") <- csd\n }\n\n if (length(X_colmeans) == 1) {\n X_colmeans <- rep(X_colmeans, p)\n }\n if (length(X_colmeans) != p) {\n stop(\n \"`X_colmeans` length (\", length(X_colmeans),\n \") does not match number of variables (\", p, \").\"\n )\n }\n\n # Create params object with all input parameters\n params_object <- list(\n L = L,\n scaled_prior_variance = scaled_prior_variance,\n residual_variance = residual_variance,\n prior_weights = prior_weights,\n null_weight = null_weight,\n estimate_residual_variance = estimate_residual_variance,\n estimate_residual_method = estimate_residual_method,\n estimate_prior_variance = estimate_prior_variance,\n estimate_prior_method = estimate_prior_method,\n prior_variance_grid = prior_variance_grid,\n mixture_weights = mixture_weights,\n unmappable_effects = unmappable_effects,\n check_null_threshold = check_null_threshold,\n prior_tol = prior_tol,\n residual_variance_upperbound = residual_variance_upperbound,\n model_init = model_init,\n coverage = coverage,\n min_abs_corr = min_abs_corr,\n compute_univariate_zscore = FALSE, # SS doesn't support univariate zscore\n max_iter = max_iter,\n tol = tol,\n convergence_method = convergence_method,\n verbose = verbose,\n track_fit = track_fit,\n residual_variance_lowerbound = residual_variance_lowerbound,\n refine = refine,\n n_purity = n_purity,\n alpha0 = alpha0,\n beta0 = beta0,\n n = n,\n use_NIG = FALSE,\n intercept = FALSE, # SS always uses intercept = FALSE\n standardize = standardize,\n check_prior = check_prior,\n slot_prior = slot_prior,\n L_greedy = L_greedy,\n greedy_lbf_cutoff = greedy_lbf_cutoff\n )\n\n # Validate and apply parameter overrides\n params_object <- validate_and_override_params(params_object)\n\n # Assemble data object\n data_object <- structure(\n list(\n XtX = XtX,\n X = X,\n Xty = Xty,\n yty = yty,\n n = n,\n p = p,\n X_colmeans = X_colmeans,\n y_mean = y_mean\n ),\n class = \"ss\"\n )\n\n # Configure data object based on params\n data_object <- configure_data(data_object, params_object)\n\n return(list(data = data_object, params = params_object))\n}\n\n# =============================================================================\n# SUMMARY STATISTICS (RSS) DATA CONSTRUCTOR\n#\n# Constructs data and params objects for SuSiE from summary statistics\n# (z-scores, R matrix, or multi-panel R/X reference).\n# =============================================================================\n#'\n#' @return A list containing:\n#' \\item{data}{A processed list containing converted matrices with appropriate scaling\n#' attributes and sample dimensions}\n#' \\item{params}{Validated params object with all input algorithm parameters}\n#'\n#' @keywords internal\n#' @noRd\nsummary_stats_constructor <- function(z = NULL, R = NULL, X = NULL,\n n = NULL, bhat = NULL,\n shat = NULL, var_y = NULL,\n L = min(10, if (!is.null(R)) ncol(R) else ncol(X)),\n lambda = 0,\n maf = NULL,\n maf_thresh = 0,\n prior_variance = 50,\n scaled_prior_variance = 0.2,\n residual_variance = NULL,\n prior_weights = NULL,\n null_weight = 0,\n standardize = TRUE,\n intercept_value = 0,\n estimate_residual_variance = FALSE,\n estimate_residual_method = \"MoM\",\n estimate_prior_variance = TRUE,\n estimate_prior_method = \"optim\",\n prior_variance_grid = NULL,\n mixture_weights = NULL,\n unmappable_effects = \"none\",\n check_null_threshold = 0,\n prior_tol = 1e-9,\n residual_variance_lowerbound = 0,\n residual_variance_upperbound = Inf,\n model_init = NULL,\n s_init = NULL,\n coverage = 0.95,\n min_abs_corr = 0.5,\n max_iter = 100,\n tol = 1e-3,\n convergence_method = \"elbo\",\n verbose = FALSE,\n track_fit = FALSE,\n check_input = FALSE,\n check_prior = TRUE,\n n_purity = 100,\n r_tol = 1e-8,\n refine = FALSE,\n R_finite = NULL,\n R_mismatch = \"none\",\n eig_delta_rel = 1e-3,\n eig_delta_abs = 0,\n artifact_threshold = 0.1,\n alpha0 = 0.1,\n beta0 = 0.1,\n slot_prior = NULL,\n L_greedy = NULL,\n greedy_lbf_cutoff = 0.1) {\n\n # Handle deprecated s_init argument\n if (!is.null(s_init)) {\n if (!is.null(model_init))\n stop(\"Cannot specify both 's_init' and 'model_init'.\")\n warning_message(\"s_init is deprecated and will be removed in a future \",\n \"version of susieR. Please use model_init instead.\")\n model_init <- s_init\n }\n\n # NIG prior requires an explicit sample size n: the default alpha0/beta0\n # scale as 1/sqrt(n) and the NIG marginal likelihood depends on n. Without\n # n, summary_stats_constructor bumps n to 2 internally (see below), which\n # would silently corrupt the NIG posterior. Reject early with a clear error.\n if (estimate_residual_method == \"NIG\" &&\n (is.null(n) || !is.numeric(n) || length(n) != 1 ||\n !is.finite(n) || n < 1)) {\n stop(\"estimate_residual_method = \\\"NIG\\\" requires a valid sample \",\n \"size `n` (got n = \", paste(n, collapse = \"\"), \"). \",\n \"For susie_rss(), pass `n` explicitly.\")\n }\n\n # PVE-adjusted z-scores: shrink large z toward zero to account for\n # winner's curse. Applied to ALL paths when sample size is available.\n # Guard: z may be NULL when bhat/shat are provided (converted later).\n pve_adjusted <- FALSE\n if (!is.null(z) && !is.null(n) && n > 1) {\n adj <- (n - 1) / (z^2 + n - 2)\n z <- sqrt(adj) * z\n pve_adjusted <- TRUE\n }\n\n is_multipanel <- (is.list(X) && !is.matrix(X)) ||\n (is.list(R) && !is.matrix(R))\n R_mismatch <- match.arg(R_mismatch, c(\"none\", \"map\", \"map_qc\"))\n if (isTRUE(R_finite) && is.null(X))\n stop(\"R_finite = TRUE requires X input. When using precomputed R, \",\n \"provide the reference sample size explicitly.\")\n R_finite <- resolve_R_finite(R_finite, if (!is.null(X)) X else R,\n is_multipanel)\n if (is_multipanel) {\n if (lambda != 0)\n stop(\"Multi-panel mixture is available only on the sufficient-statistics path.\")\n if (!is.null(bhat) || !is.null(shat)) {\n stop(\"Parameters 'bhat' and 'shat' are not supported in the \",\n \"multi-panel summary-statistics path. \",\n \"Please provide z-scores directly.\")\n }\n if (!is.null(var_y))\n stop(\"Parameter 'var_y' is not supported in the multi-panel path.\")\n return(ss_mixture_constructor(\n z = z, R = R, X = X, n = n, L = L,\n maf = maf, maf_thresh = maf_thresh,\n scaled_prior_variance = scaled_prior_variance,\n residual_variance = residual_variance,\n prior_weights = prior_weights, null_weight = null_weight,\n standardize = standardize,\n estimate_residual_variance = estimate_residual_variance,\n estimate_residual_method = estimate_residual_method,\n estimate_prior_variance = estimate_prior_variance,\n estimate_prior_method = estimate_prior_method,\n prior_variance_grid = prior_variance_grid,\n mixture_weights = mixture_weights,\n unmappable_effects = unmappable_effects,\n check_null_threshold = check_null_threshold, prior_tol = prior_tol,\n residual_variance_lowerbound = residual_variance_lowerbound,\n residual_variance_upperbound = residual_variance_upperbound,\n model_init = model_init, coverage = coverage,\n min_abs_corr = min_abs_corr, max_iter = max_iter, tol = tol,\n convergence_method = convergence_method, verbose = verbose,\n track_fit = track_fit, check_input = check_input,\n check_prior = check_prior, n_purity = n_purity,\n r_tol = r_tol, refine = refine, R_finite = R_finite,\n R_mismatch = R_mismatch, eig_delta_rel = eig_delta_rel,\n eig_delta_abs = eig_delta_abs, artifact_threshold = artifact_threshold,\n alpha0 = alpha0, beta0 = beta0, slot_prior = slot_prior,\n L_greedy = L_greedy, greedy_lbf_cutoff = greedy_lbf_cutoff\n ))\n }\n\n if (lambda != 0) {\n if (!is.null(R_finite))\n stop(\"R_finite is not available in the RSS-lambda path.\")\n if (R_mismatch != \"none\")\n stop(\"R_mismatch is not available in the RSS-lambda path.\")\n if (!is.null(bhat) || !is.null(shat)) {\n stop(\"Parameters 'bhat' and 'shat' are not supported in the \",\n \"RSS-lambda path.\")\n }\n if (!is.null(var_y))\n stop(\"Parameter 'var_y' is not supported in the RSS-lambda path.\")\n return(rss_lambda_constructor(\n z = z, R = R, X = X, n = n,\n L = L, lambda = lambda, maf = maf, maf_thresh = maf_thresh,\n prior_variance = prior_variance,\n residual_variance = residual_variance, prior_weights = prior_weights,\n null_weight = null_weight, intercept_value = intercept_value,\n estimate_residual_variance = estimate_residual_variance,\n estimate_residual_method = estimate_residual_method,\n estimate_prior_variance = estimate_prior_variance,\n estimate_prior_method = estimate_prior_method,\n prior_variance_grid = prior_variance_grid,\n mixture_weights = mixture_weights,\n check_null_threshold = check_null_threshold, prior_tol = prior_tol,\n residual_variance_lowerbound = residual_variance_lowerbound,\n model_init = model_init, coverage = coverage, min_abs_corr = min_abs_corr,\n max_iter = max_iter, tol = tol, convergence_method = convergence_method,\n verbose = verbose, track_fit = track_fit,\n check_prior = check_prior, check_R = TRUE, check_z = FALSE,\n n_purity = n_purity, r_tol = r_tol, refine = refine,\n slot_prior = slot_prior, L_greedy = L_greedy,\n greedy_lbf_cutoff = greedy_lbf_cutoff\n ))\n }\n\n # Parameter validation for standard RSS (lambda = 0)\n if (intercept_value != 0) {\n stop(\"Parameter 'intercept_value' is only supported in the \",\n \"eigendecomposition path (lambda != 0 or multi-panel).\")\n }\n\n # Issue warning for estimate_residual_variance if TRUE\n if (estimate_residual_variance && lambda == 0) {\n warning_message(\"For estimate_residual_variance = TRUE, please check \",\n \"that R is the \\\"in-sample\\\" R matrix; that is, the \",\n \"correlation matrix obtained using the exact same data \",\n \"matrix X that was used for the other summary \",\n \"statistics. Also note, when covariates are included in \",\n \"the univariate regressions that produced the summary \",\n \"statistics, also consider removing these effects from \",\n \"X before computing R.\")\n }\n\n\n # For SuSiE-ash with summary statistics, recommend providing bhat/shat/var_y\n # for best agreement with individual-level analysis. The z+R-only path\n # operates on a standardized scale (var_y=1) and may give different results.\n if (unmappable_effects %in% c(\"ash\", \"ash_filter_archived\") && is.null(bhat) && is.null(var_y)) {\n warning_message(\"SuSiE-ash with z-scores and R only operates on a \",\n \"standardized scale. For best agreement with \",\n \"individual-level analysis, provide bhat, shat, and \",\n \"var_y instead of z-scores.\")\n }\n\n # Determine p from z or bhat\n if (is.null(z) && !is.null(bhat)) {\n p <- length(bhat)\n } else if (!is.null(z)) {\n p <- length(z)\n } else {\n stop(\"Please provide either z or (bhat, shat).\")\n }\n\n # Check dimensions of R or X\n if (!is.null(R)) {\n if (nrow(R) != p) {\n stop(paste0(\n \"The dimension of R (\", nrow(R), \" x \", ncol(R), \") does not \",\n \"agree with expected (\", p, \" x \", p, \").\"\n ))\n }\n } else if (!is.null(X)) {\n if (ncol(X) != p) {\n stop(paste0(\n \"The number of columns of X (\", ncol(X), \") does not \",\n \"agree with expected (\", p, \").\"\n ))\n }\n }\n\n # Check input n\n if (!is.null(n)) {\n if (n <= 1) {\n stop(\"n must be greater than 1.\")\n }\n }\n\n # Check inputs z, bhat and shat\n if (sum(c(is.null(z), is.null(bhat) || is.null(shat))) != 1) {\n stop(\"Please provide either z or (bhat, shat), but not both.\")\n }\n if (is.null(z)) {\n if (length(shat) == 1) {\n shat <- rep(shat, length(bhat))\n }\n if (length(bhat) != length(shat)) {\n stop(\"The lengths of bhat and shat do not agree.\")\n }\n if (anyNA(bhat) || anyNA(shat)) {\n stop(\"bhat, shat cannot have missing values.\")\n }\n if (any(shat <= 0)) {\n stop(\"shat cannot have zero or negative elements.\")\n }\n z <- bhat / shat\n }\n if (length(z) < 1) {\n stop(\"Input vector z should have at least one element.\")\n }\n z[is.na(z)] <- 0\n\n # Apply PVE adjustment if not already done (when z was computed from bhat/shat)\n if (!pve_adjusted && !is.null(n) && n > 1) {\n adj <- (n - 1) / (z^2 + n - 2)\n z <- sqrt(adj) * z\n pve_adjusted <- TRUE\n }\n\n # MAF filter (after z-scores are computed)\n if (!is.null(maf)) {\n if (length(maf) != length(z)) {\n stop(paste0(\"The length of maf does not agree with expected \", length(z)))\n }\n id <- which(maf > maf_thresh)\n if (!is.null(R)) R <- R[id, id]\n if (!is.null(X)) X <- X[, id, drop = FALSE]\n z <- z[id]\n # Update p after filtering\n p <- length(z)\n }\n\n # Standardize X so X'X = R (correlation matrix). The model assumes\n # column-standardized X; without this, X'X/B gives sample covariance\n # which != correlation when columns have different variances.\n if (!is.null(X)) {\n X <- standardize_X(X)\n }\n\n R_mismatch <- match.arg(R_mismatch, c(\"none\", \"map\", \"map_qc\"))\n if (R_mismatch != \"none\" && is.null(R_finite))\n stop(\"R_mismatch requires R_finite because lambda_bias is estimated \",\n \"as extra R bias beyond finite-reference uncertainty.\")\n\n # R diagnostics (static, computed once at initialization).\n # X is standardized (X'X = R) at this point.\n R_finite_diagnostics <- NULL\n if (!is.null(R_finite)) {\n R_finite_diagnostics <- compute_R_finite_diagnostics(\n X = X, R = R, B = R_finite, p = length(z),\n x_is_standardized = TRUE)\n }\n\n # Cache eigen(R) for the Q_art QC diagnostic. Only computed when the\n # user opts into map_qc; the standard \"map\" path does not pay the\n # O(p^3) eigen cost. Works for both R-input and X-input: after\n # standardize_X, crossprod(X) == R. Reuses the attr(R, \"eigen\")\n # convention when the caller pre-computed it.\n eigen_R_cache <- NULL\n if (R_mismatch == \"map_qc\") {\n eigen_R_cache <- if (!is.null(R)) attr(R, \"eigen\") else NULL\n if (is.null(eigen_R_cache)) {\n R_for_eigen <- if (!is.null(R)) R else crossprod(X)\n eigen_R_cache <- eigen(R_for_eigen, symmetric = TRUE)\n }\n }\n\n # Convert to sufficient statistics format\n XtX <- NULL\n if (is.null(n)) {\n # Sample size not provided - use unadjusted z-scores\n warning_message(\"Providing the sample size (n), or even a rough estimate of n, \",\n \"is highly recommended. Without n, the implicit assumption is \",\n \"n is large (Inf) and the effect sizes are small (close to zero).\")\n if (!is.null(R)) {\n XtX <- R\n }\n # X path: X'X = R already after standardize_X, no further scaling needed.\n Xty <- z\n yty <- 1\n n <- 2\n scaled_prior_variance <- prior_variance\n } else {\n # Sample size provided - use PVE-adjusted z-scores\n if (!is.null(shat) && !is.null(var_y)) {\n # var_y and shat provided - effects on original scale (R path only)\n XtXdiag <- var_y * adj / (shat^2)\n XtX <- t(R * sqrt(XtXdiag)) * sqrt(XtXdiag)\n XtX <- (XtX + t(XtX)) / 2\n Xty <- z * sqrt(adj) * var_y / shat\n yty <- (n - 1) * var_y\n } else {\n # Effects on standardized X, y scale\n if (!is.null(R)) {\n XtX <- (n - 1) * R\n } else {\n # X path: X'X = R after standardize_X, scale to X'X = (n-1)*R\n X <- X * sqrt(n - 1)\n }\n Xty <- sqrt(n - 1) * z\n yty <- (n - 1) * (if (!is.null(var_y)) var_y else 1)\n }\n }\n\n # Use sufficient_stats_constructor with ALL parameters\n result <- sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = n, XtX = XtX, X = X,\n L = L, X_colmeans = NA, y_mean = NA,\n maf = NULL, maf_thresh = 0, check_input = check_input,\n r_tol = r_tol, standardize = standardize,\n scaled_prior_variance = scaled_prior_variance,\n residual_variance = residual_variance, prior_weights = prior_weights,\n null_weight = null_weight, model_init = model_init,\n estimate_residual_variance = estimate_residual_variance,\n estimate_residual_method = estimate_residual_method,\n residual_variance_lowerbound = residual_variance_lowerbound,\n residual_variance_upperbound = residual_variance_upperbound,\n estimate_prior_variance = estimate_prior_variance,\n estimate_prior_method = estimate_prior_method,\n prior_variance_grid = prior_variance_grid,\n mixture_weights = mixture_weights,\n unmappable_effects = unmappable_effects,\n check_null_threshold = check_null_threshold, prior_tol = prior_tol,\n max_iter = max_iter, tol = tol, convergence_method = convergence_method,\n coverage = coverage, min_abs_corr = min_abs_corr, n_purity = n_purity,\n verbose = verbose, track_fit = track_fit, check_prior = check_prior,\n refine = refine, alpha0 = alpha0, beta0 = beta0,\n slot_prior = slot_prior, L_greedy = L_greedy,\n greedy_lbf_cutoff = greedy_lbf_cutoff\n )\n\n # Attach finite-reference R metadata to data object.\n if (!is.null(R_finite)) {\n result$data$R_finite_B <- R_finite\n result$data$R_finite_diagnostics <- R_finite_diagnostics\n result$data$R_mismatch <- R_mismatch\n }\n\n # eigen(R) cache for Q_art diagnostic (map_qc only).\n if (!is.null(eigen_R_cache))\n result$data$eigen_R <- eigen_R_cache\n\n # Attach R-bias / mismatch params consumed by R/rss_mismatch.R.\n result$params$R_mismatch <- R_mismatch\n result$params$eig_delta_rel <- eig_delta_rel\n result$params$eig_delta_abs <- eig_delta_abs\n result$params$artifact_threshold <- artifact_threshold\n\n return(result)\n}\n\n# =============================================================================\n# SS MULTI-PANEL MIXTURE DATA CONSTRUCTOR\n# =============================================================================\n#'\n#' @keywords internal\n#' @noRd\nss_mixture_constructor <- function(z, R = NULL, X = NULL, n,\n L = min(10, if (!is.null(R)) ncol(R[[1]])\n else ncol(X[[1]])),\n maf = NULL, maf_thresh = 0,\n scaled_prior_variance = 0.2,\n residual_variance = NULL,\n prior_weights = NULL,\n null_weight = 0,\n standardize = TRUE,\n estimate_residual_variance = FALSE,\n estimate_residual_method = \"MoM\",\n estimate_prior_variance = TRUE,\n estimate_prior_method = \"optim\",\n prior_variance_grid = NULL,\n mixture_weights = NULL,\n unmappable_effects = \"none\",\n check_null_threshold = 0,\n prior_tol = 1e-9,\n residual_variance_lowerbound = 0,\n residual_variance_upperbound = Inf,\n model_init = NULL,\n coverage = 0.95,\n min_abs_corr = 0.5,\n max_iter = 100,\n tol = 1e-3,\n convergence_method = \"pip\",\n verbose = FALSE,\n track_fit = FALSE,\n check_input = FALSE,\n check_prior = TRUE,\n n_purity = 100,\n r_tol = 1e-8,\n refine = FALSE,\n R_finite = NULL,\n R_mismatch = \"none\",\n eig_delta_rel = 1e-3,\n eig_delta_abs = 0,\n artifact_threshold = 0.1,\n alpha0 = 0.1,\n beta0 = 0.1,\n slot_prior = NULL,\n L_greedy = NULL,\n greedy_lbf_cutoff = 0.1) {\n if (is.null(n) || !is.numeric(n) || length(n) != 1 || n <= 1)\n stop(\"Sample size 'n' is required for multi-panel mode.\")\n if (is.null(z))\n stop(\"Multi-panel mode requires z-scores.\")\n if (!is.null(R) && !is.null(X))\n stop(\"Please provide either R or X, but not both.\")\n\n use_R <- !is.null(R)\n panels <- if (use_R) R else X\n K <- length(panels)\n if (K < 1)\n stop(\"Multi-panel input must contain at least one panel.\")\n p <- length(z)\n\n if (use_R) {\n for (k in seq_len(K)) {\n if (!is.matrix(R[[k]]) || !is.numeric(R[[k]]))\n stop(\"Each element of R list must be a numeric matrix.\")\n if (nrow(R[[k]]) != p || ncol(R[[k]]) != p)\n stop(\"Each element of R list must have dimension length(z) by length(z).\")\n if (!is_symmetric_matrix(R[[k]]))\n R[[k]] <- (R[[k]] + t(R[[k]])) / 2\n }\n panel_R <- lapply(R, safe_cov2cor)\n X_list <- NULL\n B_list <- R_finite\n init_panel <- attr(R, \".init_panel\")\n omega_cache <- NULL\n } else {\n for (k in seq_len(K)) {\n if (!is.matrix(X[[k]]) || !is.numeric(X[[k]]))\n stop(\"Each element of X list must be a numeric matrix.\")\n if (ncol(X[[k]]) != p)\n stop(\"Each element of X list must have length(z) columns.\")\n }\n X_list <- lapply(X, standardize_X)\n panel_R <- lapply(X_list, function(Xk) cov2cor(crossprod(Xk)))\n B_list <- if (is.null(R_finite)) NULL else R_finite\n init_panel <- attr(X, \".init_panel\")\n omega_cache <- if (sum(vapply(X_list, nrow, integer(1))) < p)\n precompute_omega_cache(X_list, z) else NULL\n }\n\n if (!is.null(maf)) {\n if (length(maf) != p)\n stop(paste0(\"The length of maf does not agree with expected \", p, \".\"))\n id <- which(maf > maf_thresh)\n z <- z[id]\n panel_R <- lapply(panel_R, function(Rk) Rk[id, id, drop = FALSE])\n if (!is.null(X_list))\n X_list <- lapply(X_list, function(Xk) Xk[, id, drop = FALSE])\n p <- length(z)\n }\n\n if (any(is.infinite(z)))\n stop(\"z contains infinite values.\")\n if (anyNA(z)) {\n warning_message(\"NA values in z-scores are replaced with 0.\")\n z[is.na(z)] <- 0\n }\n\n if (is.numeric(null_weight) && null_weight == 0)\n null_weight <- NULL\n if (!is.null(null_weight)) {\n if (!is.numeric(null_weight))\n stop(\"Null weight must be numeric.\")\n if (null_weight < 0 || null_weight >= 1)\n stop(\"Null weight must be between 0 and 1.\")\n if (is.null(prior_weights)) {\n prior_weights <- c(rep(1 / p * (1 - null_weight), p), null_weight)\n } else {\n prior_weights <- c(prior_weights * (1 - null_weight), null_weight)\n }\n panel_R <- lapply(panel_R, function(Rk) cbind(rbind(Rk, 0), 0))\n if (!is.null(X_list))\n X_list <- lapply(X_list, function(Xk) cbind(Xk, 0))\n z <- c(z, 0)\n p <- p + 1L\n }\n\n if (is.null(prior_weights))\n prior_weights <- rep(1 / p, p)\n\n k_best <- if (!is.null(init_panel)) init_panel else 1L\n omega_init <- rep(0, K)\n omega_init[k_best] <- 1\n R_init <- Reduce(\"+\", Map(function(w, Rk) w * Rk, omega_init, panel_R))\n R_init <- 0.5 * (R_init + t(R_init))\n\n R_finite_B <- NULL\n R_finite_diagnostics <- NULL\n if (!is.null(R_finite)) {\n B_list <- as.numeric(R_finite)\n R_finite_B <- 1 / sum(omega_init^2 / B_list)\n R_finite_diagnostics <- compute_R_finite_diagnostics(\n R = R_init, B = R_finite_B, p = p)\n }\n\n nm1 <- n - 1\n XtX <- nm1 * R_init\n X_ss <- NULL\n if (!is.null(X_list)) {\n X_ss <- form_X_meta(X_list, omega_init) * sqrt(nm1)\n attr(X_ss, \"d\") <- rep(nm1, p)\n attr(X_ss, \"scaled:scale\") <- rep(1, p)\n XtX <- NULL\n }\n\n params_object <- list(\n L = L,\n scaled_prior_variance = scaled_prior_variance,\n residual_variance = residual_variance,\n prior_weights = prior_weights,\n null_weight = null_weight,\n estimate_residual_variance = estimate_residual_variance,\n estimate_residual_method = estimate_residual_method,\n residual_variance_lowerbound = residual_variance_lowerbound,\n residual_variance_upperbound = residual_variance_upperbound,\n estimate_prior_variance = estimate_prior_variance,\n estimate_prior_method = estimate_prior_method,\n prior_variance_grid = prior_variance_grid,\n mixture_weights = mixture_weights,\n unmappable_effects = unmappable_effects,\n check_null_threshold = check_null_threshold,\n prior_tol = prior_tol,\n max_iter = max_iter,\n tol = tol,\n convergence_method = convergence_method,\n coverage = coverage,\n min_abs_corr = min_abs_corr,\n compute_univariate_zscore = FALSE,\n verbose = verbose,\n track_fit = track_fit,\n check_prior = check_prior,\n refine = refine,\n n_purity = n_purity,\n alpha0 = alpha0,\n beta0 = beta0,\n n = n,\n use_NIG = estimate_residual_method == \"NIG\",\n intercept = FALSE,\n standardize = standardize,\n model_init = model_init,\n slot_prior = slot_prior,\n L_greedy = L_greedy,\n greedy_lbf_cutoff = greedy_lbf_cutoff,\n R_mismatch = R_mismatch,\n eig_delta_rel = eig_delta_rel,\n eig_delta_abs = eig_delta_abs,\n artifact_threshold = artifact_threshold\n )\n params_object <- validate_and_override_params(params_object)\n\n data_object <- structure(\n list(\n X = X_ss, XtX = XtX,\n Xty = sqrt(nm1) * z, yty = nm1,\n n = n, p = p,\n X_colmeans = rep(0, p), y_mean = 0,\n nm1 = nm1, z = z, lambda = 0,\n R_finite_B = R_finite_B,\n R_finite_diagnostics = R_finite_diagnostics,\n R_mismatch = R_mismatch,\n X_list_std = X_list, B_list = B_list,\n K = K, panel_R = panel_R, omega_cache = omega_cache\n ),\n class = c(\"ss_mixture\", \"ss\")\n )\n if (R_mismatch == \"map_qc\")\n data_object$eigen_R <- eigen(R_init, symmetric = TRUE)\n\n list(data = data_object, params = params_object)\n}\n\n# =============================================================================\n# RSS LAMBDA DATA CONSTRUCTOR\n#\n# Constructs data and params objects for SuSiE from RSS data using eigendecomposition\n# (lambda >= 0).\n# Handles eigen decomposition, MAF filtering, and specialized RSS-lambda preprocessing.\n# =============================================================================\n#'\n#' @return A list containing:\n#' \\item{data}{A processed list containing z-scores, R matrix, eigen decomposition,\n#' and RSS-lambda specific fields}\n#' \\item{params}{Validated params object with all input algorithm parameters}\n#'\n#' @keywords internal\n#' @noRd\nrss_lambda_constructor <- function(z, R = NULL, X = NULL, n = NULL,\n L = min(10, if (!is.null(R)) ncol(R) else ncol(X)),\n lambda = 0,\n maf = NULL,\n maf_thresh = 0,\n prior_variance = 50,\n residual_variance = NULL,\n prior_weights = NULL,\n null_weight = 0,\n intercept_value = 0,\n estimate_residual_variance = FALSE,\n estimate_residual_method = \"MLE\",\n estimate_prior_variance = TRUE,\n estimate_prior_method = \"optim\",\n prior_variance_grid = NULL,\n mixture_weights = NULL,\n check_null_threshold = 0,\n prior_tol = 1e-9,\n residual_variance_lowerbound = 0,\n model_init = NULL,\n coverage = 0.95,\n min_abs_corr = 0.5,\n max_iter = 100,\n tol = 1e-3,\n convergence_method = \"elbo\",\n verbose = FALSE,\n track_fit = FALSE,\n check_prior = TRUE,\n check_R = TRUE,\n check_z = FALSE,\n n_purity = 100,\n r_tol = 1e-8,\n refine = FALSE,\n slot_prior = NULL,\n L_greedy = NULL,\n greedy_lbf_cutoff = 0.1) {\n\n if (!identical(estimate_residual_method, \"MLE\")) {\n stop(\"RSS-lambda supports estimate_residual_method = \\\"MLE\\\" only.\")\n }\n if (is.list(R) && !is.matrix(R))\n stop(\"rss_lambda_constructor() accepts only a single R matrix.\")\n if (is.list(X) && !is.matrix(X))\n stop(\"rss_lambda_constructor() accepts only a single X matrix.\")\n\n # PVE-adjust z when sample size is provided. Shrinks large z toward\n # zero to account for winner's curse. Same form as the SS path\n # (summary_stats_constructor); skipped when n is unavailable.\n if (!is.null(z) && !is.null(n) && is.numeric(n) && length(n) == 1 &&\n is.finite(n) && n > 1) {\n adj <- (n - 1) / (z^2 + n - 2)\n z <- sqrt(adj) * z\n }\n\n if (is.null(X)) {\n # R path: validate R\n if (is.null(R))\n stop(\"Please provide either R or X for rss_lambda_constructor.\")\n if (nrow(R) != length(z)) {\n stop(paste0(\n \"The dimension of correlation matrix (\", nrow(R), \" by \",\n ncol(R), \") does not agree with expected (\", length(z), \" by \",\n length(z), \").\"\n ))\n }\n if (!is_symmetric_matrix(R)) {\n warning_message(\"R not symmetric; using (R + t(R))/2.\")\n R <- (R + t(R)) / 2\n }\n if (!(is.double(R) & is.matrix(R)) & !inherits(R, \"sparseMatrix\")) {\n stop(\"Input R must be a double-precision matrix or a sparse matrix.\")\n }\n } else {\n # Single-panel X path: validate X\n if (ncol(X) != length(z)) {\n stop(paste0(\n \"The number of columns of X (\", ncol(X),\n \") does not agree with expected (\", length(z), \").\"\n ))\n }\n }\n\n # MAF filter\n if (!is.null(maf)) {\n if (length(maf) != length(z)) {\n stop(paste0(\"The length of maf does not agree with expected \", length(z), \".\"))\n }\n id <- which(maf > maf_thresh)\n if (!is.null(R)) R <- R[id, id]\n if (!is.null(X)) X <- X[, id, drop = FALSE]\n z <- z[id]\n }\n\n if (any(is.infinite(z))) {\n stop(\"z contains infinite values.\")\n }\n\n # Check for NAs\n if (!is.null(R) && anyNA(R)) {\n stop(\"R matrix contains missing values.\")\n }\n\n # Replace NAs in z with zero\n if (anyNA(z)) {\n warning_message(\"NA values in z-scores are replaced with 0.\")\n z[is.na(z)] <- 0\n }\n\n # Handle null weight\n if (is.numeric(null_weight) && null_weight == 0) {\n null_weight <- NULL\n }\n if (!is.null(null_weight)) {\n if (!is.numeric(null_weight)) {\n stop(\"Null weight must be numeric.\")\n }\n if (null_weight < 0 || null_weight >= 1) {\n stop(\"Null weight must be between 0 and 1.\")\n }\n p_cur <- if (!is.null(R)) ncol(R) else ncol(X)\n if (is.null(prior_weights)) {\n prior_weights <- c(rep(1 / p_cur * (1 - null_weight), p_cur), null_weight)\n } else {\n prior_weights <- c(prior_weights * (1 - null_weight), null_weight)\n }\n if (!is.null(R)) R <- cbind(rbind(R, 0), 0)\n if (!is.null(X)) X <- cbind(X, 0)\n z <- c(z, 0)\n }\n\n # Determine p and set prior weights\n p <- if (!is.null(R)) ncol(R) else ncol(X)\n\n if (is.null(prior_weights)) {\n prior_weights <- rep(1 / p, p)\n }\n\n # Eigen decomposition: from R or SVD of X\n if (!is.null(X)) {\n # Single-panel: standardize so X'X = R, then SVD\n X <- standardize_X(X)\n eigen_R <- eigen_from_X(X, p)\n } else {\n eigen_R <- eigen(R, symmetric = TRUE)\n }\n\n if (is.null(X) && check_R && any(eigen_R$values < -r_tol)) {\n stop(paste0(\n \"The correlation matrix (\", nrow(R), \" by \", ncol(R),\n \") is not a positive semidefinite matrix. \",\n \"The smallest eigenvalue is \", min(eigen_R$values),\n \". You can bypass this by \\\"check_R = FALSE\\\" which instead \",\n \"sets negative eigenvalues to 0 to allow for continued \",\n \"computations.\"\n ))\n }\n\n # Check whether z in space spanned by the non-zero eigenvectors of R\n if (is.null(X) && check_z) {\n colspace <- which(eigen_R$values > r_tol)\n if (length(colspace) < length(z)) {\n znull <- crossprod(eigen_R$vectors[, -colspace], z)\n if (sum(znull^2) > r_tol * sum(z^2)) {\n warning_message(\"Input z does not lie in the space of non-zero eigenvectors of R.\")\n } else {\n message(\"Input z is in space spanned by the non-zero eigenvectors of R.\\n\")\n }\n }\n }\n\n # Set negative eigenvalues to zero\n eigen_R$values[eigen_R$values < r_tol] <- 0\n\n # Precompute V'z\n Vtz <- crossprod(eigen_R$vectors, z)\n\n # Compute Null-space z-score norm: ||z||^2 - ||V'z||^2.\n z_null_norm2 <- max(sum(z^2) - sum(Vtz^2), 0)\n\n # Handle lambda estimation\n if (identical(lambda, \"estimate\")) {\n colspace <- which(eigen_R$values > 0)\n if (length(colspace) == length(z)) {\n lambda <- 0\n } else {\n znull <- crossprod(eigen_R$vectors[, -colspace], z)\n lambda <- sum(znull^2) / length(znull)\n }\n }\n\n if (is.null(residual_variance)) {\n residual_variance <- 1 - lambda\n } else {\n residual_variance <- residual_variance - lambda\n }\n\n # Create params object with ALL algorithm parameters\n params_object <- list(\n L = L,\n scaled_prior_variance = prior_variance, # Use unscaled prior_variance for RSS-lambda\n residual_variance = residual_variance,\n prior_weights = prior_weights,\n null_weight = null_weight,\n estimate_residual_variance = estimate_residual_variance,\n estimate_residual_method = estimate_residual_method,\n estimate_prior_variance = estimate_prior_variance,\n estimate_prior_method = estimate_prior_method,\n prior_variance_grid = prior_variance_grid,\n mixture_weights = mixture_weights,\n unmappable_effects = \"none\", # RSS-lambda doesn't support unmappable effects\n check_null_threshold = check_null_threshold,\n prior_tol = prior_tol,\n residual_variance_upperbound = 1, # RSS constraint\n model_init = model_init,\n coverage = coverage,\n min_abs_corr = min_abs_corr,\n compute_univariate_zscore = FALSE,\n max_iter = max_iter,\n tol = tol,\n convergence_method = convergence_method,\n verbose = verbose,\n track_fit = track_fit,\n residual_variance_lowerbound = residual_variance_lowerbound,\n refine = refine,\n n_purity = n_purity,\n alpha0 = 0, # RSS doesn't support NIG\n beta0 = 0, # RSS doesn't support NIG\n n = n,\n use_NIG = FALSE,\n intercept = FALSE, # RSS always uses intercept = FALSE\n standardize = FALSE, # Never standardize RSS-lambda\n check_prior = check_prior,\n slot_prior = slot_prior,\n L_greedy = L_greedy,\n greedy_lbf_cutoff = greedy_lbf_cutoff\n )\n\n # Validate params\n params_object <- validate_and_override_params(params_object)\n\n # Create data object with RSS-lambda specific fields. n is the GWAS\n # sample size (used by the PVE adjustment above and by any downstream\n # consumer that needs to know the GWAS size); we store NA_integer_ when\n # the caller did not supply it. p (the number of variants) is always\n # length(z).\n data_object <- structure(\n list(\n z = z,\n R = R,\n X = X,\n n = if (is.null(n)) NA_integer_ else as.integer(n),\n p = length(z),\n lambda = lambda,\n intercept_value = intercept_value,\n r_tol = r_tol,\n prior_variance = prior_variance,\n eigen_R = eigen_R,\n Vtz = Vtz,\n z_null_norm2 = z_null_norm2\n ),\n class = \"rss_lambda\"\n )\n\n return(list(data = data_object, params = params_object))\n}\n" }, { "path": "R/susie_get_functions.R", "content": "#' @rdname susie_get_methods\n#'\n#' @title Inferences From Fitted SuSiE Model\n#'\n#' @description These functions access basic properties or draw\n#' inferences from a fitted susie model.\n#'\n#' @param res A susie fit, typically an output from\n#' \\code{\\link{susie}} or one of its variants. For\n#' \\code{susie_get_pip} and \\code{susie_get_cs}, this may instead be\n#' the posterior inclusion probability matrix, \\code{alpha}.\n#'\n#' @param last_only If \\code{last_only = FALSE}, return the ELBO from\n#' all iterations; otherwise return the ELBO from the last iteration\n#' only.\n#'\n#' @param warning_tol Warn if ELBO is decreasing by this\n#' tolerance level.\n#'\n#' @return \\code{susie_get_objective} returns the evidence lower bound\n#' (ELBO) achieved by the fitted susie model and, optionally, at each\n#' iteration of the IBSS fitting procedure.\n#'\n#' \\code{susie_get_residual_variance} returns the (estimated or\n#' fixed) residual variance parameter.\n#'\n#' \\code{susie_get_prior_variance} returns the (estimated or fixed)\n#' prior variance parameters.\n#'\n#' \\code{susie_get_posterior_mean} returns the posterior mean for the\n#' regression coefficients of the fitted susie model.\n#'\n#' \\code{susie_get_posterior_sd} returns the posterior standard\n#' deviation for coefficients of the fitted susie model.\n#'\n#' \\code{susie_get_niter} returns the number of model fitting\n#' iterations performed.\n#'\n#' \\code{susie_get_pip} returns a vector containing the posterior\n#' inclusion probabilities (PIPs) for all variables.\n#'\n#' \\code{susie_get_lfsr} returns a vector containing the average lfsr\n#' across variables for each single-effect, weighted by the posterior\n#' inclusion probability (alpha).\n#'\n#' \\code{susie_get_posterior_samples} returns a list containing the\n#' effect sizes samples and causal status with two components: \\code{b},\n#' an \\code{num_variables} x \\code{num_samples} matrix of effect\n#' sizes; \\code{gamma}, an \\code{num_variables} x \\code{num_samples}\n#' matrix of causal status random draws.\n#'\n#' \\code{susie_get_cs} returns credible sets (CSs) from a susie fit,\n#' as well as summaries of correlation among the variables included in\n#' each CS. If desired, one can filter out CSs that do not meet a\n#' specified \\dQuote{purity} threshold; to do this, either \\code{X} or\n#' \\code{Xcorr} must be supplied. It returns a list with the following\n#' elements:\n#'\n#' \\item{cs}{A list in which each list element is a vector containing\n#' the indices of the variables in the CS.}\n#'\n#' \\item{coverage}{The nominal coverage specified for each CS.}\n#'\n#' \\item{purity}{If \\code{X} or \\code{Xcorr} iis provided), the\n#' purity of each CS.}\n#'\n#' \\item{cs_index}{If \\code{X} or \\code{Xcorr} is provided) the index\n#' (number between 1 and L) of each reported CS in the supplied susie\n#' fit.}\n#'\n#' @examples\n#' set.seed(1)\n#' n <- 1000\n#' p <- 1000\n#' beta <- rep(0, p)\n#' beta[1:4] <- 1\n#' X <- matrix(rnorm(n * p), nrow = n, ncol = p)\n#' X <- scale(X, center = TRUE, scale = TRUE)\n#' y <- drop(X %*% beta + rnorm(n))\n#' s <- susie(X, y, L = 10)\n#' susie_get_objective(s)\n#' susie_get_objective(s, last_only = FALSE)\n#' susie_get_residual_variance(s)\n#' susie_get_prior_variance(s)\n#' susie_get_posterior_mean(s)\n#' susie_get_posterior_sd(s)\n#' susie_get_niter(s)\n#' susie_get_pip(s)\n#' susie_get_lfsr(s)\n#'\n#' @export\n#'\nsusie_get_objective <- function(res, last_only = TRUE, warning_tol = 1e-6) {\n if (!all(diff(res$elbo) >= (-1 * warning_tol))) {\n warning_message(\"Objective is decreasing\")\n }\n if (last_only) {\n return(res$elbo[length(res$elbo)])\n } else {\n return(res$elbo)\n }\n}\n\n#' @rdname susie_get_methods\n#'\n#' @export\n#'\nsusie_get_posterior_mean <- function(res, prior_tol = 1e-9) {\n # Drop the single-effects with estimated prior of zero.\n if (is.numeric(res$V)) {\n include_idx <- which(res$V > prior_tol)\n } else {\n include_idx <- 1:nrow(res$alpha)\n }\n\n # Now extract relevant rows from alpha matrix.\n if (length(include_idx) > 0) {\n return(colSums((res$alpha * res$mu)[include_idx, , drop = FALSE]) /\n res$X_column_scale_factors)\n } else {\n return(numeric(ncol(res$mu)))\n }\n}\n\n#' @rdname susie_get_methods\n#'\n#' @export\n#'\nsusie_get_posterior_sd <- function(res, prior_tol = 1e-9) {\n # Drop the single-effects with estimated prior of zero.\n if (is.numeric(res$V)) {\n include_idx <- which(res$V > prior_tol)\n } else {\n include_idx <- 1:nrow(res$alpha)\n }\n\n # Now extract relevant rows from alpha matrix.\n if (length(include_idx) > 0) {\n return(sqrt(colSums((res$alpha * res$mu2 -\n (res$alpha * res$mu)^2)[include_idx, , drop = FALSE])) /\n (res$X_column_scale_factors))\n } else {\n return(numeric(ncol(res$mu)))\n }\n}\n\n#' @rdname susie_get_methods\n#'\n#' @export\n#'\nsusie_get_niter <- function(res) {\n res$niter\n}\n\n#' @rdname susie_get_methods\n#'\n#' @export\n#'\nsusie_get_prior_variance <- function(res) {\n res$V\n}\n\n#' @rdname susie_get_methods\n#'\n#' @export\n#'\nsusie_get_residual_variance <- function(res) {\n res$sigma2\n}\n\n#' @rdname susie_get_methods\n#'\n#' @importFrom stats pnorm\n#'\n#' @export\n#'\nsusie_get_lfsr <- function(res) {\n pos_prob <- pnorm(0, mean = t(res$mu), sd = sqrt(res$mu2 - res$mu^2))\n neg_prob <- 1 - pos_prob\n return(1 - rowSums(res$alpha * t(pmax(pos_prob, neg_prob))))\n}\n\n#' @rdname susie_get_methods\n#'\n#' @param susie_fit A susie fit, an output from \\code{\\link{susie}}.\n#'\n#' @param num_samples The number of draws from the posterior\n#' distribution.\n#'\n#' @importFrom stats rmultinom\n#' @importFrom stats rnorm\n#'\n#' @export\n#'\nsusie_get_posterior_samples <- function(susie_fit, num_samples) {\n # Remove effects having estimated prior variance equals zero.\n if (is.numeric(susie_fit$V)) {\n include_idx <- which(susie_fit$V > 1e-9)\n } else {\n include_idx <- 1:nrow(susie_fit$alpha)\n }\n\n posterior_mean <- sweep(susie_fit$mu, 2, susie_fit$X_column_scale_factors, \"/\")\n posterior_sd <- sweep(\n sqrt(susie_fit$mu2 - (susie_fit$mu)^2), 2,\n susie_fit$X_column_scale_factors, \"/\"\n )\n\n pip <- susie_fit$alpha\n L <- nrow(pip)\n num_snps <- ncol(pip)\n b_samples <- matrix(as.numeric(NA), num_snps, num_samples)\n gamma_samples <- matrix(as.numeric(NA), num_snps, num_samples)\n for (sample_i in 1:num_samples) {\n b <- 0\n if (length(include_idx) > 0) {\n for (l in include_idx) {\n gamma_l <- rmultinom(1, 1, pip[l, ])\n effect_size <- rnorm(1,\n mean = posterior_mean[l, which(gamma_l != 0)],\n sd = posterior_sd[l, which(gamma_l != 0)]\n )\n b_l <- gamma_l * effect_size\n b <- b + b_l\n }\n }\n b_samples[, sample_i] <- b\n gamma_samples[, sample_i] <- as.numeric(b != 0)\n }\n return(list(b = b_samples, gamma = gamma_samples))\n}\n\n#' @rdname susie_get_methods\n#' @param X n by p matrix of values of the p variables (covariates) in\n#' n samples. When provided, correlation between variables will be\n#' computed and used to remove CSs whose minimum correlation among\n#' variables is smaller than \\code{min_abs_corr}.\n#'\n#' @param Xcorr p by p matrix of correlations between variables\n#' (covariates). When provided, it will be used to remove CSs whose\n#' minimum correlation among variables is smaller than\n#' \\code{min_abs_corr}.\n#'\n#' @param coverage A number between 0 and 1 specifying desired\n#' coverage of each CS.\n#'\n#' @param min_abs_corr A \"purity\" threshold for the CS. Any CS that\n#' contains a pair of variables with correlation less than this\n#' threshold will be filtered out and not reported. This filter is\n#' only applied when \\code{X} or \\code{Xcorr} is provided; otherwise\n#' it is ignored and a warning is issued.\n#'\n#' @param dedup If \\code{dedup = TRUE}, remove duplicate CSs.\n#'\n#' @param squared If \\code{squared = TRUE}, report min, mean and\n#' median of squared correlation instead of the absolute correlation.\n#'\n#' @param check_symmetric If \\code{check_symmetric = TRUE}, perform a\n#' check for symmetry of matrix \\code{Xcorr} when \\code{Xcorr} is\n#' provided (not \\code{NULL}).\n#'\n#' @param n_purity The maximum number of credible set (CS) variables\n#' used in calculating the correlation (\\dQuote{purity})\n#' statistics. When the number of variables included in the CS is\n#' greater than this number, the CS variables are randomly subsampled.\n#'\n#' @param use_rfast Use the Rfast package for the purity calculations.\n#' By default \\code{use_rfast = TRUE} if the Rfast package is\n#' installed.\n#'\n#' @param ld_extend_threshold Threshold for extending CS by LD (default 0.99).\n#' Variants with |correlation| > threshold with any CS member are added.\n#' Set to NULL to disable LD extension. Requires Xcorr (would not work if only X is provided).\n#'\n#' @export\n#'\nsusie_get_cs <- function(res, X = NULL, Xcorr = NULL, coverage = 0.95,\n min_abs_corr = 0.5, dedup = TRUE, squared = FALSE,\n check_symmetric = TRUE, n_purity = 100,\n use_rfast = NULL, ld_extend_threshold = 0.99) {\n if (!is.null(X) && !is.null(Xcorr)) {\n stop(\"Only one of X or Xcorr should be specified\")\n }\n if (is.null(X) && is.null(Xcorr)) {\n warning_message(\n \"Neither X nor Xcorr was provided; purity filtering is skipped \",\n \"and min_abs_corr will have no effect. Pass X or Xcorr to enable \",\n \"the purity filter.\"\n )\n }\n if (check_symmetric) {\n if (!is.null(Xcorr) && !is_symmetric_matrix(Xcorr)) {\n warning_message(\n \"Xcorr is not symmetric; forcing Xcorr to be symmetric \",\n \"by replacing Xcorr with (Xcorr + t(Xcorr))/2\"\n )\n Xcorr <- Xcorr + t(Xcorr)\n Xcorr <- Xcorr / 2\n }\n }\n\n null_index <- 0\n include_idx <- rep(TRUE, nrow(res$alpha))\n if (!is.null(res$null_index)) null_index <- res$null_index\n if (is.numeric(res$V)) include_idx <- res$V > 1e-9\n \n # L x P binary matrix\n status <- in_CS(res$alpha, coverage)\n\n # L-list of CS positions\n cs <- lapply(1:nrow(status), function(i) which(status[i, ] != 0))\n claimed_coverage <- sapply(\n 1:length(cs),\n function(i) sum(res$alpha[i, ][cs[[i]]])\n )\n include_idx <- include_idx * (lapply(cs, length) > 0)\n\n # FIXME: see issue 21\n # https://github.com/stephenslab/susieR/issues/21\n if (dedup) {\n include_idx <- include_idx * (!duplicated(cs))\n }\n include_idx <- as.logical(include_idx)\n if (sum(include_idx) == 0) {\n return(list(\n cs = NULL,\n coverage = NULL,\n requested_coverage = coverage\n ))\n }\n \n cs <- cs[include_idx]\n claimed_coverage <- claimed_coverage[include_idx]\n # Track which original effects these correspond to\n effect_indices <- which(include_idx)\n\n # Compute and filter by \"purity\"\n if (is.null(use_rfast)) {\n use_rfast <- requireNamespace(\"Rfast\", quietly = TRUE)\n }\n \n # If no correlation info, return without purity or LD extension\n if (is.null(Xcorr) && is.null(X)) {\n names(cs) <- paste0(\"L\", effect_indices)\n return(list(\n cs = cs,\n coverage = claimed_coverage,\n requested_coverage = coverage\n ))\n }\n \n # Extend CS by LD if threshold is set and Xcorr is available\n # Note: LD extension requires Xcorr; if only X is provided, skip extension\n # (X may be sparse, and computing full Xcorr is expensive/infeasible)\n if (!is.null(ld_extend_threshold) && !is.null(Xcorr)) {\n for (i in 1:length(cs)) {\n cs_idx <- cs[[i]]\n # Find variants in tight LD with any CS member\n ld_with_cs <- abs(Xcorr[cs_idx, , drop = FALSE]) > ld_extend_threshold\n in_tight_ld <- which(colSums(ld_with_cs) > 0)\n # Extend CS\n cs[[i]] <- sort(unique(c(cs_idx, in_tight_ld)))\n # Update coverage for extended CS\n claimed_coverage[i] <- sum(res$alpha[effect_indices[i], cs[[i]]])\n }\n }\n\n # Compute purity for each CS\n purity <- NULL\n for (i in 1:length(cs)) {\n if (null_index > 0 && null_index %in% cs[[i]]) {\n purity <- rbind(purity, c(-9, -9, -9))\n } else {\n purity <- rbind(\n purity,\n matrix(get_purity(cs[[i]], X, Xcorr, squared, n_purity, use_rfast), 1, 3)\n )\n }\n }\n purity <- as.data.frame(purity)\n if (squared) {\n colnames(purity) <- c(\"min.sq.corr\", \"mean.sq.corr\", \"median.sq.corr\")\n } else {\n colnames(purity) <- c(\"min.abs.corr\", \"mean.abs.corr\", \"median.abs.corr\")\n }\n \n threshold <- ifelse(squared, min_abs_corr^2, min_abs_corr)\n is_pure <- which(purity[, 1] >= threshold)\n \n if (length(is_pure) > 0) {\n cs <- cs[is_pure]\n purity <- purity[is_pure, , drop = FALSE]\n claimed_coverage <- claimed_coverage[is_pure]\n effect_indices <- effect_indices[is_pure]\n \n row_names <- paste0(\"L\", effect_indices)\n names(cs) <- row_names\n rownames(purity) <- row_names\n \n # Re-order CS list and purity rows based on purity\n ordering <- order(purity[, 1], decreasing = TRUE)\n return(list(\n cs = cs[ordering],\n purity = purity[ordering, , drop = FALSE],\n cs_index = effect_indices[ordering],\n coverage = claimed_coverage[ordering],\n requested_coverage = coverage\n ))\n } else {\n return(list(cs = NULL, coverage = NULL, requested_coverage = coverage))\n }\n}\n\n#' @title Get Correlations Between CSs, using Variable with Maximum PIP From Each CS\n#'\n#' @description This function evaluates the correlation between single effect\n#' CSs. It is not part of the SuSiE inference. Rather, it is designed as\n#' a diagnostic tool to assess how correlated the reported CS are.\n#'\n#' @param model A SuSiE fit, typically an output from\n#' \\code{\\link{susie}} or one of its variants.\n#'\n#' @param X n by p matrix of values of the p variables (covariates) in\n#' n samples. When provided, correlation between variables will be\n#' computed and used to remove CSs whose minimum correlation among\n#' variables is smaller than \\code{min_abs_corr}.\n#'\n#' @param Xcorr p by p matrix of correlations between variables\n#' (covariates). When provided, it will be used to remove CSs whose\n#' minimum correlation among variables is smaller than\n#' \\code{min_abs_corr}.\n#'\n#' @param max When \\code{max = FAFLSE}, return a matrix of CS\n#' correlations. When \\code{max = TRUE}, return only the maximum\n#' absolute correlation among all pairs of correlations.\n#'\n#' @return A matrix of correlations between CSs, or the maximum\n#' absolute correlation when \\code{max = TRUE}.\n#'\n#' @export\n#'\nget_cs_correlation <- function(model, X = NULL, Xcorr = NULL, max = FALSE) {\n if (is.null(model$sets$cs) || length(model$sets$cs) == 1) {\n return(NA)\n }\n if (!is.null(X) && !is.null(Xcorr)) {\n stop(\"Only one of X or Xcorr should be specified\")\n }\n if (is.null(Xcorr) && is.null(X)) {\n stop(\"One of X or Xcorr must be specified\")\n }\n if (!is.null(Xcorr) && !is_symmetric_matrix(Xcorr)) {\n warning_message(\n \"Xcorr is not symmetric; forcing Xcorr to be symmetric \",\n \"by replacing Xcorr with (Xcorr + t(Xcorr))/2\"\n )\n Xcorr <- Xcorr + t(Xcorr)\n Xcorr <- Xcorr / 2\n }\n # Get index for the best PIP per CS\n max_pip_idx <- sapply(model$sets$cs, function(cs) cs[which.max(model$pip[cs])])\n if (is.null(Xcorr)) {\n X_sub <- X[, max_pip_idx]\n cs_corr <- safe_cor(as.matrix(X_sub))\n } else {\n cs_corr <- Xcorr[max_pip_idx, max_pip_idx]\n }\n if (max) {\n cs_corr <- max(abs(cs_corr[upper.tri(cs_corr)]))\n } else {\n rownames(cs_corr) <- colnames(cs_corr) <- names(model$sets$cs)\n }\n return(cs_corr)\n}\n\n#' @rdname susie_get_methods\n#'\n#' @param prune_by_cs Whether or not to ignore single effects not in\n#' a reported CS when calculating PIP.\n#'\n#' @param prior_tol Filter out effects having estimated prior variance\n#' smaller than this threshold.\n#'\n#' @export\n#'\nsusie_get_pip <- function(res, prune_by_cs = FALSE, prior_tol = 1e-9) {\n if (inherits(res, \"susie\")) {\n # Drop null weight columns.\n if (!is.null(res$null_index) && res$null_index > 0) {\n res$alpha <- res$alpha[, -res$null_index, drop = FALSE]\n }\n\n # Drop the single-effects with estimated prior of zero.\n if (is.numeric(res$V)) {\n include_idx <- which(res$V > prior_tol)\n } else {\n include_idx <- 1:nrow(res$alpha)\n }\n\n # Only consider variables in reported CS.\n # This is not what we do in the SuSiE paper.\n # So by default prune_by_cs = FALSE means we do not run the\n # following code.\n if (!is.null(res$sets$cs_index) && prune_by_cs) {\n include_idx <- intersect(include_idx, res$sets$cs_index)\n }\n if (is.null(res$sets$cs_index) && prune_by_cs) {\n include_idx <- numeric(0)\n }\n\n # Extract slot weights (c_hat) if available for Gamma-Poisson weighting.\n # PIP_j = 1 - prod_l(1 - c_hat[l] * alpha[l,j])\n # (Faithfully ported from susieAnn posterior.R:195-200)\n slot_wt <- res$slot_weights\n\n # now extract relevant rows from alpha matrix\n if (length(include_idx) > 0) {\n res_alpha <- res$alpha[include_idx, , drop = FALSE]\n if (!is.null(slot_wt)) {\n slot_wt <- slot_wt[include_idx]\n }\n } else {\n res_alpha <- matrix(0, 1, ncol(res$alpha))\n slot_wt <- NULL\n }\n res <- res_alpha\n }\n\n # c_hat-weighted PIPs when slot_weights are available\n if (exists(\"slot_wt\", inherits = FALSE) && !is.null(slot_wt)) {\n weighted_alpha <- sweep(res, 1, slot_wt, `*`)\n return(as.vector(1 - apply(1 - weighted_alpha, 2, prod)))\n }\n return(as.vector(1 - apply(1 - res, 2, prod)))\n}\n\n#' @title Initialize a susie object using regression coefficients\n#'\n#' @param coef_index An L-vector containing the the indices of the\n#' nonzero coefficients.\n#'\n#' @param coef_value An L-vector containing initial coefficient\n#' estimates.\n#'\n#' @param p A scalar giving the number of variables.\n#'\n#' @return A list with elements \\code{alpha}, \\code{mu} and \\code{mu2}\n#' to be used by \\code{susie}.\n#'\n#' @examples\n#' set.seed(1)\n#' n = 1000\n#' p = 1000\n#' beta = rep(0,p)\n#' beta[sample(1:1000,4)] = 1\n#' X = matrix(rnorm(n*p),nrow = n,ncol = p)\n#' X = scale(X,center = TRUE,scale = TRUE)\n#' y = drop(X %*% beta + rnorm(n))\n#'\n#' # Initialize susie to ground-truth coefficients.\n#' s = susie_init_coef(which(beta != 0),beta[beta != 0],length(beta))\n#' res = susie(X,y,L = 10,model_init=s)\n#'\n#' @export\n#'\nsusie_init_coef = function (coef_index, coef_value, p) {\n L = length(coef_index)\n if (L <= 0)\n stop(\"Need at least one non-zero effect\")\n if (!all(coef_value != 0))\n stop(\"Input coef_value must be non-zero for all its elements\")\n if (L != length(coef_value))\n stop(\"Inputs coef_index and coef_value must of the same length\")\n if (max(coef_index) > p)\n stop(\"Input coef_index exceeds the boundary of p\")\n alpha = matrix(0,nrow = L,ncol = p)\n mu = matrix(0,nrow = L,ncol = p)\n for(i in 1:L){\n alpha[i,coef_index[i]] = 1\n mu[i,coef_index[i]] = coef_value[i]\n }\n out = list(alpha = alpha, mu = mu, mu2 = mu*mu)\n class(out) = c(\"susie\",\"list\")\n return(out)\n}\n" }, { "path": "R/susie_plot.R", "content": "#' @rdname susie_plots\n#'\n#' @title SuSiE Plots.\n#'\n#' @description \\code{susie_plot} produces a per-variable summary of\n#' the SuSiE credible sets. \\code{susie_plot_iteration} produces a\n#' diagnostic plot for the susie model fitting. For\n#' \\code{susie_plot_iteration}, several plots will be created if\n#' \\code{track_fit = TRUE} when calling \\code{susie}.\n#'\n#' @param model A SuSiE fit, typically an output from\n#' \\code{\\link{susie}} or one of its variants. For \\code{suse_plot},\n#' the susie fit must have \\code{model$z}, \\code{model$PIP}, and may\n#' include \\code{model$sets}. \\code{model} may also be a vector of\n#' z-scores or PIPs.\n#'\n#' @param y A string indicating what to plot: either \\code{\"z_original\"} for\n#' z-scores, \\code{\"z\"} for z-score derived p-values on (base-10) log-scale,\n#' \\code{\"PIP\"} for posterior inclusion probabilities,\n#' \\code{\"log10PIP\"} for posterior inclusion probabiliities on the\n#' (base-10) log-scale. For any other setting, the data are plotted as\n#' is.\n#'\n#' @param add_bar If \\code{add_bar = TRUE}, add horizontal bar to\n#' signals in credible interval.\n#'\n#' @param pos This can be either be (1) a numeric vector of indices of\n#' subset of variables to plot, or (2) a list with the following list\n#' elements: \\code{pos$attr}, \\code{pos$start} and \\code{pos$end},\n#' where \\code{pos$attr} is a character string of the name of index\n#' variable in \\code{model} object, and \\code{pos$start} and\n#' \\code{pos$end} are boundaries of indices to plot. See the provided\n#' examples.\n#'\n#' @param b For simulated data, set \\code{b = TRUE} to highlight\n#' \"true\" effects (highlights in red).\n#'\n#' @param max_cs The largest credible set to display, either based on\n#' purity (set \\code{max_cs} between 0 and 1), or based on size (set\n#' \\code{max_cs > 1}).\n#'\n#' @param add_legend If \\code{add_legend = TRUE}, add a legend to\n#' annotate the size and purity of each CS discovered. It can also be\n#' specified as location where legends should be added, e.g.,\n#' \\code{add_legend = \"bottomright\"} (default location is\n#' \\code{\"topright\"}).\n#'\n#' @param \\dots Additional arguments passed to\n#' \\code{\\link[graphics]{plot}}.\n#'\n#' @return Invisibly returns \\code{NULL}.\n#'\n#' @seealso \\code{\\link{susie_plot_changepoint}}\n#'\n#' @examples\n#' set.seed(1)\n#' n <- 1000\n#' p <- 1000\n#' beta <- rep(0, p)\n#' beta[sample(1:1000, 4)] <- 1\n#' X <- matrix(rnorm(n * p), nrow = n, ncol = p)\n#' X <- scale(X, center = TRUE, scale = TRUE)\n#' y <- drop(X %*% beta + rnorm(n))\n#' res <- susie(X, y, L = 10)\n#' susie_plot(res, \"PIP\")\n#' susie_plot(res, \"PIP\", add_bar = TRUE)\n#' susie_plot(res, \"PIP\", add_legend = TRUE)\n#' susie_plot(res, \"PIP\", pos = 1:500, add_legend = TRUE)\n#' # Plot selected regions with adjusted x-axis position label\n#' res$genomic_position <- 1000 + (1:length(res$pip))\n#' susie_plot(res, \"PIP\",\n#' add_legend = TRUE,\n#' pos = list(attr = \"genomic_position\", start = 1000, end = 1500)\n#' )\n#' # True effects are shown in red.\n#' susie_plot(res, \"PIP\", b = beta, add_legend = TRUE)\n#'\n#' @importFrom utils head\n#' @importFrom stats pnorm\n#' @importFrom graphics plot\n#' @importFrom graphics segments\n#' @importFrom graphics points\n#' @importFrom graphics legend\n#' @importFrom graphics par\n#'\n#' @export\n#'\nsusie_plot <- function(model, y, add_bar = FALSE, pos = NULL, b = NULL,\n max_cs = 400, add_legend = NULL, ...) {\n is_susie <- inherits(model, \"susie\")\n ylab <- y\n color <- c(\n \"dodgerblue2\",\n \"green4\",\n \"#6A3D9A\", # purple\n \"#FF7F00\", # orange\n \"gold1\",\n \"skyblue2\", \"#FB9A99\", # lt pink\n \"palegreen2\",\n \"#CAB2D6\", # lt purple\n \"#FDBF6F\", # lt orange\n \"gray70\", \"khaki2\",\n \"maroon\", \"orchid1\", \"deeppink1\", \"blue1\", \"steelblue4\",\n \"darkturquoise\", \"green1\", \"yellow4\", \"yellow3\",\n \"darkorange4\", \"brown\"\n )\n if (y == \"z\") {\n if (is_susie) {\n if (is.null(model$z)) {\n stop(\n \"z-scores are not available from SuSiE fit; please set \",\n \"compute_univariate_zscore = TRUE in susie() call\"\n )\n }\n zneg <- -abs(model$z)\n } else {\n zneg <- -abs(model)\n }\n p <- -log10(2 * pnorm(zneg))\n ylab <- \"-log10(p)\"\n } else if (y == \"z_original\") {\n if (is_susie) {\n if (is.null(model$z)) {\n stop(\n \"z-scores are not available from SuSiE fit; please set \",\n \"compute_univariate_zscore = TRUE in susie() call\"\n )\n }\n p <- model$z\n } else {\n p <- model\n }\n ylab <- \"z score\"\n } else if (y == \"PIP\") {\n if (is_susie) {\n p <- model$pip\n } else {\n p <- model\n }\n } else if (y == \"log10PIP\") {\n if (is_susie) {\n p <- log10(model$pip)\n } else {\n p <- log10(model)\n }\n ylab <- \"log10(PIP)\"\n } else {\n if (is_susie) {\n stop(\"Need to specify z_original, z, PIP or log10PIP for SuSiE fits\")\n }\n p <- model\n }\n if (is.null(b)) {\n b <- rep(0, length(p))\n }\n if (is.null(pos)) {\n pos <- 1:length(p)\n }\n start <- 0\n if (inherits(pos, \"list\")) {\n # Check input.\n if (is.null(pos$attr) || is.null(pos$start) || is.null(pos$end)) {\n stop(\"pos argument should be a list of list(attr=,start=,end=)\")\n }\n if (!(pos$attr %in% names(model))) {\n stop(paste(\"Cannot find attribute\", pos$attr, \"in input model object\"))\n }\n if (pos$start >= pos$end) {\n stop(\"Position start should be smaller than end\")\n }\n start <- min(min(model[[pos$attr]]), pos$start)\n end <- max(max(model[[pos$attr]]), pos$end)\n\n # Add zeros to alpha and p.\n new_p <- rep(NA, end - start + 1)\n pos_with_value <- model[[pos$attr]] - start + 1\n new_p[pos_with_value] <- p\n p <- new_p\n\n # Adjust model$cs.\n if (!is.null(model$sets$cs)) {\n for (i in 1:length(model$sets$cs)) {\n model$sets$cs[[i]] <- pos_with_value[model$sets$cs[[i]]]\n }\n }\n\n # Change \"pos\" object to be indices.\n start_adj <- -min(min(model[[pos$attr]]) - pos$start, 0)\n end_adj <- max(max(model[[pos$attr]]) - pos$end, 0)\n pos <- (1 + start_adj):(length(p) - end_adj)\n } else {\n if (!all(pos %in% 1:length(p))) {\n stop(\"Provided position is outside the range of variables\")\n }\n pos_with_value <- 1:length(p)\n }\n legend_text <- list(col = vector(), purity = vector(), size = vector(), cs_index = vector())\n # scipen0 = options()$scipen\n # options(scipen = 10)\n args <- list(...)\n if (!exists(\"xlab\", args)) args$xlab <- \"variable\"\n if (!exists(\"ylab\", args)) args$ylab <- ylab\n if (!exists(\"pch\", args)) args$pch <- 16\n args$x <- pos + start\n args$y <- p[pos]\n do.call(plot, args)\n if (is_susie && !is.null(model$sets$cs)) {\n for (cs_idx in rev(seq_along(model$sets$cs))) {\n\n cs_vars <- model$sets$cs[[cs_idx]]\n purity <- model$sets$purity[cs_idx, 1]\n\n # Apply filtering based on max_cs parameter\n if (!is.null(model$sets$purity) && max_cs < 1 && purity >= max_cs) {\n x0 <- intersect(pos, cs_vars)\n y1 <- p[x0]\n } else if (length(cs_vars) < max_cs) {\n x0 <- intersect(pos, cs_vars)\n y1 <- p[x0]\n } else {\n x0 <- NULL\n y1 <- NULL\n }\n\n if (is.null(x0)) {\n next\n }\n if (add_bar) {\n y0 <- rep(0, length(x0))\n x1 <- x0\n segments(x0 + start, y0, x1 + start, y1, lwd = 1.5, col = \"gray\")\n }\n points(x0 + start, y1, col = head(color, 1), cex = 1.5, lwd = 2.5)\n legend_text$col <- append(head(color, 1), legend_text$col)\n\n # Rotate color.\n color <- c(color[-1], color[1])\n legend_text$purity <- append(round(purity, 4), legend_text$purity)\n legend_text$size <- append(length(x0), legend_text$size)\n\n # Store the original cs_index\n if (!is.null(model$sets$cs_index)) {\n legend_text$cs_index <- append(model$sets$cs_index[cs_idx], legend_text$cs_index)\n } else {\n legend_text$cs_index <- append(cs_idx, legend_text$cs_index)\n }\n }\n if (length(legend_text$col) > 0 && !is.null(add_legend) &&\n !identical(add_legend, FALSE)) {\n # Plot legend.\n text <- vector()\n for (i in 1:length(legend_text$col)) {\n effect_label <- if (length(legend_text$cs_index) >= i) legend_text$cs_index[i] else i\n if (legend_text$size[i] == 1) {\n text[i] <- paste0(\"L\", effect_label, \": C=1\")\n } else {\n text[i] <- paste0(\n \"L\", effect_label, \": C=\", legend_text$size[i], \"/R=\",\n legend_text$purity[i]\n )\n }\n }\n if (!(add_legend %in% c(\n \"bottomright\", \"bottom\", \"bottomleft\", \"left\",\n \"topleft\", \"top\", \"topright\", \"right\", \"center\"\n ))) {\n add_legend <- \"topright\"\n }\n legend(add_legend, text,\n bty = \"n\", col = legend_text$col, cex = 0.65,\n pch = 15\n )\n }\n }\n points(pos[b != 0] + start, p[b != 0] + start, col = 2, pch = 16)\n # options(scipen = scipen0)\n return(invisible())\n}\n\n#' @rdname susie_plots\n#'\n#' @param L An integer specifying the number of credible sets to plot.\n#'\n#' @param file_prefix Prefix to path of output plot file. If not\n#' specified, the plot, or plots, will be saved to a temporary\n#' directory generated using \\code{\\link{tempdir}}.\n#'\n#' @param pos Indices of variables to plot. If \\code{pos = NULL} all\n#' variables are plotted.\n#'\n#' @examples\n#' set.seed(1)\n#' n <- 1000\n#' p <- 1000\n#' beta <- rep(0, p)\n#' beta[sample(1:1000, 4)] <- 1\n#' X <- matrix(rnorm(n * p), nrow = n, ncol = p)\n#' X <- scale(X, center = TRUE, scale = TRUE)\n#' y <- drop(X %*% beta + rnorm(n))\n#' res <- susie(X, y, L = 10)\n#' susie_plot_iteration(res, L = 10)\n#'\n#' @importFrom grDevices pdf\n#' @importFrom grDevices dev.off\n#' @importFrom reshape melt\n#' @importFrom ggplot2 ggplot\n#' @importFrom ggplot2 aes\n#' @importFrom ggplot2 geom_col\n#' @importFrom ggplot2 ggtitle\n#' @importFrom ggplot2 theme_classic\n#' @importFrom ggplot2 .data\n#'\n#' @export\n#'\nsusie_plot_iteration <- function(model, L, file_prefix, pos = NULL) {\n get_layer <- function(obj, k, idx, vars) {\n alpha <- melt(obj$alpha[1:k, vars, drop = FALSE])\n colnames(alpha) <- c(\"L\", \"variables\", \"alpha\")\n alpha$L <- as.factor(alpha$L)\n ggplot(alpha, aes(x = .data$variables, y = .data$alpha, group = .data$L)) +\n geom_col(aes(fill = .data$L)) +\n ggtitle(paste(\"Iteration\", idx)) +\n theme_classic()\n }\n k <- min(nrow(model$alpha), L)\n if (is.null(pos)) {\n vars <- 1:ncol(model$alpha)\n } else {\n vars <- pos\n }\n if (missing(file_prefix)) {\n file_prefix <- file.path(tempdir(), \"susie_plot\")\n }\n pdf(paste0(file_prefix, \".pdf\"), 8, 3)\n if (is.null(model$trace)) {\n print(get_layer(model, k, model$niter, vars))\n } else {\n for (i in 2:length(model$trace)) {\n print(get_layer(model$trace[[i]], k, i - 1, vars))\n }\n }\n dev.off()\n format <- \".pdf\"\n if (!is.null(model$trace)) {\n cmd <- paste(\n \"convert -delay 30 -loop 0 -density 300 -dispose previous\",\n paste0(file_prefix, \".pdf\"),\n \"\\\\( -clone 0 -set delay 300 \\\\) -swap 0 +delete\",\n \"\\\\( +clone -set delay 300 \\\\) +swap +delete -coalesce\",\n \"-layers optimize\", paste0(file_prefix, \".gif\")\n )\n message(\"Creating GIF animation...\")\n if (file.exists(paste0(file_prefix, \".gif\"))) {\n file.remove(paste0(file_prefix, \".gif\"))\n }\n output <- try(system(cmd))\n if (inherits(output, \"try-error\")) {\n stop(\"Cannot create GIF animation because convert command failed\")\n } else {\n format <- \".gif\"\n }\n }\n message(paste0(\"Iterplot saved to \", file_prefix, format, \"\\n\"))\n return(invisible())\n}\n\n#' @title Plot changepoint data and susie fit using ggplot2\n#'\n#' @description Plots original data, y, overlaid with line showing\n#' susie fitted value and shaded rectangles showing credible sets for\n#' changepoint locations.\n#'\n#' @param y An n-vector of observations that are ordered in time or\n#' space (assumed equally-spaced).\n#'\n#' @param s A susie fit generated by\n#' \\code{susie_trendfilter(y,order = 0)}.\n#'\n#' @param line_col Color for the line showing fitted values.\n#'\n#' @param line_size Size of the lines showing fitted values\n#'\n#' @param cs_col Color of the shaded rectangles showing credible\n#' sets.\n#'\n#' @return A ggplot2 plot object.\n#'\n#' @examples\n#' set.seed(1)\n#' mu <- c(rep(0, 50), rep(1, 50), rep(3, 50), rep(-2, 50), rep(0, 300))\n#' y <- mu + rnorm(500)\n#' # Here we use a less sensitive tolerance so that the example takes\n#' # less time; in practice you will likely want to use a more stringent\n#' # setting such as tol = 0.001.\n#' s <- susie_trendfilter(y, tol = 0.1)\n#'\n#' # Produces ggplot with credible sets for changepoints.\n#' susie_plot_changepoint(s, y)\n#'\n#' @importFrom ggplot2 ggplot\n#' @importFrom ggplot2 aes\n#' @importFrom ggplot2 geom_point\n#' @importFrom ggplot2 geom_line\n#' @importFrom ggplot2 annotate\n#' @importFrom ggplot2 .data\n#'\n#' @export\n#'\nsusie_plot_changepoint <- function(s, y, line_col = \"blue\", line_size = 1.5,\n cs_col = \"red\") {\n df <- data.frame(x = 1:length(y), y = y, mu = predict.susie(s))\n CS <- susie_get_cs(s)$cs\n p <- ggplot(df) +\n geom_point(data = df, aes(x = .data$x, y = .data$y)) +\n geom_line(\n color = line_col, data = df, aes(x = .data$x, y = .data$mu),\n linewidth = line_size\n )\n for (i in seq_along(CS)) {\n p <- p + annotate(\"rect\",\n fill = cs_col, alpha = 0.5,\n xmin = min(CS[[i]]) - 0.5, xmax = max(CS[[i]]) + 0.5,\n ymin = -Inf, ymax = Inf\n )\n }\n return(p)\n}\n" }, { "path": "R/susie_post_outcome_configuration.R", "content": "# Post-hoc causal-configuration probabilities for one or more SuSiE-class fits.\n#\n# Two algorithms live here, exposed through one entry point:\n#\n# * SuSiEx (Nature Genetics, 2024): N-trait 2^N enumeration. Per CS tuple\n# (one CS chosen from each trait), report posterior probabilities over\n# all 2^N \"which traits share the causal\" patterns plus per-trait\n# marginals. Legacy reference implementation:\n# `mvf.susie.alpha::posthoc_multfsusie`.\n#\n# * Coloc pairwise ABF (Wallace, 2020 / `coloc::coloc.bf_bf`): pairwise\n# H0/H1/H2/H3/H4 posteriors for every (trait, trait') pair across every\n# (CS in trait, CS in trait') pair. Implemented inline here as a\n# verbatim port of `coloc:::combine.abf` so susieR has no soft\n# dependency on coloc.\n#\n# The public function normalises any supported input shape (single fit, list\n# of fits, or a single multi-output fit treated outcome-wise) to a flat list\n# of \"trait views\", then runs the requested algorithms against that list.\n# Class-aware branches use `inherits()` and are confined to one helper.\n#\n# The return value is tagged with class `\"susie_post_outcome_configuration\"`\n# so `summary()` dispatches to the pretty-printer at the bottom of this file.\n\n#' Post-hoc causal-configuration probabilities for one or more SuSiE-class fits\n#'\n#' Runs one of two complementary post-hoc analyses, selected by\n#' \\code{method}: \\code{\"susiex\"} (default) for the SuSiEx \\eqn{2^N}\n#' combinatorial enumeration, reporting the posterior probability of\n#' every binary causality pattern across the \\eqn{N} input traits; or\n#' \\code{\"coloc_pairwise\"} for the coloc pairwise ABF, reporting the\n#' five colocalisation hypothesis posteriors (H0/H1/H2/H3/H4) for every\n#' pair of traits. To get both, call the function twice and combine.\n#'\n#' Two grouping modes are supported through the \\code{by} argument:\n#' \\describe{\n#' \\item{\\code{\"fit\"}}{Each input fit contributes a single trait view.\n#' Multi-output fits (\\code{mvsusie}, \\code{mfsusie}) are kept whole: the\n#' trait's per-(CS, SNP) log Bayes factors are the joint composite\n#' stored on the fit as \\code{lbf_variable}. Configuration enumeration\n#' loops over the cross-product \\eqn{L_1 \\times \\dots \\times L_N} of CS\n#' indices.}\n#' \\item{\\code{\"outcome\"}}{Multi-output fits fan out into per-outcome views,\n#' each with its own per-(CS, SNP) log Bayes factors read from\n#' \\code{fit$lbf_variable_outcome} (an \\eqn{L \\times J \\times R} or\n#' \\eqn{L \\times J \\times M} array). All per-outcome views share the\n#' joint fit's PIP matrix and CS list, so the configuration enumeration\n#' reduces to a single index \\eqn{l \\in 1..L}. Single-output \\code{susie}\n#' fits pass through unchanged. Requires \\code{$lbf_variable_outcome} on the\n#' fit (set \\code{attach_lbf_variable_outcome = TRUE} when fitting).}\n#' }\n#'\n#' \\subsection{SuSiEx algorithm}{\n#' For each credible-set tuple \\eqn{(l_1, \\dots, l_N)}:\n#' \\enumerate{\n#' \\item Per-trait CS-level log BF (alpha-weighted SNP average):\n#' \\deqn{\\log\\mathrm{BF}^{(n)}_{l_n} = \\sum_j \\alpha_{n,l_n,j}\\,\n#' \\log\\mathrm{BF}_{n,l_n,j}.}\n#' \\item Enumerate the \\eqn{2^N} binary configurations\n#' \\eqn{c \\in \\{0,1\\}^N}.\n#' \\item Configuration log BF:\n#' \\deqn{\\log\\mathrm{BF}^{(c)} = \\sum_{n: c_n = 1} \\log\\mathrm{BF}^{(n)}_{l_n}.}\n#' \\item Normalise under a uniform prior over the \\eqn{2^N} configurations.\n#' \\item Per-trait marginal: \\eqn{P(\\mathrm{trait}\\,n\\,\\mathrm{causal}) =\n#' \\sum_{c: c_n = 1} P(c \\mid \\mathrm{tuple})}.\n#' }\n#' }\n#'\n#' \\subsection{Coloc pairwise algorithm}{\n#' For each unordered trait pair \\eqn{(n, n')} and each CS pair\n#' \\eqn{(l_n, l_{n'})}, with per-SNP log BFs\n#' \\eqn{\\ell_1 = \\log\\mathrm{BF}_{n,l_n,\\cdot}} and\n#' \\eqn{\\ell_2 = \\log\\mathrm{BF}_{n',l_{n'},\\cdot}} (length \\eqn{J}), the\n#' five hypothesis log-BFs are\n#' \\deqn{\\log\\mathrm{BF}_{H_0} = 0,\\quad\n#' \\log\\mathrm{BF}_{H_1} = \\log p_1 + \\mathrm{LSE}(\\ell_1),\\quad\n#' \\log\\mathrm{BF}_{H_2} = \\log p_2 + \\mathrm{LSE}(\\ell_2),}\n#' \\deqn{\\log\\mathrm{BF}_{H_3} = \\log p_1 + \\log p_2 +\n#' \\mathrm{logdiff}(\\mathrm{LSE}(\\ell_1) + \\mathrm{LSE}(\\ell_2),\\;\n#' \\mathrm{LSE}(\\ell_1 + \\ell_2)),}\n#' \\deqn{\\log\\mathrm{BF}_{H_4} = \\log p_{12} + \\mathrm{LSE}(\\ell_1 + \\ell_2),}\n#' and the corresponding posteriors are\n#' \\eqn{\\mathrm{PP.H}_h = \\exp(\\log\\mathrm{BF}_{H_h} -\n#' \\mathrm{LSE}(\\log\\mathrm{BF}_{H_0:H_4}))}, where\n#' \\eqn{\\mathrm{LSE}} is the log-sum-exp.\n#' \\itemize{\n#' \\item H0: no causal variant in either CS.\n#' \\item H1: causal in trait \\eqn{n} only.\n#' \\item H2: causal in trait \\eqn{n'} only.\n#' \\item H3: distinct causals in the two traits.\n#' \\item H4: a single shared causal variant.\n#' }\n#' }\n#'\n#' @param input A single fit of class \\code{susie}, \\code{mvsusie}, or\n#' \\code{mfsusie}, OR a list of such fits.\n#' @param by Either \\code{\"fit\"} (one trait per input fit; default) or\n#' \\code{\"outcome\"} (multi-output fits expand into per-outcome traits).\n#' @param method Character scalar; one of \\code{\"susiex\"} (default) or\n#' \\code{\"coloc_pairwise\"}. Pick the analysis to run; for both, call\n#' the function twice.\n#' @param prob_thresh Per-trait marginal threshold for the convenience\n#' \\code{$active} flags in the SuSiEx output. Default \\code{0.8}.\n#' @param cs_only Logical. If \\code{TRUE} (default) only enumerate over CSs\n#' present in each fit's \\code{$sets$cs}; if \\code{FALSE} loop over all L\n#' rows of \\code{$alpha}. Either way, effects whose entire alpha row is\n#' zero are skipped. When \\code{TRUE}, every fit must carry a non-null\n#' \\code{$sets$cs} or the function errors.\n#' @param p1,p2,p12 Coloc per-SNP causal priors: \\code{p1} for trait 1\n#' alone, \\code{p2} for trait 2 alone, \\code{p12} for shared causal.\n#' Defaults match \\code{coloc::coloc.bf_bf}: \\code{p1 = p2 = 1e-4},\n#' \\code{p12 = 5e-6}. Only used when \\code{\"coloc_pairwise\"} is in\n#' \\code{methods}.\n#' @param ... Currently ignored.\n#'\n#' @return A list of class \\code{\"susie_post_outcome_configuration\"} with\n#' exactly one of the following components, depending on \\code{method}:\n#' \\describe{\n#' \\item{\\code{$susiex}}{(when \\code{method = \"susiex\"}) A list of length\n#' equal to the number of CS tuples considered. Each element has\n#' components \\code{cs_indices} (length-N integer tuple),\n#' \\code{logBF_trait} (length N), \\code{configs} (\\eqn{2^N \\times N}\n#' binary matrix), \\code{config_prob} (length \\eqn{2^N}),\n#' \\code{marginal_prob} (length-N per-trait marginal posterior\n#' probability of being active across the configuration ensemble),\n#' and \\code{active} (logical, \\code{marginal_prob >= prob_thresh}).}\n#' \\item{\\code{$coloc_pairwise}}{(when \\code{method = \"coloc_pairwise\"})\n#' A data.frame with one row per (trait1, trait2, l1, l2)\n#' combination, columns \\code{trait1, trait2, l1, l2, hit1, hit2,\n#' PP.H0, PP.H1, PP.H2, PP.H3, PP.H4}.}\n#' }\n#' Pretty-print with \\code{summary(out)}.\n#'\n#' @references\n#' SuSiEx, Nature Genetics 2024 (combinatorial \\eqn{2^N} enumeration).\n#' Wallace, PLoS Genetics 2020 (coloc pairwise H0/H1/H2/H3/H4 ABF).\n#'\n#' @export\nsusie_post_outcome_configuration <- function(input,\n by = c(\"fit\", \"outcome\"),\n method = c(\"susiex\",\n \"coloc_pairwise\"),\n prob_thresh = 0.8,\n cs_only = TRUE,\n p1 = 1e-4,\n p2 = 1e-4,\n p12 = 5e-6,\n ...) {\n by <- match.arg(by)\n method <- match.arg(method)\n\n if (!is.numeric(prob_thresh) || length(prob_thresh) != 1L ||\n !is.finite(prob_thresh) || prob_thresh < 0 || prob_thresh > 1) {\n stop(\"`prob_thresh` must be a single numeric in [0, 1].\")\n }\n if (!is.logical(cs_only) || length(cs_only) != 1L || is.na(cs_only)) {\n stop(\"`cs_only` must be a single logical (TRUE or FALSE).\")\n }\n for (nm in c(\"p1\", \"p2\", \"p12\")) {\n v <- get(nm)\n if (!is.numeric(v) || length(v) != 1L || !is.finite(v) ||\n v <= 0 || v >= 1) {\n stop(\"`\", nm, \"` must be a single numeric in (0, 1).\")\n }\n }\n\n views <- normalise_to_views(input, by = by, cs_only = cs_only)\n\n out <- list()\n if (identical(method, \"susiex\")) {\n out$susiex <- susiex_configurations(views,\n by = by,\n prob_thresh = prob_thresh)\n } else {\n # method == \"coloc_pairwise\"\n out$coloc_pairwise <- coloc_pairwise_abf(views,\n p1 = p1,\n p2 = p2,\n p12 = p12)\n }\n attr(out, \"prob_thresh\") <- prob_thresh\n attr(out, \"method\") <- method\n class(out) <- c(\"susie_post_outcome_configuration\", \"list\")\n out\n}\n\n# -----------------------------------------------------------------------------\n# Input normalisation\n# -----------------------------------------------------------------------------\n\nis_susie_fit <- function(x) {\n inherits(x, \"susie\") || inherits(x, \"mvsusie\") || inherits(x, \"mfsusie\")\n}\n\nnormalise_to_views <- function(input, by, cs_only) {\n fits <- if (is_susie_fit(input)) list(input) else as.list(input)\n\n if (length(fits) == 0L) {\n stop(\"`input` must be a SuSiE-class fit or a non-empty list of fits.\")\n }\n for (k in seq_along(fits)) {\n if (!is_susie_fit(fits[[k]])) {\n stop(\"Element \", k,\n \" of `input` is not a SuSiE-class fit (`susie`, `mvsusie`, or \",\n \"`mfsusie`).\")\n }\n if (cs_only && is.null(fits[[k]]$sets$cs)) {\n stop(\"Fit \", k, \": `cs_only = TRUE` requires `$sets$cs` to be present. \",\n \"Either pass `cs_only = FALSE` or attach a credible-set list via \",\n \"susie_get_cs() before calling.\")\n }\n }\n\n raw_names <- names(fits)\n if (is.null(raw_names)) raw_names <- character(length(fits))\n default_names <- paste0(\"trait_\", seq_along(fits))\n raw_names[!nzchar(raw_names)] <- default_names[!nzchar(raw_names)]\n\n views <- vector(\"list\", 0)\n for (k in seq_along(fits)) {\n views <- c(views, expand_one_fit(fits[[k]], raw_names[k], by = by))\n }\n views\n}\n\nexpand_one_fit <- function(fit, base_name, by) {\n if (by == \"fit\") {\n return(list(make_view(\n name = base_name,\n alpha = fit$alpha,\n lbf = fit$lbf_variable,\n sets_cs = fit$sets$cs\n )))\n }\n\n # by = \"outcome\": multi-output fits fan out; single-output fits pass\n # through as one view.\n if (inherits(fit, \"mvsusie\") || inherits(fit, \"mfsusie\")) {\n if (is.null(fit$lbf_variable_outcome)) {\n stop(\"Fit '\", base_name, \"': `by = \\\"outcome\\\"` requires `$lbf_variable_outcome` \",\n \"(an L x J x R or L x J x M array) on the fit. \",\n \"Refit with `attach_lbf_variable_outcome = TRUE` (the default in mfsusie / \",\n \"mvsusie), or pass `by = \\\"fit\\\"` to use the joint composite log \",\n \"BF instead.\")\n }\n R <- dim(fit$lbf_variable_outcome)[3L]\n out_names <- dimnames(fit$lbf_variable_outcome)[[3L]]\n if (is.null(out_names)) out_names <- paste0(\"outcome_\", seq_len(R))\n views <- vector(\"list\", R)\n for (r in seq_len(R)) {\n views[[r]] <- make_view(\n name = paste0(base_name, \"_\", out_names[r]),\n alpha = fit$alpha,\n lbf = fit$lbf_variable_outcome[, , r, drop = TRUE],\n sets_cs = fit$sets$cs\n )\n }\n return(views)\n }\n\n # Single-output `susie` under by = \"outcome\": same as by = \"fit\".\n list(make_view(\n name = base_name,\n alpha = fit$alpha,\n lbf = fit$lbf_variable,\n sets_cs = fit$sets$cs\n ))\n}\n\nmake_view <- function(name, alpha, lbf, sets_cs) {\n if (is.null(alpha) || is.null(lbf)) {\n stop(\"Trait '\", name, \"': both `$alpha` and `$lbf_variable` (or per-\",\n \"outcome lbf row) must be non-null.\")\n }\n if (!is.matrix(alpha)) alpha <- as.matrix(alpha)\n if (!is.matrix(lbf)) lbf <- as.matrix(lbf)\n if (!identical(dim(alpha), dim(lbf))) {\n stop(\"Trait '\", name, \"': `alpha` and `lbf` must have identical shape; \",\n \"got \", paste(dim(alpha), collapse = \"x\"), \" vs \",\n paste(dim(lbf), collapse = \"x\"), \".\")\n }\n list(name = name, alpha = alpha, lbf = lbf, sets_cs = sets_cs)\n}\n\n# -----------------------------------------------------------------------------\n# CS-tuple enumeration shared by both algorithms.\n# -----------------------------------------------------------------------------\n\n# Per-view CS index set, restricted to $sets$cs when cs_only = TRUE.\nview_cs_indices <- function(view, cs_only) {\n L_n <- nrow(view$alpha)\n if (!cs_only) return(seq_len(L_n))\n\n idx <- attr(view$sets_cs, \"cs_idx\")\n if (is.null(idx)) {\n # Fall back to the names of $sets$cs (\"L1\", \"L2\", ... in susieR's format).\n if (length(view$sets_cs) > 0L && !is.null(names(view$sets_cs))) {\n idx <- as.integer(sub(\"^L\", \"\", names(view$sets_cs)))\n } else {\n idx <- seq_len(L_n)\n }\n }\n idx[idx >= 1L & idx <= L_n]\n}\n\n# Returns a list of length-N integer tuples (one CS index per view).\n# Under by = \"outcome\" all views share CSs and we use the diagonal.\n# Under by = \"fit\" we use the cross-product.\nenumerate_cs_tuples <- function(views, by, cs_only) {\n per_view <- lapply(views, view_cs_indices, cs_only = cs_only)\n if (any(vapply(per_view, length, integer(1)) == 0L)) return(list())\n\n if (by == \"outcome\") {\n common <- Reduce(intersect, per_view)\n lapply(common, function(l) rep.int(l, length(views)))\n } else {\n grid <- expand.grid(per_view, KEEP.OUT.ATTRS = FALSE)\n lapply(seq_len(nrow(grid)), function(i) as.integer(grid[i, , drop = TRUE]))\n }\n}\n\n# -----------------------------------------------------------------------------\n# SuSiEx 2^N configuration enumeration.\n# -----------------------------------------------------------------------------\n\nsusiex_configurations <- function(views, by, prob_thresh,\n max_traits = 20L) {\n N <- length(views)\n if (N > max_traits) {\n stop(\"susiex: N = \", N, \" traits exceeds the safety ceiling (\",\n max_traits, \"); 2^N enumeration would be too large.\")\n }\n\n cs_tuples <- enumerate_cs_tuples(views, by = by, cs_only = TRUE)\n if (length(cs_tuples) == 0L) return(list())\n\n configs <- as.matrix(expand.grid(rep(list(c(0L, 1L)), N)))\n colnames(configs) <- paste0(\"trait_\", seq_len(N))\n trait_names <- vapply(views, function(v) v$name, character(1))\n\n out <- vector(\"list\", length(cs_tuples))\n for (ti in seq_along(cs_tuples)) {\n tuple <- cs_tuples[[ti]]\n\n logBF_trait <- numeric(N)\n skip <- FALSE\n for (n in seq_len(N)) {\n l_n <- tuple[n]\n alpha_row <- views[[n]]$alpha[l_n, ]\n lbf_row <- views[[n]]$lbf [l_n, ]\n if (all(alpha_row == 0)) { skip <- TRUE; break }\n logBF_trait[n] <- sum(alpha_row * lbf_row) # alpha-weighted SNP avg\n }\n if (skip) {\n out[[ti]] <- NULL\n next\n }\n\n logBF_conf <- as.vector(configs %*% logBF_trait)\n maxlog <- max(logBF_conf)\n prob_conf <- exp(logBF_conf - maxlog)\n prob_conf <- prob_conf / sum(prob_conf)\n marginal_prob <- as.vector(crossprod(configs, prob_conf))\n\n out[[ti]] <- list(\n cs_indices = setNames(as.integer(tuple), trait_names),\n logBF_trait = setNames(logBF_trait, trait_names),\n configs = configs,\n config_prob = prob_conf,\n marginal_prob = setNames(marginal_prob, trait_names),\n active = setNames(marginal_prob >= prob_thresh, trait_names)\n )\n }\n\n out[!vapply(out, is.null, logical(1))]\n}\n\n# -----------------------------------------------------------------------------\n# Coloc pairwise ABF (verbatim port of coloc:::combine.abf).\n# -----------------------------------------------------------------------------\n\n# Numerically stable log(sum(exp(x))).\n.logsum <- function(x) {\n m <- max(x)\n m + log(sum(exp(x - m)))\n}\n\n# Numerically stable log(exp(a) - exp(b)) for a > b.\n.logdiff <- function(a, b) {\n m <- max(a, b)\n m + log(exp(a - m) - exp(b - m))\n}\n\n# Compute (PP.H0, PP.H1, PP.H2, PP.H3, PP.H4) from per-SNP log-BF vectors,\n# matching coloc:::combine.abf line-for-line.\ncombine_abf_pair <- function(l1, l2, p1, p2, p12) {\n stopifnot(length(l1) == length(l2))\n lsum <- l1 + l2\n lH0 <- 0\n lH1 <- log(p1) + .logsum(l1)\n lH2 <- log(p2) + .logsum(l2)\n lH3 <- log(p1) + log(p2) +\n .logdiff(.logsum(l1) + .logsum(l2), .logsum(lsum))\n lH4 <- log(p12) + .logsum(lsum)\n all_lH <- c(lH0, lH1, lH2, lH3, lH4)\n pp <- exp(all_lH - .logsum(all_lH))\n names(pp) <- paste0(\"PP.H\", 0:4)\n pp\n}\n\ncoloc_pairwise_abf <- function(views, p1, p2, p12) {\n N <- length(views)\n empty <- data.frame(trait1 = character(0), trait2 = character(0),\n l1 = integer(0), l2 = integer(0),\n hit1 = character(0), hit2 = character(0),\n PP.H0 = numeric(0), PP.H1 = numeric(0),\n PP.H2 = numeric(0), PP.H3 = numeric(0),\n PP.H4 = numeric(0),\n stringsAsFactors = FALSE)\n if (N < 2L) return(empty)\n\n trait_names <- vapply(views, function(v) v$name, character(1))\n rows <- list()\n\n for (a in seq_len(N - 1L)) {\n for (b in (a + 1L):N) {\n L1 <- view_cs_indices(views[[a]], cs_only = TRUE)\n L2 <- view_cs_indices(views[[b]], cs_only = TRUE)\n if (length(L1) == 0L || length(L2) == 0L) next\n\n var_names_a <- colnames(views[[a]]$lbf)\n var_names_b <- colnames(views[[b]]$lbf)\n\n for (i in L1) {\n if (all(views[[a]]$alpha[i, ] == 0)) next\n l1_row <- views[[a]]$lbf[i, ]\n for (j in L2) {\n if (all(views[[b]]$alpha[j, ] == 0)) next\n l2_row <- views[[b]]$lbf[j, ]\n\n pp <- combine_abf_pair(l1_row, l2_row, p1 = p1, p2 = p2, p12 = p12)\n\n hit1 <- if (!is.null(var_names_a)) {\n var_names_a[which.max(l1_row)]\n } else {\n paste0(\"snp_\", which.max(l1_row))\n }\n hit2 <- if (!is.null(var_names_b)) {\n var_names_b[which.max(l2_row)]\n } else {\n paste0(\"snp_\", which.max(l2_row))\n }\n\n rows[[length(rows) + 1L]] <- data.frame(\n trait1 = trait_names[a], trait2 = trait_names[b],\n l1 = i, l2 = j,\n hit1 = hit1, hit2 = hit2,\n PP.H0 = pp[\"PP.H0\"], PP.H1 = pp[\"PP.H1\"],\n PP.H2 = pp[\"PP.H2\"], PP.H3 = pp[\"PP.H3\"],\n PP.H4 = pp[\"PP.H4\"],\n stringsAsFactors = FALSE,\n row.names = NULL\n )\n }\n }\n }\n }\n\n if (length(rows) == 0L) return(empty)\n do.call(rbind, rows)\n}\n# =============================================================================\n# Summary / print methods for `susie_post_outcome_configuration` results.\n# =============================================================================\n#\n# Goals:\n# * Be the one-stop pretty-printer so users almost never have to inspect\n# the raw nested list.\n# * Color-code signal vs. no-signal so the eye reads the table at a glance\n# (BOLD DARK GREEN = active / shared, YELLOW = ambiguous, DIM = below\n# threshold; coloc verdicts H4 = green/bold, H3 = magenta, H1/H2 = blue,\n# H0 = dim).\n# * Filter no-signal rows by default (signal_only = TRUE) and footer the\n# hidden count.\n# * Be robust to malformed / partial input objects: missing fields,\n# missing columns, empty lists, length-mismatched per-trait fields,\n# trait names colliding with reserved column names, etc. None of these\n# should error -- they should degrade gracefully.\n\n# Reserved column names that the SuSiEx tidy table adds. Trait names that\n# collide get a \"trait_\" prefix during materialisation.\n.SUSIEX_RESERVED <- c(\"tuple\", \"top_pattern\", \"top_prob\")\n\n# Coloc PP columns. We tolerate the data.frame missing some, only enforce\n# that PP.H0..PP.H4 are present (the source enforces all five).\n.COLOC_PP_COLS <- c(\"PP.H0\", \"PP.H1\", \"PP.H2\", \"PP.H3\", \"PP.H4\")\n.COLOC_DISPLAY <- c(\"trait1\", \"trait2\", \"l1\", \"l2\", \"hit1\", \"hit2\")\n.COLOC_LABELS <- c(\"H0 no signal\",\n \"H1 trait1-only\",\n \"H2 trait2-only\",\n \"H3 distinct\",\n \"H4 shared\")\n\n#' Summarise a susie_post_outcome_configuration result\n#'\n#' Builds tidy tables from the nested list returned by\n#' [susie_post_outcome_configuration()] and prints them with ANSI color\n#' highlighting via [print.summary.susie_post_outcome_configuration()].\n#' The summary itself is an S3 object: index `$susiex` and\n#' `$coloc_pairwise` to grab the data.frames for downstream use.\n#'\n#' Color encoding (when ANSI colors are available):\n#' \\itemize{\n#' \\item SuSiEx per-trait marginal probability: bold dark green when\n#' `>= prob_thresh` (active), yellow when in\n#' `[ambiguous_lower, prob_thresh)`, dim otherwise. The `active`\n#' logical from the raw result is encoded by color and is not shown\n#' as a separate column.\n#' \\item Coloc verdict: bold dark green for H4 (shared causal), magenta\n#' for H3 (distinct causals), blue for H1 or H2 (single-trait causal),\n#' dim for H0 (no signal). The dominant PP per row is bolded.\n#' }\n#'\n#' Robustness: this method is defensive against malformed input. Empty\n#' lists, NULL components, missing fields, length-mismatched per-trait\n#' vectors, trait names that collide with reserved columns\n#' (`tuple`, `top_pattern`, `top_prob`), and coloc data.frames that\n#' lack some optional columns (`hit1`, `hit2`) all degrade gracefully\n#' rather than erroring.\n#'\n#' @param object Output of [susie_post_outcome_configuration()].\n#' @param prob_thresh Threshold above which `marginal_prob` counts as a\n#' signal (default `0.8`).\n#' @param ambiguous_lower Lower edge of the \"ambiguous\" band for the\n#' SuSiEx color coding: marginals in\n#' `[ambiguous_lower, prob_thresh)` are colored yellow. Default `0.5`.\n#' Set to `prob_thresh` to disable the band.\n#' @param signal_only Logical. If `TRUE` (default), drop CS tuples where\n#' no trait is active and drop coloc rows whose dominant hypothesis is\n#' H0. Pass `FALSE` to keep everything.\n#' @param color One of `\"auto\"` (default; honors [crayon::has_color()]),\n#' `TRUE` (force colors on), or `FALSE` (force them off).\n#' @param ... Ignored.\n#'\n#' @return A list of class `\"summary.susie_post_outcome_configuration\"`\n#' with components:\n#' \\describe{\n#' \\item{`$susiex`}{`data.frame` (or `NULL` when no signals): one row per\n#' CS tuple. Columns: `tuple` (e.g. `\"(1,1,1)\"`), one numeric column\n#' per trait carrying that trait's `marginal_prob`, `top_pattern`\n#' (binary configuration string for the most-probable configuration),\n#' `top_prob` (its probability).}\n#' \\item{`$coloc_pairwise`}{`data.frame` (or `NULL`): the original coloc\n#' table extended with `verdict` (named hypothesis label) and `top_pp`\n#' (the dominant PP value).}\n#' \\item{`$susiex_n_total`, `$susiex_n_kept`, `$coloc_n_total`,\n#' `$coloc_n_kept`}{row counts before and after `signal_only`\n#' filtering, used by the print method to footer hidden rows.}\n#' \\item{`$prob_thresh`, `$ambiguous_lower`, `$signal_only`, `$color`}{\n#' parameters echoed for the print method.}\n#' }\n#'\n#' @seealso [susie_post_outcome_configuration()],\n#' [print.summary.susie_post_outcome_configuration()]\n#'\n#' @method summary susie_post_outcome_configuration\n#' @export summary.susie_post_outcome_configuration\n#' @export\nsummary.susie_post_outcome_configuration <- function(\n object,\n prob_thresh = 0.8,\n ambiguous_lower = 0.5,\n signal_only = TRUE,\n color = \"auto\",\n ...) {\n if (!is.numeric(prob_thresh) || length(prob_thresh) != 1L ||\n !is.finite(prob_thresh) || prob_thresh < 0 || prob_thresh > 1) {\n stop(\"`prob_thresh` must be a single numeric in [0, 1].\")\n }\n if (!is.numeric(ambiguous_lower) || length(ambiguous_lower) != 1L ||\n !is.finite(ambiguous_lower) ||\n ambiguous_lower < 0 || ambiguous_lower > prob_thresh) {\n stop(\"`ambiguous_lower` must be a single numeric in [0, prob_thresh].\")\n }\n if (!is.logical(signal_only) || length(signal_only) != 1L ||\n is.na(signal_only)) {\n stop(\"`signal_only` must be a single logical (TRUE or FALSE).\")\n }\n if (!(isTRUE(color) || isFALSE(color) || identical(color, \"auto\"))) {\n stop(\"`color` must be one of TRUE, FALSE, or \\\"auto\\\".\")\n }\n\n ses <- .summarise_susiex(object$susiex, signal_only, prob_thresh)\n cls <- .summarise_coloc(object$coloc_pairwise, signal_only)\n out <- list(\n susiex = ses$df,\n susiex_n_total = ses$n_total,\n susiex_n_kept = ses$n_kept,\n coloc_pairwise = cls$df,\n coloc_n_total = cls$n_total,\n coloc_n_kept = cls$n_kept,\n prob_thresh = prob_thresh,\n ambiguous_lower = ambiguous_lower,\n signal_only = signal_only,\n color = color\n )\n class(out) <- c(\"summary.susie_post_outcome_configuration\", \"list\")\n out\n}\n\n# Tidy `configs$susiex` (list of CS-tuple result lists) into a data.frame\n# wrapped in a small list with kept/total counts so the print method can\n# tell users what was hidden. Returns NULL `df` when input is empty or\n# fully filtered.\n#\n# Defensive against per-tuple field omissions: a tuple missing\n# `marginal_prob` or `config_prob` is silently skipped. Trait names that\n# collide with reserved columns are prefixed with \"trait_\". Trait sets\n# that vary across tuples are unioned.\n.summarise_susiex <- function(susiex, signal_only, prob_thresh) {\n if (is.null(susiex) || !is.list(susiex) || length(susiex) == 0L) {\n return(list(df = NULL, n_total = 0L, n_kept = 0L))\n }\n n_total <- length(susiex)\n\n # Pull the union of trait names across all tuples (some tuples might be\n # malformed and missing fields; we just skip those).\n trait_names_all <- unique(unlist(lapply(susiex, function(tup) {\n if (is.list(tup) && !is.null(tup$marginal_prob)) {\n names(tup$marginal_prob)\n } else character(0)\n })))\n if (length(trait_names_all) == 0L) {\n return(list(df = NULL, n_total = n_total, n_kept = 0L))\n }\n # Avoid collisions with reserved column names by prefixing.\n trait_cols <- ifelse(trait_names_all %in% .SUSIEX_RESERVED,\n paste0(\"trait_\", trait_names_all),\n trait_names_all)\n trait_cols <- make.unique(trait_cols)\n names(trait_cols) <- trait_names_all # raw -> column-name mapping\n\n rows <- lapply(susiex, function(tup) {\n if (!is.list(tup) || is.null(tup$marginal_prob) ||\n is.null(tup$config_prob) || is.null(tup$configs)) {\n return(NULL)\n }\n mp <- tup$marginal_prob\n if (signal_only) {\n # Re-derive active using current prob_thresh (don't trust the stored\n # active flag, which was computed against the call-time threshold).\n if (!any(is.finite(mp) & mp >= prob_thresh)) return(NULL)\n }\n cp <- tup$config_prob\n if (length(cp) == 0L || !all(is.finite(cp))) return(NULL)\n top_idx <- which.max(cp)\n cfg <- tup$configs\n top_pat <- if (is.matrix(cfg) && nrow(cfg) >= top_idx) {\n paste(cfg[top_idx, ], collapse = \"\")\n } else NA_character_\n cs_idx_str <- if (!is.null(tup$cs_indices)) {\n paste0(\"(\", paste(tup$cs_indices, collapse = \",\"), \")\")\n } else NA_character_\n\n out <- data.frame(tuple = cs_idx_str, stringsAsFactors = FALSE)\n for (raw in trait_names_all) {\n out[[trait_cols[[raw]]]] <- if (raw %in% names(mp)) {\n as.numeric(mp[[raw]])\n } else NA_real_\n }\n out$top_pattern <- top_pat\n out$top_prob <- as.numeric(cp[top_idx])\n out\n })\n rows <- rows[!vapply(rows, is.null, logical(1))]\n if (length(rows) == 0L) {\n return(list(df = NULL, n_total = n_total, n_kept = 0L))\n }\n df <- do.call(rbind, rows)\n rownames(df) <- NULL\n list(df = df, n_total = n_total, n_kept = nrow(df))\n}\n\n# Annotate the coloc data.frame with verdict + dominant PP, and optionally\n# drop rows whose dominant hypothesis is H0. Returns the df and kept/total\n# counts so the print method can footer the hidden count. Tolerates the\n# input data.frame already carrying a `verdict` or `top_pp` column (we\n# overwrite). Errors if any of PP.H0..PP.H4 is missing -- those columns\n# define the algorithm.\n.summarise_coloc <- function(df, signal_only) {\n if (is.null(df) || !is.data.frame(df) || nrow(df) == 0L) {\n return(list(df = NULL, n_total = 0L, n_kept = 0L))\n }\n missing_pp <- setdiff(.COLOC_PP_COLS, colnames(df))\n if (length(missing_pp) > 0L) {\n warning(\"coloc_pairwise table missing required columns: \",\n paste(missing_pp, collapse = \", \"),\n \"; skipping coloc summary.\", call. = FALSE)\n return(list(df = NULL, n_total = nrow(df), n_kept = 0L))\n }\n\n pp_mat <- as.matrix(df[, .COLOC_PP_COLS, drop = FALSE])\n storage.mode(pp_mat) <- \"double\"\n # Rows where every PP is NA / non-finite are unscoreable; treat as H0.\n bad_row <- !apply(pp_mat, 1L, function(r) any(is.finite(r)))\n pp_mat[bad_row, ] <- 0\n pp_mat[bad_row, 1L] <- 1\n\n top <- max.col(pp_mat, ties.method = \"first\")\n df$verdict <- .COLOC_LABELS[top]\n df$top_pp <- pp_mat[cbind(seq_len(nrow(df)), top)]\n n_total <- nrow(df)\n\n if (signal_only) {\n df <- df[top != 1L, , drop = FALSE]\n rownames(df) <- NULL\n }\n if (nrow(df) == 0L) {\n return(list(df = NULL, n_total = n_total, n_kept = 0L))\n }\n list(df = df, n_total = n_total, n_kept = nrow(df))\n}\n\n#' Print a summary.susie_post_outcome_configuration object\n#'\n#' Pretty-prints the tidy tables built by\n#' [summary.susie_post_outcome_configuration()] with optional ANSI color\n#' highlighting. See that page for the color encoding.\n#'\n#' @param x Output of [summary.susie_post_outcome_configuration()].\n#' @param ... Ignored.\n#' @return The input invisibly.\n#'\n#' @seealso [summary.susie_post_outcome_configuration()]\n#'\n#' @method print summary.susie_post_outcome_configuration\n#' @export print.summary.susie_post_outcome_configuration\n#' @export\n#' @importFrom crayon has_color bold silver green yellow blue magenta cyan\nprint.summary.susie_post_outcome_configuration <- function(x, ...) {\n use_color <- isTRUE(x$color) ||\n (identical(x$color, \"auto\") && has_color())\n\n # Force-enable crayon when the caller asked for colors explicitly. Crayon\n # otherwise respects its own global `crayon.enabled` option and may strip\n # ANSI in non-tty contexts (R CMD CHECK, capture.output, knitr) even when\n # the user passed `color = TRUE`.\n if (isTRUE(x$color)) {\n old_opt <- options(crayon.enabled = TRUE)\n on.exit(options(old_opt), add = TRUE)\n }\n\n paint <- if (use_color) {\n function(s, style) style(s)\n } else {\n function(s, style) s\n }\n\n if (is.null(x$susiex) && is.null(x$coloc_pairwise)) {\n cat(\"susie_post_outcome_configuration: no signals to report\",\n if (isTRUE(x$signal_only)) \" (signal_only = TRUE)\" else \"\",\n \"\\n\", sep = \"\")\n return(invisible(x))\n }\n\n if (!is.null(x$susiex) && nrow(x$susiex) > 0L) {\n cat(\"\\n\",\n paint(\"SuSiEx: per-trait marginal P(active) per CS tuple\", bold),\n \"\\n\", sep = \"\")\n cat(paint(sprintf(\n \" prob_thresh = %.2f, ambiguous = [%.2f, %.2f)\",\n x$prob_thresh, x$ambiguous_lower, x$prob_thresh),\n silver), \"\\n\\n\", sep = \"\")\n .print_susiex_table(x$susiex, x$prob_thresh, x$ambiguous_lower, use_color)\n if (isTRUE(x$signal_only) && x$susiex_n_total > x$susiex_n_kept) {\n cat(paint(sprintf(\n \" (%d/%d CS tuples hidden -- no trait above prob_thresh; pass signal_only = FALSE to show)\",\n x$susiex_n_total - x$susiex_n_kept, x$susiex_n_total),\n silver), \"\\n\", sep = \"\")\n }\n }\n\n if (!is.null(x$coloc_pairwise) && nrow(x$coloc_pairwise) > 0L) {\n cat(\"\\n\",\n paint(\"Coloc pairwise: dominant hypothesis per (trait, trait', l1, l2)\",\n bold),\n \"\\n\", sep = \"\")\n cat(paint(\n \" H0 no signal | H1 trait1-only | H2 trait2-only | H3 distinct | H4 shared\",\n silver), \"\\n\\n\", sep = \"\")\n .print_coloc_table(x$coloc_pairwise, use_color)\n if (isTRUE(x$signal_only) && x$coloc_n_total > x$coloc_n_kept) {\n cat(paint(sprintf(\n \" (%d/%d pairs hidden -- H0 dominant; pass signal_only = FALSE to show)\",\n x$coloc_n_total - x$coloc_n_kept, x$coloc_n_total),\n silver), \"\\n\", sep = \"\")\n }\n }\n\n invisible(x)\n}\n\n# ---- table renderers -------------------------------------------------------\n\n.print_susiex_table <- function(df, prob_thresh, ambiguous_lower, use_color) {\n trait_cols <- setdiff(colnames(df), .SUSIEX_RESERVED)\n\n fmt_prob <- function(p) {\n s <- if (is.na(p)) \" NA\" else sprintf(\"%.3f\", p)\n if (!use_color) return(s)\n if (is.na(p)) silver(s)\n else if (p >= prob_thresh) bold(green(s))\n else if (p >= ambiguous_lower) yellow(s)\n else silver(s)\n }\n fmt_pat <- function(pat) {\n if (is.na(pat)) return(\"NA\")\n if (!use_color) return(pat)\n cyan(pat)\n }\n\n hdr <- c(\"CS tuple\", trait_cols, \"top pattern\", \"top P\")\n rows <- lapply(seq_len(nrow(df)), function(i) {\n c(as.character(df$tuple[i]),\n vapply(trait_cols, function(t) fmt_prob(df[[t]][i]), character(1)),\n fmt_pat(df$top_pattern[i]),\n sprintf(\"%.3f\", df$top_prob[i]))\n })\n .print_aligned(hdr, rows)\n}\n\n.print_coloc_table <- function(df, use_color) {\n display_present <- intersect(.COLOC_DISPLAY, colnames(df))\n pp_present <- intersect(.COLOC_PP_COLS, colnames(df))\n\n pp_mat <- as.matrix(df[, pp_present, drop = FALSE])\n storage.mode(pp_mat) <- \"double\"\n top_idx <- max.col(pp_mat, ties.method = \"first\")\n\n fmt_pp <- function(p, is_top) {\n s <- if (is.na(p)) \" NA\" else sprintf(\"%.3f\", p)\n if (!use_color) return(s)\n if (is.na(p)) silver(s)\n else if (is_top) bold(s)\n else s\n }\n fmt_verdict <- function(v) {\n if (is.na(v) || !nzchar(v)) return(if (is.na(v)) \"NA\" else v)\n if (!use_color) return(v)\n style <- switch(\n substr(v, 1L, 2L),\n \"H0\" = silver,\n \"H1\" = blue,\n \"H2\" = blue,\n \"H3\" = magenta,\n \"H4\" = function(s) bold(green(s)),\n identity)\n style(v)\n }\n\n hdr <- c(display_present, pp_present, \"verdict\")\n rows <- lapply(seq_len(nrow(df)), function(i) {\n pp_strs <- vapply(seq_along(pp_present), function(k) {\n fmt_pp(pp_mat[i, k], k == top_idx[i])\n }, character(1))\n c(vapply(display_present, function(col) {\n as.character(df[[col]][i])\n }, character(1)),\n pp_strs,\n fmt_verdict(df$verdict[i]))\n })\n .print_aligned(hdr, rows)\n}\n\n# Width-aware aligned printing. `vwidth` strips ANSI escape sequences so\n# colored cells line up correctly; `pad_to` right-pads to a target width.\n.print_aligned <- function(hdr, rows) {\n vwidth <- function(s) nchar(gsub(\"\\033\\\\[[0-9;]*m\", \"\", s))\n pad_to <- function(s, w) {\n pad <- max(0L, w - vwidth(s))\n paste0(s, strrep(\" \", pad))\n }\n\n ncols <- length(hdr)\n if (length(rows) == 0L) {\n cat(\" \", paste(hdr, collapse = \" \"), \"\\n\", sep = \"\")\n return(invisible())\n }\n widths <- vapply(seq_len(ncols), function(k) {\n body_w <- max(vapply(rows, function(r) vwidth(r[[k]]), integer(1)))\n max(vwidth(hdr[k]), body_w)\n }, integer(1))\n\n cat(\" \",\n paste(vapply(seq_len(ncols), function(k) pad_to(hdr[k], widths[k]),\n character(1)),\n collapse = \" \"),\n \"\\n\", sep = \"\")\n cat(\" \",\n paste(strrep(\"-\", widths), collapse = \" \"),\n \"\\n\", sep = \"\")\n for (r in rows) {\n cat(\" \",\n paste(vapply(seq_len(ncols), function(k) pad_to(r[[k]], widths[k]),\n character(1)),\n collapse = \" \"),\n \"\\n\", sep = \"\")\n }\n invisible()\n}\n" }, { "path": "R/susie_rss_utils.R", "content": "# =============================================================================\n# FUNDAMENTAL COMPUTATIONS\n#\n# Basic mathematical utilities and core RSS computations. These functions\n# handle fundamental operations like sufficient statistics computation and\n# eigenvalue inverse calculations.\n#\n# Functions: compute_suff_stat, compute_Dinv, safe_pd_decomp\n# =============================================================================\n\n# Decompose a symmetric PSD matrix for efficient log-determinant and solve.\n# Uses Cholesky when the matrix is PD (fast, O(r^3/6)). Falls back to\n# eigendecomposition when the matrix is singular (e.g. lambda=0 at simplex\n# vertices in omega optimization), projecting out the null-space.\n#\n# Returns a list with:\n# logdet - log-determinant (only over positive eigenvalues)\n# r_eff - effective rank (number of positive eigenvalues)\n# solve - function(v) that computes S^{-1} v (or pseudoinverse for singular S)\n# solve_z - S^{-1} applied to a specific vector z (precomputed for speed)\n#\n#' @keywords internal\nsafe_pd_decomp <- function(S, z = NULL) {\n r <- nrow(S)\n # Try Cholesky first (fast path)\n L <- tryCatch(chol(S), error = function(e) NULL)\n\n if (!is.null(L)) {\n # Cholesky succeeded: S is PD\n logdet <- 2 * sum(log(diag(L)))\n solve_fn <- function(v) backsolve(L, backsolve(L, v, transpose = TRUE))\n solve_z <- if (!is.null(z)) solve_fn(z) else NULL\n return(list(logdet = logdet, r_eff = r, solve = solve_fn, solve_z = solve_z))\n }\n\n # Cholesky failed: use eigendecomposition (handles singular matrices)\n eig <- eigen(S, symmetric = TRUE)\n d <- pmax(eig$values, 0)\n Q <- eig$vectors\n pos <- d > .Machine$double.eps * max(d)\n d_pos <- d[pos]\n Q_pos <- Q[, pos, drop = FALSE]\n\n logdet <- sum(log(d_pos))\n solve_fn <- function(v) Q_pos %*% (crossprod(Q_pos, v) / d_pos)\n solve_z <- if (!is.null(z)) {\n Qt_z <- crossprod(Q_pos, z)\n Q_pos %*% (Qt_z / d_pos)\n } else NULL\n\n list(logdet = logdet, r_eff = sum(pos), solve = solve_fn, solve_z = solve_z)\n}\n\n\n#' @title Compute sufficient statistics for input to \\code{susie_ss}\n#'\n#' @description Computes the sufficient statistics \\eqn{X'X, X'y, y'y}\n#' and \\eqn{n} after centering (and possibly standardizing) the\n#' columns of \\eqn{X} and centering \\eqn{y} to have mean zero. We also\n#' store the column means of \\eqn{X} and mean of \\eqn{y}.\n#'\n#' @param X An n by p matrix of covariates.\n#'\n#' @param y An n vector.\n#'\n#' @param standardize Logical flag indicating whether to standardize\n#' columns of X to unit variance prior to computing summary data\n#'\n#' @return A list of sufficient statistics (\\code{XtX, Xty, yty, n})\n#' and \\code{X_colmeans}, \\code{y_mean}.\n#'\n#' @importFrom methods as\n#' @importFrom Matrix colMeans\n#' @importFrom Matrix crossprod\n#'\n#' @examples\n#' data(N2finemapping)\n#' ss <- compute_suff_stat(N2finemapping$X, N2finemapping$Y[, 1])\n#'\n#' @export\n#'\ncompute_suff_stat <- function(X, y, standardize = FALSE) {\n y_mean <- mean(y)\n y <- y - y_mean\n n <- nrow(X)\n mu <- colMeans(X)\n s <- compute_colSds(X)\n Xty <- drop(y %*% X)\n XtX <- crossprod(X)\n XtX <- as.matrix(XtX)\n XtX <- XtX - n * tcrossprod(mu)\n if (standardize) {\n XtX <- XtX / s\n XtX <- t(XtX)\n XtX <- XtX / s\n Xty <- Xty / s\n }\n n <- length(y)\n yty <- sum(y^2)\n return(list(\n XtX = XtX, Xty = Xty, yty = yty, n = n,\n y_mean = y_mean, X_colmeans = mu\n ))\n}\n\n# Compute inverse eigenvalues for RSS-lambda methods\n#' @keywords internal\ncompute_Dinv <- function(model, data) {\n eigen_R <- get_eigen_R(data, model)\n Dinv <- 1 / (model$sigma2 * eigen_R$values + data$lambda)\n Dinv[is.infinite(Dinv)] <- 0\n return(Dinv)\n}\n\n# Accessor for eigen_R: check model first (multi-panel), fall through to data\n#' @keywords internal\nget_eigen_R <- function(data, model) {\n if (!is.null(model$eigen_R)) model$eigen_R else data$eigen_R\n}\n\n# Accessor for Vtz: check model first (multi-panel), fall through to data\n#' @keywords internal\nget_Vtz <- function(data, model) {\n if (!is.null(model$Vtz)) model$Vtz else data$Vtz\n}\n\n# =============================================================================\n# RSS MODEL METHODS\n#\n# Core RSS algorithm functions including parameter estimation and model\n# preprocessing. These implement the mathematical framework for RSS-based\n# fine-mapping and handle iteration-specific computations.\n#\n# Functions: estimate_s_rss, precompute_rss_lambda_terms\n# =============================================================================\n\n#' @title Estimate s in \\code{susie_rss} Model Using Regularized LD\n#'\n#' @description The estimated s gives information about the\n#' consistency between the z scores and LD matrix. A larger \\eqn{s}\n#' means there is a strong inconsistency between z scores and LD\n#' matrix. The \\dQuote{null-mle} method obtains mle of \\eqn{s} under\n#' \\eqn{z | R ~ N(0,(1-s)R + s I)}, \\eqn{0 < s < 1}. The\n#' \\dQuote{null-partialmle} method obtains mle of \\eqn{s} under\n#' \\eqn{U^T z | R ~ N(0,s I)}, in which \\eqn{U} is a matrix containing\n#' the of eigenvectors that span the null space of R; that is, the\n#' eigenvectors corresponding to zero eigenvalues of R. The estimated\n#' \\eqn{s} from \\dQuote{null-partialmle} could be greater than 1. The\n#' \\dQuote{null-pseudomle} method obtains mle of \\eqn{s} under\n#' pseudolikelihood \\eqn{L(s) = \\prod_{j=1}^{p} p(z_j | z_{-j}, s,\n#' R)}, \\eqn{0 < s < 1}.\n#'\n#' @param z A p-vector of z scores.\n#'\n#' @param R A p by p symmetric, positive semidefinite correlation\n#' matrix.\n#'\n#' @param n The sample size. (Optional, but highly recommended.)\n#'\n#' @param r_tol Tolerance level for eigenvalue check of positive\n#' semidefinite matrix of R.\n#'\n#' @param method a string specifies the method to estimate \\eqn{s}.\n#'\n#' @return A number between 0 and 1.\n#'\n#' @examples\n#' set.seed(1)\n#' n <- 500\n#' p <- 1000\n#' beta <- rep(0, p)\n#' beta[1:4] <- 0.01\n#' X <- matrix(rnorm(n * p), nrow = n, ncol = p)\n#' X <- scale(X, center = TRUE, scale = TRUE)\n#' y <- drop(X %*% beta + rnorm(n))\n#' input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n#' ss <- univariate_regression(X, y)\n#' R <- cor(X)\n#' attr(R, \"eigen\") <- eigen(R, symmetric = TRUE)\n#' zhat <- with(ss, betahat / sebetahat)\n#'\n#' # Estimate s using the unadjusted z-scores.\n#' s0 <- estimate_s_rss(zhat, R)\n#'\n#' # Estimate s using the adjusted z-scores.\n#' s1 <- estimate_s_rss(zhat, R, n)\n#'\n#' @importFrom stats dnorm\n#' @importFrom stats optim\n#'\n#' @export\n#'\nestimate_s_rss <- function(z, R, n, r_tol = 1e-08, method = \"null-mle\") {\n # Check and process input arguments z, R.\n z[is.na(z)] <- 0\n if (is.null(attr(R, \"eigen\"))) {\n attr(R, \"eigen\") <- eigen(R, symmetric = TRUE)\n }\n eigenld <- attr(R, \"eigen\")\n if (any(eigenld$values < -r_tol)) {\n warning_message(\n \"The matrix R is not positive semidefinite. Negative \",\n \"eigenvalues are set to zero\"\n )\n }\n eigenld$values[eigenld$values < r_tol] <- 0\n\n # Check input n, and adjust the z-scores if n is provided.\n if (missing(n)) {\n warning_message(\n \"Providing the sample size (n), or even a rough estimate of n, \",\n \"is highly recommended. Without n, the implicit assumption is \",\n \"n is large (Inf) and the effect sizes are small (close to zero).\"\n )\n } else if (n <= 1) {\n stop(\"n must be greater than 1\")\n }\n if (!missing(n)) {\n sigma2 <- (n - 1) / (z^2 + n - 2)\n z <- sqrt(sigma2) * z\n }\n\n if (method == \"null-mle\") {\n negloglikelihood <- function(s, ztv, d) {\n 0.5 * sum(log((1 - s) * d + s)) +\n 0.5 * tcrossprod(ztv / ((1 - s) * d + s), ztv)\n }\n s <- optim(0.5,\n fn = negloglikelihood, ztv = crossprod(z, eigenld$vectors),\n d = eigenld$values, method = \"Brent\", lower = 0, upper = 1\n )$par\n } else if (method == \"null-partialmle\") {\n colspace <- which(eigenld$values > 0)\n if (length(colspace) == length(z)) {\n s <- 0\n } else {\n znull <- crossprod(eigenld$vectors[, -colspace], z) # U2^T z\n s <- sum(znull^2) / length(znull)\n }\n } else if (method == \"null-pseudomle\") {\n pseudolikelihood <- function(s, z, eigenld) {\n precision <- eigenld$vectors %*% (t(eigenld$vectors) *\n (1 / ((1 - s) * eigenld$values + s)))\n postmean <- rep(0, length(z))\n postvar <- rep(0, length(z))\n for (i in 1:length(z)) {\n postmean[i] <- -(1 / precision[i, i]) * precision[i, -i] %*% z[-i]\n postvar[i] <- 1 / precision[i, i]\n }\n return(-sum(dnorm(z, mean = postmean, sd = sqrt(postvar), log = TRUE)))\n }\n s <- optim(0.5,\n fn = pseudolikelihood, z = z, eigenld = eigenld,\n method = \"Brent\", lower = 0, upper = 1\n )$par\n } else {\n stop(\"The method is not implemented\")\n }\n return(s)\n}\n\n# Precompute RSS lambda terms that change per IBSS iteration\n#' @keywords internal\nprecompute_rss_lambda_terms <- function(data, model) {\n # Precompute quantities that change per IBSS iteration.\n # When slot_weights (c_hat) are active, Z and zbar are weighted by sw_l\n # so that get_ER2.rss_lambda and the omega evaluator see c_hat-weighted\n # posterior means. diag_postb2 is weighted by sw_l (not sw_l^2) because\n # E[c_l^2] = c_hat_l for Bernoulli.\n sw <- if (!is.null(model$slot_weights)) model$slot_weights else rep(1, nrow(model$alpha))\n model$Z <- sw * model$alpha * model$mu\n model$zbar <- colSums(model$Z)\n model$diag_postb2 <- colSums(sw * model$alpha * model$mu2)\n\n return(model)\n}\n\n# estimate_lambda_bias and apply_inflation_state moved to R/rss_mismatch.R.\n\n# =============================================================================\n# MULTI-PANEL LD MIXTURE\n#\n# Functions for combining K reference LD panels with learnable convex weights.\n# R(omega) = sum_k omega_k R_hat_k, with X_meta = [sqrt(omega_1) X_1; ...].\n#\n# Key functions:\n# form_X_meta -- form composite X from K panels with weights\n# eigen_from_X -- SVD-based eigendecomposition from X matrix\n# precompute_omega_cache -- joint SVD for reduced-basis optimization\n# precompute_omega_iteration -- per-IBSS-iter bilinear forms\n# eval_omega_eloglik_reduced -- O(r^3) Eloglik evaluator (Cholesky)\n# eigen_from_reduced -- recover full p-dim eigen from reduced basis\n# eval_omega_eloglik_R -- O(p^3) reference implementation (testing)\n# optimize_omega -- simplex optimizer (Grid+Brent or Frank-Wolfe)\n# =============================================================================\n\n# Form composite X from K panels with weights omega\n# Pre-allocates output to avoid K intermediate copies\n#' @keywords internal\nform_X_meta <- function(X_list, omega) {\n K <- length(X_list)\n p <- ncol(X_list[[1]])\n nrs <- vapply(X_list, nrow, integer(1))\n X_meta <- matrix(0, sum(nrs), p)\n offset <- 0L\n for (k in seq_len(K)) {\n rows <- offset + seq_len(nrs[k])\n if (omega[k] > 0)\n X_meta[rows, ] <- sqrt(omega[k]) * X_list[[k]]\n offset <- offset + nrs[k]\n }\n X_meta\n}\n\n# SVD-based eigendecomposition from X matrix (X'X = R)\n#' @keywords internal\neigen_from_X <- function(X, p) {\n sv <- svd(X, nu = 0)\n eigen_values <- pmax(sv$d^2, 0)\n eigen_vectors <- sv$v\n if (ncol(eigen_vectors) < p) {\n eigen_vectors <- cbind(eigen_vectors,\n matrix(0, p, p - ncol(eigen_vectors)))\n eigen_values <- c(eigen_values, rep(0, p - length(eigen_values)))\n }\n idx <- order(eigen_values, decreasing = TRUE)\n list(values = eigen_values[idx], vectors = eigen_vectors[, idx])\n}\n\n# Precompute reduced-basis quantities for fast omega optimization.\n#\n# For K panels with reference factor matrices X_k (B_k x p), projects all panel\n# correlations into a joint reduced basis V_s (p x r) where r = rank of\n# [X_1; ...; X_K]. Each Brent evaluation then works on r x r matrices\n# (Cholesky + backsolves) instead of p x p eigendecompositions.\n#\n# Returns a list to be stored in data$omega_cache.\n#' @keywords internal\nprecompute_omega_cache <- function(X_list, z, r_tol = 1e-8) {\n X_stack <- do.call(rbind, X_list)\n sv <- svd(X_stack, nu = 0)\n keep <- sv$d > r_tol\n V_s <- sv$v[, keep, drop = FALSE]\n r <- ncol(V_s)\n\n # Project each panel into reduced basis: A_k = V_s' R_k V_s (r x r)\n A_list <- lapply(X_list, function(Xk) {\n Zk <- Xk %*% V_s\n crossprod(Zk)\n })\n\n list(\n V_s = V_s,\n r = r,\n A_list = A_list,\n Vsz = as.vector(crossprod(V_s, z)),\n z_norm2 = sum(z^2)\n )\n}\n\n# Precompute per-IBSS-iteration quantities for the omega Brent evaluator.\n# Called once per IBSS iteration (not per Brent eval).\n#' @keywords internal\nprecompute_omega_iteration <- function(cache, zbar, diag_postb2, Z) {\n Vsz_bar <- as.vector(crossprod(cache$V_s, zbar))\n ZVs <- Z %*% cache$V_s # L x r\n M_postb2 <- crossprod(cache$V_s * diag_postb2, cache$V_s) # r x r\n\n list(Vsz_bar = Vsz_bar, ZVs = ZVs, M_postb2 = M_postb2)\n}\n\n# Evaluate Eloglik at a candidate omega using reduced basis + Cholesky.\n#\n# Uses precomputed A_k*vector products from precompute_omega_iteration,\n# so per-eval work is dominated by the r x r Cholesky + backsolves.\n#' @keywords internal\neval_omega_eloglik_reduced <- function(cache, omega, iter_cache,\n sigma2, lambda, K, p) {\n r <- cache$r\n\n # Form A(omega) = sum_k omega_k A_k once; reused for all terms\n A_omega <- omega[1] * cache$A_list[[1]]\n for (k in seq_len(K)[-1])\n A_omega <- A_omega + omega[k] * cache$A_list[[k]]\n\n # S_r = sigma2 * A(omega) + lambda * I_r\n # Uses safe_pd_decomp: Cholesky when PD, eigen fallback when singular\n # (lambda=0 at simplex vertices where one panel's weight = 0).\n S_r <- sigma2 * A_omega + lambda * diag(r)\n decomp <- safe_pd_decomp(S_r, z = cache$Vsz)\n Sinv_Vsz <- decomp$solve_z\n solve_S <- decomp$solve\n\n # log|S|: column-space from decomp, null-space from lambda (if > 0)\n logdet_null <- if (lambda > 0) (p - r) * log(lambda) else 0\n logdet_term <- -0.5 * (decomp$logdet + logdet_null)\n\n # z^T S^{-1} z: null-space term only when lambda > 0\n z_null_norm2 <- max(cache$z_norm2 - sum(cache$Vsz^2), 0)\n zSinvz <- sum(cache$Vsz * Sinv_Vsz)\n if (lambda > 0) zSinvz <- zSinvz + z_null_norm2 / lambda\n\n # Effective dimension: full p when lambda > 0 (null-space contributes),\n # only the effective rank of S_r when lambda = 0.\n p_eff <- if (lambda > 0) p else decomp$r_eff\n\n # term2: -2 * zbar' R(omega) S^{-1} z\n RSinvz_r <- A_omega %*% Sinv_Vsz\n term2 <- -2 * sum(iter_cache$Vsz_bar * RSinvz_r)\n\n # term3: zbar' R(omega) S^{-1} R(omega) zbar\n A_Vsz_bar <- A_omega %*% iter_cache$Vsz_bar\n Sinv_A_Vsz_bar <- solve_S(A_Vsz_bar)\n term3 <- sum(A_Vsz_bar * Sinv_A_Vsz_bar)\n\n # term4: -tr(Z' R(omega) S^{-1} R(omega) Z)\n A_ZVs_t <- A_omega %*% t(iter_cache$ZVs)\n Sinv_A_ZVs_t <- solve_S(A_ZVs_t)\n term4 <- -sum(A_ZVs_t * Sinv_A_ZVs_t)\n\n # term5: tr(diag(postb2) R(omega) S^{-1} R(omega))\n AMA_omega <- A_omega %*% iter_cache$M_postb2 %*% A_omega\n Sinv_AMA <- solve_S(AMA_omega)\n term5 <- sum(diag(Sinv_AMA))\n\n ER2 <- zSinvz + term2 + term3 + term4 + term5\n # Always include the column-space log|S(omega)|: it is omega-dependent and\n # is the primary driver of mixture weight selection. At lambda=0 the\n # null-space pieces (logdet_null, z_null_norm2/lambda) are constants in\n # omega given the joint reduced basis, so dropping them is fine --- but\n # dropping logdet_term itself erases the omega signal.\n -p_eff / 2 * log(2 * pi) + logdet_term - 0.5 * ER2\n}\n\n# Recover full eigendecomposition from reduced basis after omega is chosen.\n# Called once per IBSS iteration (after Brent converges), not per eval.\n#' @keywords internal\neigen_from_reduced <- function(cache, omega, K, p) {\n A_omega <- omega[1] * cache$A_list[[1]]\n for (k in seq_len(K)[-1])\n A_omega <- A_omega + omega[k] * cache$A_list[[k]]\n\n eig <- eigen(0.5 * (A_omega + t(A_omega)), symmetric = TRUE)\n d <- pmax(eig$values, 0)\n V_full <- cache$V_s %*% eig$vectors\n\n if (cache$r < p) {\n V_full <- cbind(V_full, matrix(0, p, p - cache$r))\n d <- c(d, rep(0, p - cache$r))\n }\n\n list(values = d, vectors = V_full)\n}\n\n# Naive O(p^3) Eloglik evaluator (used for testing and as reference).\n# Forms R(omega), eigendecomposes the p x p matrix, evaluates Eloglik.\n#' @keywords internal\neval_omega_eloglik_R <- function(panel_R, omega, z, zbar, diag_postb2, Z,\n sigma2, lambda, K, p) {\n # Form R(omega) = sum_k omega_k R_k\n R_omega <- omega[1] * panel_R[[1]]\n for (k in seq_len(K)[-1]) R_omega <- R_omega + omega[k] * panel_R[[k]]\n R_omega <- 0.5 * (R_omega + t(R_omega))\n\n # Eigendecompose\n eig <- eigen(R_omega, symmetric = TRUE)\n D <- pmax(eig$values, 0)\n V <- eig$vectors\n\n # Eloglik computation\n Vtz <- crossprod(V, z)\n z_null_norm2 <- max(sum(z^2) - sum(Vtz^2), 0)\n S_diag <- sigma2 * D + lambda\n Dinv <- ifelse(S_diag > 0, 1 / S_diag, 0)\n DinvD2 <- Dinv * D^2\n\n # When lambda=0, skip zero entries in log-det and null-space terms\n S_pos <- S_diag[S_diag > 0]\n logdet_term <- -0.5 * sum(log(S_pos))\n zSinvz <- sum(Dinv * Vtz^2)\n if (lambda > 0) zSinvz <- zSinvz + z_null_norm2 / lambda\n\n RSinvz <- V %*% (Dinv * D * Vtz)\n term2 <- -2 * sum(zbar * RSinvz)\n\n Vtzbar <- crossprod(V, zbar)\n term3 <- sum(Vtzbar^2 * DinvD2)\n\n ZV <- Z %*% V\n term4 <- -sum(ZV^2 %*% DinvD2)\n\n diag_RSinvR <- colSums(t(V)^2 * DinvD2)\n term5 <- sum(diag_RSinvR * diag_postb2)\n\n ER2 <- zSinvz + term2 + term3 + term4 + term5\n p_eff <- length(S_pos)\n # See eval_omega_eloglik_reduced: always keep column-space logdet_term.\n -p_eff / 2 * log(2 * pi) + logdet_term - 0.5 * ER2\n}\n\n# Optimize omega on the K-simplex by maximizing eval_fn.\n# Uses the Frank-Wolfe conditional gradient algorithm: each iteration\n# evaluates the objective at all K simplex vertices to find the steepest\n# ascent direction, then performs a line search (Brent's method) toward\n# that vertex. For K=2 a coarse grid warm-start is prepended since the\n# simplex is 1D and the grid cost is negligible.\n# Returns list(omega, converged) where converged indicates max|delta| < tol.\n#' @keywords internal\n#' @importFrom stats optimize\noptimize_omega <- function(eval_fn, omega_cur, K,\n tol = .omega_tol) {\n omega <- omega_cur\n cur_val <- eval_fn(omega)\n\n # K=2 warm-start: coarse grid over the 1D simplex\n if (K == 2) {\n grid <- seq(0, 1, tol$grid_spacing)\n vals <- vapply(grid, function(w1) eval_fn(c(w1, 1 - w1)), numeric(1))\n best_w1 <- grid[which.max(vals)]\n omega <- c(best_w1, 1 - best_w1)\n cur_val <- max(vals)\n }\n\n # Frank-Wolfe: conditional gradient on simplex with Brent line search.\n # For K=2 the grid already evaluated the vertices; cache them.\n vertex_cache <- if (K == 2) c(vals[1], vals[length(vals)]) else NULL\n for (fw_iter in seq_len(tol$fw_max_iter)) {\n vertex_vals <- if (!is.null(vertex_cache)) {\n vertex_cache\n } else {\n vapply(seq_len(K), function(k) {\n e_k <- rep(0, K); e_k[k] <- 1; eval_fn(e_k)\n }, numeric(1))\n }\n vertex_cache <- NULL # only reuse on first iteration\n k_star <- which.max(vertex_vals)\n s <- rep(0, K); s[k_star] <- 1\n opt <- optimize(function(gamma) eval_fn((1 - gamma) * omega + gamma * s),\n interval = c(0, 1), maximum = TRUE)\n # Absolute improvement check: conservative for large negative Eloglik values\n if (opt$objective - cur_val < tol$fw_stop) break\n omega <- (1 - opt$maximum) * omega + opt$maximum * s\n cur_val <- opt$objective\n }\n\n converged <- max(abs(omega - omega_cur)) < tol$convergence\n list(omega = omega, converged = converged)\n}\n\n# =============================================================================\n# DIAGNOSTIC & QUALITY CONTROL\n#\n# Functions for RSS model diagnostics, data quality assessment, and\n# validation. These help users assess the compatibility between z-scores\n# and LD matrices and identify potential data issues.\n#\n# Functions: kriging_rss\n# =============================================================================\n\n#' @title Compute Distribution of z-scores of Variant j Given Other z-scores, and Detect Possible Allele Switch Issue\n#'\n#' @description Under the null, the rss model with regularized LD\n#' matrix is \\eqn{z|R,s ~ N(0, (1-s)R + s I))}. We use a mixture of\n#' normals to model the conditional distribution of z_j given other z\n#' scores, \\eqn{z_j | z_{-j}, R, s ~ \\sum_{k=1}^{K} \\pi_k\n#' N(-\\Omega_{j,-j} z_{-j}/\\Omega_{jj}, \\sigma_{k}^2/\\Omega_{jj})},\n#' \\eqn{\\Omega = ((1-s)R + sI)^{-1}}, \\eqn{\\sigma_1, ..., \\sigma_k}\n#' is a grid of fixed positive numbers. We estimate the mixture\n#' weights \\eqn{\\pi} We detect the possible allele switch issue\n#' using likelihood ratio for each variant.\n#'\n#' @param z A p-vector of z scores.\n#'\n#' @param R A p by p symmetric, positive semidefinite correlation\n#' matrix.\n#'\n#' @param n The sample size. (Optional, but highly recommended.)\n#'\n#' @param r_tol Tolerance level for eigenvalue check of positive\n#' semidefinite matrix of R.\n#'\n#' @param s an estimated s from \\code{estimate_s_rss}\n#'\n#' @return a list containing a ggplot2 plot object and a table. The plot\n#' compares observed z score vs the expected value. The possible allele\n#' switched variants are labeled as red points (log LR > 2 and abs(z) > 2).\n#' The table summarizes the conditional distribution for each variant\n#' and the likelihood ratio test. The table has the following columns:\n#' the observed z scores, the conditional expectation, the conditional\n#' variance, the standardized differences between the observed z score\n#' and expected value, the log likelihood ratio statistics.\n#'\n#' @importFrom stats dnorm\n#' @importFrom ggplot2 ggplot\n#' @importFrom ggplot2 geom_point\n#' @importFrom ggplot2 geom_abline\n#' @importFrom ggplot2 theme_bw\n#' @importFrom ggplot2 labs\n#' @importFrom ggplot2 aes_string\n#' @importFrom mixsqp mixsqp\n#'\n#' @examples\n#' # See also the vignette, \"Diagnostic for fine-mapping with summary\n#' # statistics.\"\n#' set.seed(1)\n#' n <- 500\n#' p <- 1000\n#' beta <- rep(0, p)\n#' beta[1:4] <- 0.01\n#' X <- matrix(rnorm(n * p), nrow = n, ncol = p)\n#' X <- scale(X, center = TRUE, scale = TRUE)\n#' y <- drop(X %*% beta + rnorm(n))\n#' ss <- univariate_regression(X, y)\n#' R <- cor(X)\n#' attr(R, \"eigen\") <- eigen(R, symmetric = TRUE)\n#' zhat <- with(ss, betahat / sebetahat)\n#' cond_dist <- kriging_rss(zhat, R, n = n)\n#' cond_dist$plot\n#'\n#' @export\n#'\nkriging_rss <- function(z, R, n, r_tol = 1e-08,\n s = estimate_s_rss(z, R, n, r_tol, method = \"null-mle\")) {\n # Check and process input arguments z, R.\n z[is.na(z)] <- 0\n if (is.null(attr(R, \"eigen\"))) {\n attr(R, \"eigen\") <- eigen(R, symmetric = TRUE)\n }\n eigenld <- attr(R, \"eigen\")\n if (any(eigenld$values < -r_tol)) {\n warning_message(\n \"The matrix R is not positive semidefinite. Negative \",\n \"eigenvalues are set to zero.\"\n )\n }\n eigenld$values[eigenld$values < r_tol] <- 0\n\n # Check and progress input argument s.\n force(s)\n if (s > 1) {\n warning_message(\"The given s is greater than 1. We replace it with 0.8.\")\n s <- 0.8\n } else if (s < 0) {\n stop(\"The s must be non-negative\")\n }\n\n # Check input n, and adjust the z-scores if n is provided.\n if ((!missing(n)) && (n <= 1)) {\n stop(\"n must be greater than 1\")\n }\n if (missing(n)) {\n warning_message(\n \"Providing the sample size (n), or even a rough estimate of n, \",\n \"is highly recommended. Without n, the implicit assumption is \",\n \"n is large (Inf) and the effect sizes are small (close to zero).\"\n )\n } else {\n sigma2 <- (n - 1) / (z^2 + n - 2)\n z <- sqrt(sigma2) * z\n }\n\n dinv <- 1 / ((1 - s) * eigenld$values + s)\n dinv[is.infinite(dinv)] <- 0\n precision <- eigenld$vectors %*% (t(eigenld$vectors) * dinv)\n condmean <- rep(0, length(z))\n condvar <- rep(0, length(z))\n for (i in 1:length(z)) {\n condmean[i] <- -(1 / precision[i, i]) * precision[i, -i] %*% z[-i]\n condvar[i] <- 1 / precision[i, i]\n }\n z_std_diff <- (z - condmean) / sqrt(condvar)\n\n # obtain grid\n a_min <- 0.8\n if (max(z_std_diff^2) < 1) {\n a_max <- 2\n } else {\n a_max <- 2 * sqrt(max(z_std_diff^2))\n }\n npoint <- ceiling(log2(a_max / a_min) / log2(1.05))\n a_grid <- 1.05^(seq(-npoint, 0)) * a_max\n\n # compute likelihood\n sd_mtx <- outer(sqrt(condvar), a_grid)\n matrix_llik <- dnorm(z - condmean, sd = sd_mtx, log = TRUE)\n lfactors <- apply(matrix_llik, 1, max)\n matrix_llik <- matrix_llik - lfactors\n\n # estimate weight\n w <- mixsqp(matrix_llik, log = TRUE, control = list(verbose = FALSE))$x\n\n # Compute denominators in likelihood ratios.\n logl0mix <- drop(log(exp(matrix_llik) %*% (w + 1e-15))) + lfactors\n\n # Compute numerators in likelihood ratios.\n matrix_llik <- dnorm(z + condmean, sd = sd_mtx, log = TRUE)\n lfactors <- apply(matrix_llik, 1, max)\n matrix_llik <- matrix_llik - lfactors\n logl1mix <- drop(log(exp(matrix_llik) %*% (w + 1e-15))) + lfactors\n\n # Compute (log) likelihood ratios.\n logLRmix <- logl1mix - logl0mix\n\n z <- drop(z)\n z_std_diff <- drop(z_std_diff)\n res <- data.frame(\n z = z,\n condmean = condmean,\n condvar = condvar,\n z_std_diff = z_std_diff,\n logLR = logLRmix\n )\n p <- ggplot(res, aes(y = .data$z, x = .data$condmean)) +\n geom_point() +\n labs(y = \"Observed z scores\", x = \"Expected value\") +\n geom_abline(intercept = 0, slope = 1) +\n theme_bw()\n idx <- which(logLRmix > 2 & abs(z) > 2)\n if (length(idx) > 0) {\n p <- p + geom_point(\n data = res[idx, ],\n aes(y = .data$z, x = .data$condmean), col = \"red\"\n )\n }\n return(list(plot = p, conditional_dist = res))\n}\n" }, { "path": "R/susie_trendfilter.R", "content": "#' @title Apply susie to trend filtering (especially changepoint\n#' problems), a type of non-parametric regression.\n#'\n#' @description Fits the non-parametric Gaussian regression model\n#' \\eqn{y = mu + e}, where the mean \\eqn{mu} is modelled as \\eqn{mu =\n#' Xb}, X is a matrix with columns containing an appropriate basis,\n#' and b is vector with a (sparse) SuSiE prior. In particular, when\n#' \\code{order = 0}, the jth column of X is a vector with the first j\n#' elements equal to zero, and the remaining elements equal to 1, so\n#' that \\eqn{b_j} corresponds to the change in the mean of y between\n#' indices j and j+1. For background on trend filtering, see\n#' Tibshirani (2014). See also the \"Trend filtering\" vignette,\n#' \\code{vignette(\"trend_filtering\")}.\n#'\n#' @details This implementation exploits the special structure of X,\n#' which means that the matrix-vector product \\eqn{X^Ty} is fast to\n#' compute; in particular, the computation time is \\eqn{O(n)} rather\n#' than \\eqn{O(n^2)} if \\code{X} were formed explicitly. For\n#' implementation details, see the \"Implementation of SuSiE trend\n#' filtering\" vignette by running\n#' \\code{vignette(\"trendfiltering_derivations\")}.\n#'\n#' @param y An n-vector of observations ordered in time or space\n#' (assumed to be equally spaced).\n#'\n#' @param order An integer specifying the order of trend filtering.\n#' The default, \\code{order = 0}, corresponds to \"changepoint\"\n#' problems (\\emph{i.e.}, piecewise constant \\eqn{mu}). Although\n#' \\code{order > 0} is implemented, we do not recommend its use; in\n#' practice, we have found problems with convergence of the algorithm\n#' to poor local optima, producing unreliable inferences.\n#'\n#' @param standardize Logical indicating whether to standardize the X\n#' variables (\"basis functions\"); \\code{standardize = FALSE} is\n#' recommended as these basis functions already have a natural scale.\n#'\n#' @param use_mad Logical indicating whether to use the \"median\n#' absolute deviation\" (MAD) method to the estimate residual\n#' variance. If \\code{use_mad = TRUE}, susie is run twice, first by\n#' fixing the residual variance to the MAD value, then a second time,\n#' initialized to the first fit, but with residual variance estimated\n#' the usual way (by maximizing the ELBO). We have found this strategy\n#' typically improves reliability of the results by reducing a\n#' tendency to converge to poor local optima of the ELBO.\n#'\n#' @param ... Other arguments passed to \\code{\\link{susie}}.\n#'\n#' @return A \"susie\" fit; see \\code{\\link{susie}} for details.\n#'\n#' @references R. J. Tibshirani (2014). Adaptive piecewise polynomial\n#' estimation via trend filtering. \\emph{Annals of Statistics}\n#' \\bold{42}, 285-323.\n#'\n#' @examples\n#' set.seed(1)\n#' mu <- c(rep(0, 50), rep(1, 50), rep(3, 50), rep(-2, 50), rep(0, 200))\n#' y <- mu + rnorm(400)\n#' s <- susie_trendfilter(y)\n#' plot(y)\n#' lines(mu, col = 1, lwd = 3)\n#' lines(predict(s), col = 2, lwd = 2)\n#'\n#' # Calculate credible sets (indices of y that occur just before\n#' # changepoints).\n#' susie_get_cs(s)\n#'\n#' # Plot with credible sets for changepoints.\n#' susie_plot_changepoint(s, y)\n#'\n#' @importFrom Matrix sparseMatrix\n#'\n#' @export\n#'\nsusie_trendfilter <- function(y, order = 0, standardize = FALSE,\n use_mad = TRUE, ...) {\n if (order > 0) {\n warning_message(\"order > 0 is not recommended\")\n }\n n <- length(y)\n X <- sparseMatrix(i = NULL, j = NULL, dims = c(n, n))\n attr(X, \"matrix.type\") <- \"tfmatrix\"\n attr(X, \"order\") <- order\n if (use_mad && !(\"model_init\" %in% names(list(...)))) {\n mad <- estimate_mad_residual_variance(y)\n s_mad_init <- suppressWarnings(susie(\n X = X, y = y, standardize = standardize,\n estimate_residual_variance = FALSE, residual_variance = mad, ...\n ))\n s <- susie(X = X, y = y, standardize = standardize, model_init = s_mad_init, ...)\n } else {\n s <- susie(X = X, y = y, standardize = standardize, ...)\n }\n return(s)\n}\n\n# @title estimate residual variance using MAD estimator\n# @param y an n-vector\n# @return a scalar of estimated residual variance\nestimate_mad_residual_variance <- function(y) {\n sigma2 <- 0.5 * (median(abs(diff(y)) / 0.6745)^2)\n if (sigma2 == 0) {\n stop(\"Cannot use median absolute deviation (MAD) to initialize residual variance because MAD = 0 for the input data. Please set 'use_mad = FALSE'\")\n }\n return(sigma2)\n}" }, { "path": "R/susie_trendfilter_utils.R", "content": "# @title Compute unscaled X %*% b using the special structure of trend\n# filtering\n# @param order is the order of trend filtering\n# @param b an n=p vector\n# @return an n vector\ncompute_tf_Xb <- function(order, b) {\n for (i in 1:(order + 1)) {\n b <- rev(-1 * cumsum(rev(b)))\n }\n return(b)\n}\n\n# @title Compute unscaled t(X) %*% y using the special structure of\n# trend filtering\n# @param order is the order of trend filtering\n# @param y an n vector\n# @return an n vector\ncompute_tf_Xty <- function(order, y) {\n for (i in 1:(order + 1)) {\n y <- -1 * cumsum(y)\n }\n return(y)\n}\n\n# @title Compute colSums(X*X) for X under four scenarios\n# @param order is the order of trend filtering\n# @param n the length of y\n# @param cm column means of X\n# @param csd column standard deviations of X\n# @param intercept a boolean denotes whether mean centering X\n# @param standardize a boolean denotes whether scaling X by standard deviation\n# @return an n vector\ncompute_tf_d <- function(order, n, cm, csd, standardize = FALSE,\n intercept = FALSE) {\n if (intercept) {\n # When standardize = TRUE, intercept = TRUE: by special\n # observation d = [n-1, n-1, ...]\n d <- rep(n - 1, n)\n if (order == 0) {\n d[n] <- 0\n }\n\n # When standardize = FALSE, intercept = TRUE:\n # d = [n-1, n-1, ...] * (csd^2)\n if (!standardize) {\n d <- d * csd^2\n }\n return(d)\n } else {\n # When standardize = FALSE, intercept = FALSE: d = colSums(X^2)\n base <- rep(-1, n)\n if (order == 0) {\n d <- cumsum(base^2)\n } else {\n for (i in 1:order) {\n base <- cumsum(base)\n }\n d <- cumsum(base^2)\n }\n\n # When standardize = TRUE, intercept = TRUE:\n # d = colSums(X^2) / (csd^2)\n if (standardize) {\n d <- d / csd^2\n }\n return(d)\n }\n}\n\n# @title Compute column mean of the trend filtering matrix X.\n# @param order is the order of trend filtering\n# @param n the length of y\n# @return an n vector\ncompute_tf_cm <- function(order, n) {\n base <- rep(1, n)\n for (i in 1:(order + 1)) {\n base <- -cumsum(base)\n }\n return(base / n)\n}\n\n# @title Compute column standard deviation of the trend filtering\n# matrix X\n# @param order is the order of trend filtering\n# @param n is the length of y\n# @return an n vector\ncompute_tf_csd <- function(order, n) {\n cm <- compute_tf_cm(order, n)\n csd <- sqrt((compute_tf_d(order, n) / n - cm^2) * n / (n - 1))\n csd[which(csd == 0)] <- 1\n return(csd)\n}\n\n# @title A fast way to compute colSums(X*X), where X is a\n# mean-centered and standardized trend filtering matrix.\n# @param order order of trend filtering\n# @param n the length of y\n# @return an n vector\ncompute_tf_std_d <- function(order, n) {\n res <- rep(n - 1, n)\n if (order == 0) {\n res[n] <- 0\n }\n return(res)\n}\n" }, { "path": "R/susie_utils.R", "content": "# =============================================================================\n# FUNDAMENTAL BUILDING BLOCKS\n#\n# Basic mathematical operations and utilities that serve as dependencies\n# for other functions. These include matrix operations, statistical computations,\n# and general-purpose helper functions.\n#\n# Functions: warning_message, safe_cor, safe_cov2cor, is_symmetric_matrix,\n# apply_nonzeros, compute_colSds, compute_colstats\n# =============================================================================\n\n# Report R process memory usage (GB). Uses gc() which is cheap.\n#' @keywords internal\nmem_used_gb <- function() {\n gc_info <- gc(verbose = FALSE, reset = FALSE)\n sum(gc_info[, \"(Mb)\"]) / 1024\n}\n\n# Format prior variance vector: show non-zero values, summarize zeros.\n# E.g., \"[1.23e-01, 5.34e-02, 0 x 3]\"\n#' @keywords internal\nformat_V_summary <- function(V) {\n n_na <- sum(is.na(V))\n V_nona <- V[!is.na(V)]\n n_zero <- sum(V_nona == 0)\n nz <- V_nona[V_nona != 0]\n parts <- sprintf(\"%.2e\", nz)\n if (n_zero > 0) parts <- c(parts, sprintf(\"0 x %d\", n_zero))\n if (n_na > 0) parts <- c(parts, sprintf(\"NA x %d\", n_na))\n paste0(\"[\", paste(parts, collapse = \", \"), \"]\")\n}\n\n# Format slot activity (c_hat) summary for verbose output.\n# Shows per-slot c_hat values and lbf when active, empty string when not.\n# E.g., \", c_hat=[0.99,0.87,0.12,0.45], lbf=[12.3,8.1,0.0,-0.2], C_hat=2.4\"\n#' @keywords internal\nformat_chat_summary <- function(model) {\n if (is.null(model$slot_weights)) return(\"\")\n sw <- model$slot_weights\n lbf <- model$lbf\n lbf[is.na(lbf)] <- 0\n chat_vals <- paste(sprintf(\"%.2f\", sw), collapse = \",\")\n lbf_vals <- paste(sprintf(\"%.1f\", lbf), collapse = \",\")\n n_active <- sum(sw > 0.5)\n sprintf(\", c_hat=[%s], lbf=[%s], C_hat=%.1f(%d>0.5)\",\n chat_vals, lbf_vals, sum(sw), n_active)\n}\n\n# Utility function to display warning messages as they occur\n#' @importFrom crayon combine_styles\n#' @keywords internal\nwarning_message <- function(..., style = c(\"warning\", \"hint\")) {\n style <- match.arg(style)\n if (style == \"warning\" && getOption(\"warn\") >= 0) {\n alert <- combine_styles(\"bold\", \"underline\", \"red\")\n message(alert(\"WARNING:\"), \" \", ...)\n } else {\n alert <- combine_styles(\"bold\", \"underline\", \"magenta\")\n message(alert(\"HINT:\"), \" \", ...)\n }\n}\n\n#' Converts covariance matrix to correlation matrix\n#' Constant variables (zero variance) get correlation 0 with others, 1 with self\n#'\n#' @param V Covariance matrix\n#' @return Correlation matrix\n#' @keywords internal\nsafe_cov2cor <- function(V) {\n d <- sqrt(diag(V))\n d_inv <- 1 / d\n d_inv[d == 0] <- 0\n R <- V * outer(d_inv, d_inv)\n diag(R) <- 1\n R\n}\n\n#' Computes correlation matrix from data matrix\n#' Handles constant columns without warnings - returns 0 correlation for constant cols\n#' Uses Rfast::cora when available (much faster for large matrices), falls back\n#' to crossprod-based computation otherwise.\n#'\n#' @param X Data matrix (n x p)\n#' @return Correlation matrix (p x p)\n#' @keywords internal\nsafe_cor <- function(X) {\n n <- nrow(X)\n cm <- colMeans(X)\n css <- colSums(X^2) - n * cm^2 # column sum of squares (centered)\n has_const <- any(css == 0)\n\n # Fast path: use Rfast::cora when available and no constant columns\n if (!has_const && requireNamespace(\"Rfast\", quietly = TRUE)) {\n return(Rfast::cora(X))\n }\n\n # Fallback: manual crossprod, handling constant columns\n X_centered <- X - rep(cm, each = n)\n sds <- sqrt(css / n)\n sds_inv <- 1 / sds\n sds_inv[sds == 0] <- 0\n X_scaled <- X_centered * rep(sds_inv, each = n)\n R <- crossprod(X_scaled) / n\n diag(R) <- 1\n R\n}\n\n# Standardize X so that X'X equals the correlation matrix R.\n# Centers columns, divides by column sd, then scales by 1/sqrt(n)\n# so that crossprod(X_out) = cor(X_in). Constant columns are zeroed.\n# This is the in-place analog of safe_cor: safe_cor(X) == crossprod(standardize_X(X)).\n#' @keywords internal\nstandardize_X <- function(X) {\n n <- nrow(X)\n cm <- colMeans(X)\n X <- X - rep(cm, each = n)\n css <- colSums(X^2)\n sds <- sqrt(css / n)\n sds[sds < .Machine$double.eps] <- 1 # constant columns: avoid 0/0\n X <- X * rep(1 / (sds * sqrt(n)), each = n)\n X\n}\n\n#' Check for symmetric matrix\n#'\n#' @param x A matrix to check\n#' @return Logical indicating if x is symmetric\n#' @export\n#' @keywords internal\nis_symmetric_matrix <- function(x) {\n if (is.matrix(x) && is.numeric(x) && !isS4(x) &&\n requireNamespace(\"Rfast\", quietly = TRUE)) {\n return(Rfast::is.symmetric(x))\n } else {\n return(Matrix::isSymmetric(x, check.attributes = FALSE))\n }\n}\n\n# Apply operation f to all nonzeros of a sparse matrix.\n#' @importFrom Matrix sparseMatrix\n#' @importFrom Matrix summary\n#' @keywords internal\napply_nonzeros <- function(X, f) {\n d <- summary(X)\n return(sparseMatrix(i = d$i, j = d$j, x = f(d$x), dims = dim(X)))\n}\n\n# Computes column standard deviations for any type of matrix\n# This should give the same result as matrixStats::colSds(X),\n# but allows for sparse matrices as well as dense ones.\n#' @importFrom matrixStats colSds\n#' @importFrom Matrix summary\n#' @keywords internal\ncompute_colSds <- function(X) {\n if (is.matrix(X)) {\n return(colSds(X))\n } else {\n n <- nrow(X)\n Y <- apply_nonzeros(X, function(u) u^2)\n d <- colMeans(Y) - colMeans(X)^2\n return(sqrt(d * n / (n - 1)))\n }\n}\n\n# Compute the column means of X, the column standard deviations of X,\n# and rowSums(Y^2), where Y is the centered and/or scaled version of\n# X.\n#\n#' @importFrom Matrix rowSums\n#' @importFrom Matrix colMeans\n#' @keywords internal\ncompute_colstats <- function(X, center = TRUE, scale = TRUE) {\n n <- nrow(X)\n p <- ncol(X)\n if (!is.null(attr(X, \"matrix.type\"))) {\n # X is a trend filtering matrix.\n cm <- compute_tf_cm(attr(X, \"order\"), p)\n csd <- compute_tf_csd(attr(X, \"order\"), p)\n d <- compute_tf_d(attr(X, \"order\"), p, cm, csd, scale, center)\n if (!center) {\n cm <- rep(0, p)\n }\n if (!scale) {\n csd <- rep(1, p)\n }\n } else {\n # X is an ordinary dense or sparse matrix. Set sd = 1 when the\n # column has variance 0.\n if (center) {\n cm <- colMeans(X, na.rm = TRUE)\n } else {\n cm <- rep(0, p)\n }\n if (scale) {\n csd <- compute_colSds(X)\n csd[csd == 0] <- 1\n } else {\n csd <- rep(1, p)\n }\n\n # These two lines of code should give the same result as\n #\n # Y = (t(X) - cm)/csd\n # d = rowSums(Y^2)\n #\n # for all four combinations of \"center\" and \"scale\", but do so\n # without having to modify X, or create copies of X in memory. In\n # particular the first line should be equivalent to colSums(X^2).\n d <- n * colMeans(X)^2 + (n - 1) * compute_colSds(X)^2\n d <- (d - n * cm^2) / csd^2\n }\n\n return(list(cm = cm, csd = csd, d = d))\n}\n\n# Compute standard error for regression coef.\n# S = (X'X)^-1 \\Sigma\ncalc_stderr = function (X, residuals)\n sqrt(diag(sum(residuals^2)/(nrow(X) - 2) * chol2inv(chol(crossprod(X)))))\n\n#' Check alpha/PIP fixed-point or short-cycle convergence\n#'\n#' Uses one tolerance for both marginal PIPs and alpha. Lag 1 is ordinary\n#' convergence; larger lags detect a periodic orbit and average alpha over it.\n#'\n#' @keywords internal\ncheck_alpha_pip_cycle_convergence <- function(data, params, model) {\n tol <- params$tol\n cycle_window <- if (!is.null(params$pip_stall_window))\n params$pip_stall_window\n else\n 5\n cycle_window <- max(1L, as.integer(cycle_window))\n prior_tol <- if (!is.null(params$prior_tol)) params$prior_tol else 1e-9\n\n alpha_pip <- function(alpha) {\n tmp <- model\n tmp$alpha <- alpha\n if (inherits(tmp, \"susie\"))\n susie_get_pip(tmp, prior_tol = prior_tol)\n else\n susie_get_pip(alpha, prior_tol = prior_tol)\n }\n\n current_alpha <- model$alpha\n current_pip <- alpha_pip(current_alpha)\n\n alpha_history <- model$runtime$alpha_history\n pip_history <- model$runtime$pip_history\n if (is.null(alpha_history) || is.null(pip_history)) {\n alpha_history <- list(model$runtime$prev_alpha)\n pip_history <- list(alpha_pip(model$runtime$prev_alpha))\n }\n\n state_diff <- function(alpha_old, pip_old)\n max(max(abs(current_alpha - alpha_old)), max(abs(current_pip - pip_old)))\n\n max_lag <- min(cycle_window, length(alpha_history))\n lag_diff <- state_diff(alpha_history[[length(alpha_history)]],\n pip_history[[length(pip_history)]])\n reason <- NULL\n\n if (lag_diff < tol) {\n reason <- \"alpha_pip_fixed_point\"\n } else if (max_lag >= 2) {\n for (lag in 2:max_lag) {\n idx <- length(alpha_history) - lag + 1\n lag_diff <- state_diff(alpha_history[[idx]], pip_history[[idx]])\n if (lag_diff < tol) {\n reason <- paste0(\"alpha_pip_cycle_\", lag)\n cycle_alpha <- c(tail(alpha_history, lag - 1), list(current_alpha))\n model$alpha <- Reduce(`+`, cycle_alpha) / lag\n current_alpha <- model$alpha\n current_pip <- alpha_pip(current_alpha)\n break\n }\n }\n }\n\n model$converged <- !is.null(reason)\n model$convergence_reason <- reason\n model$runtime$pip_diff <- lag_diff\n model$runtime$alpha_history <- c(alpha_history, list(current_alpha))\n model$runtime$pip_history <- c(pip_history, list(current_pip))\n if (length(model$runtime$alpha_history) > cycle_window) {\n keep <- seq.int(length(model$runtime$alpha_history) - cycle_window + 1,\n length(model$runtime$alpha_history))\n model$runtime$alpha_history <- model$runtime$alpha_history[keep]\n model$runtime$pip_history <- model$runtime$pip_history[keep]\n }\n return(model)\n}\n\n# =============================================================================\n# DATA PROCESSING & VALIDATION\n#\n# Functions for input validation, data conversion between formats, and\n# preprocessing operations. These ensure data integrity and compatibility\n# across different SuSiE data types.\n#\n# Functions: check_semi_pd, check_projection, validate_init,\n# convert_individual_to_ss, extract_prior_weights, reconstruct_full_weights,\n# validate_and_override_params\n# =============================================================================\n\n# Check whether A is positive semidefinite\n#' @keywords internal\ncheck_semi_pd <- function(A, tol) {\n attr(A, \"eigen\") <- eigen(A, symmetric = TRUE)\n v <- attr(A, \"eigen\")$values\n v[abs(v) < tol] <- 0\n return(list(\n matrix = A,\n status = !any(v < 0),\n eigenvalues = v\n ))\n}\n\n# Check whether b is in space spanned by the non-zero eigenvectors of A\n#' @keywords internal\ncheck_projection <- function(A, b) {\n if (is.null(attr(A, \"eigen\"))) {\n attr(A, \"eigen\") <- eigen(A, symmetric = TRUE)\n }\n v <- attr(A, \"eigen\")$values\n B <- attr(A, \"eigen\")$vectors[, v > .Machine$double.eps]\n msg <- all.equal(as.vector(B %*% crossprod(B, b)), as.vector(b),\n check.names = FALSE\n )\n if (!is.character(msg)) {\n return(list(status = TRUE, msg = NA))\n } else {\n return(list(status = FALSE, msg = msg))\n }\n}\n\n# Validate Model Initialization Object\n#' @keywords internal\nvalidate_init <- function(data, params) {\n if (!inherits(params$model_init, \"susie\")) {\n stop(\"model_init must be a 'susie' object\")\n }\n\n # Assign values from initialized model\n L <- params$L\n alpha <- params$model_init$alpha\n mu <- params$model_init$mu\n mu2 <- params$model_init$mu2\n V <- params$model_init$V\n sigma2 <- params$model_init$sigma2\n pi_w <- params$model_init$pi\n null_id <- params$model_init$null_index\n\n # Verify no NA/Inf values in alpha\n if (any(!is.finite(alpha))) {\n stop(\"model_init$alpha contains NA/Inf values\")\n }\n\n # Verify no NA/Inf values in mu\n if (any(!is.finite(mu))) {\n stop(\"model_init$mu contains NA/Inf values\")\n }\n\n # Verify no NA/Inf values in mu2\n if (any(!is.finite(mu2))) {\n stop(\"model_init$mu2 contains NA/Inf values\")\n }\n\n # Only check V if it exists\n if (!is.null(V)) {\n # Verify no NA/Inf values in V\n if (any(!is.finite(V))) {\n stop(\"model_init$V contains NA/Inf values\")\n }\n }\n\n # Only check sigma2 if it exists\n if (!is.null(sigma2)) {\n # Verify no NA/Inf values in sigma2\n if (any(!is.finite(sigma2))) {\n stop(\"model_init$sigma2 contains NA/Inf\")\n }\n }\n\n # Only check pi_w if it exists\n if (!is.null(pi_w)) {\n # Verify no NA/Inf values in prior weights\n if (any(!is.finite(pi_w))) {\n stop(\"model_init$pi contains NA/Inf\")\n }\n }\n\n # Verify alpha is matrix\n if (!is.matrix(alpha)) {\n stop(\"model_init$alpha must be a matrix\")\n }\n\n # Verify alpha values are between [0,1]\n if (max(alpha) > 1 || min(alpha) < 0) {\n stop(\n \"model_init$alpha has invalid values outside range [0,1]; please \",\n \"check your input\"\n )\n }\n\n # Verify mu & mu2 dimensions match alpha\n if (!all(dim(mu) == dim(alpha))) {\n stop(\"model_init$mu and model_init$alpha dimensions do not match\")\n }\n if (!all(dim(mu2) == dim(alpha))) {\n stop(\"model_init$mu2 and model_init$alpha dimensions do not match\")\n }\n\n # Only validate V dimensions and values if V exists\n if (!is.null(V)) {\n # Verify V & alpha dimensions agree\n if (length(V) != nrow(alpha)) {\n stop(\n \"length(model_init$V) (\", length(V), \") does not equal nrow(model_init$alpha) (\",\n nrow(alpha), \")\"\n )\n }\n\n # Verify V is numeric and non-negative\n if (!is.numeric(V)) {\n stop(\"model_init$V must be numeric\")\n }\n if (any(V < 0)) {\n stop(\"model_init$V has at least one negative value\")\n }\n }\n\n # Verify sigma2 is numeric and non-negative if it exists\n if (!is.null(sigma2)) {\n if (!is.numeric(sigma2)) {\n stop(\"model_init$sigma2 must be numeric\")\n }\n if (sigma2 < 0) {\n stop(\"model_init$sigma2 is negative\")\n }\n }\n\n # Verify prior weight properties if they exist\n if (!is.null(pi_w)) {\n if (length(pi_w) != ncol(alpha)) {\n stop(\n \"model_init$pi should have the same length as the number of columns\",\n \" in model_init$alpha\"\n )\n }\n }\n\n invisible(params$model_init)\n}\n\n# Convert individual data to ss with unmappable effects components.\n#' @keywords internal\nconvert_individual_to_ss <- function(data, params) {\n # Compute sufficient statistics\n XtX <- compute_XtX(data$X)\n Xty <- compute_Xty(data$X, data$y)\n yty <- sum(data$y^2)\n\n # Get column means and scaling from attributes\n X_colmeans <- attr(data$X, \"scaled:center\")\n\n # Create sufficient statistics data object\n ss_data <- structure(\n list(\n XtX = XtX,\n X = NULL,\n Xty = Xty,\n yty = yty,\n n = data$n,\n p = data$p,\n X_colmeans = X_colmeans,\n y_mean = data$mean_y\n ),\n class = \"ss\"\n )\n\n # Set attributes on XtX from individual X\n attr(ss_data$XtX, \"d\") <- attr(data$X, \"d\")\n attr(ss_data$XtX, \"scaled:scale\") <- attr(data$X, \"scaled:scale\")\n\n # Add eigen decomposition for unmappable effects methods\n ss_data <- add_eigen_decomposition(ss_data, params, data)\n\n return(ss_data)\n}\n\n# Extract non-null prior weights from a model\n#' @keywords internal\nextract_prior_weights <- function(model, null_weight = NULL) {\n # Use model's null_weight if not provided (backwards compatibility)\n if (is.null(null_weight)) {\n null_weight <- model$null_weight\n }\n \n if (!is.null(null_weight) && null_weight != 0 && !is.null(model$null_index) && model$null_index != 0) {\n # Extract non-null prior weights and rescale\n pw_s <- model$pi[-model$null_index] / (1 - null_weight)\n } else {\n pw_s <- model$pi\n }\n return(pw_s)\n}\n\n# Reconstruct full prior weights with null weight handling\n#' @keywords internal\nreconstruct_full_weights <- function(non_null_weights, null_weight) {\n if (!is.null(null_weight) && null_weight != 0) {\n # Reconstruct full prior weights including null component\n full_weights <- c(non_null_weights * (1 - null_weight), null_weight)\n } else {\n full_weights <- non_null_weights\n }\n # Normalize to sum to 1\n return(full_weights / sum(full_weights))\n}\n\n\n# Validate and Override Parameters\n#' @keywords internal\nvalidate_and_override_params <- function(params) {\n\n # Validate prior tolerance threshold\n if (!is.numeric(params$prior_tol) || length(params$prior_tol) != 1) {\n stop(\"prior_tol must be a numeric scalar.\")\n }\n if (params$prior_tol < 0) {\n stop(\"prior_tol must be non-negative.\")\n }\n\n # Validate greedy-L parameters.\n if (!is.null(params$L_greedy)) {\n if (!is.numeric(params$L_greedy) || length(params$L_greedy) != 1 ||\n is.na(params$L_greedy) || !is.finite(params$L_greedy) ||\n params$L_greedy < 1 ||\n params$L_greedy != as.integer(params$L_greedy)) {\n stop(\"L_greedy must be NULL or a positive integer.\")\n }\n params$L_greedy <- as.integer(params$L_greedy)\n if (params$L_greedy > params$L) {\n warning_message(\"L_greedy is greater than L; using L instead.\")\n params$L_greedy <- as.integer(params$L)\n }\n }\n if (!is.numeric(params$greedy_lbf_cutoff) ||\n length(params$greedy_lbf_cutoff) != 1 ||\n is.na(params$greedy_lbf_cutoff) ||\n !is.finite(params$greedy_lbf_cutoff)) {\n stop(\"greedy_lbf_cutoff must be a numeric scalar.\")\n }\n\n # Validate residual_variance_upperbound\n if (!is.numeric(params$residual_variance_upperbound) || length(params$residual_variance_upperbound) != 1) {\n stop(\"residual_variance_upperbound must be a numeric scalar.\")\n }\n if (params$residual_variance_upperbound <= 0) {\n stop(\"residual_variance_upperbound must be positive.\")\n }\n\n # Validate scaled prior variance\n if (!is.numeric(params$scaled_prior_variance) || any(params$scaled_prior_variance < 0)) {\n stop(\"Scaled prior variance should be positive number.\")\n }\n spv_len <- length(params$scaled_prior_variance)\n if (spv_len != 1 && spv_len != params$L) {\n stop(\"scaled_prior_variance must be a scalar or a vector of length L.\")\n }\n\n # Validate unmappable_effects\n # \"ash_filter_archived\" is a hidden option for internal diagnostics/archiving\n # of the original SuSiE-ASH filter-based masking heuristic.\n valid_unmappable <- c(\"none\", \"inf\", \"ash\", \"ash_filter_archived\")\n if (!params$unmappable_effects %in% valid_unmappable) {\n stop(\"unmappable_effects must be one of 'none', 'inf', or 'ash'.\")\n }\n\n # Auto-create Beta-Binomial slot prior for ash mode (identifiability).\n if (params$unmappable_effects == \"ash\" && is.null(params$slot_prior)) {\n params$slot_prior <- slot_prior_betabinom()\n warning_message(\n \"For SuSiE-ash it is strongly advised to set slot_prior with \",\n \"a beta-binomial prior based on your expected sparsity of data. \",\n \"Set slot_prior = slot_prior_betabinom(a_beta, b_beta) explicitly.\")\n }\n # Report BB default parameters (separate from the warning above).\n if (!is.null(params$slot_prior) && inherits(params$slot_prior, \"slot_prior_betabinom\") &&\n isTRUE(params$slot_prior$ab_was_default)) {\n sp <- params$slot_prior\n n_active <- round(sp$a_beta / (sp$a_beta + sp$b_beta) * params$L)\n warning_message(\n \"Beta-Binomial prior parameters not specified, using default \",\n \"Beta(a=\", sp$a_beta, \", b=\", sp$b_beta, \"), \",\n \"roughly expecting ~\", n_active, \" of \", params$L,\n \" slots to be active. Set a_beta and b_beta explicitly \",\n \"to change this behavior.\")\n }\n # Report nu default after the C message so the user sees C first.\n if (!is.null(params$slot_prior) && !inherits(params$slot_prior, \"slot_prior_betabinom\") &&\n isTRUE(params$slot_prior$nu_was_default)) {\n sp <- params$slot_prior\n sd_mu <- sp$C / sqrt(sp$nu)\n warning_message(\n \"Overdispersion parameter nu not specified, using default nu = \",\n sp$nu, \". With C = \", sp$C,\n \" this implies sd(mu) = \", round(sd_mu, 2),\n \", so the number of active effects ranges roughly from \",\n round(max(0, sp$C - 2 * sd_mu), 1), \" to \",\n round(sp$C + 2 * sd_mu, 1),\n \" around the prior mean. Set nu explicitly to change this behavior.\")\n }\n\n # Override convergence method for unmappable effects or slot_prior.\n # The ELBO is not well-defined when slot_weights != 1 (c_hat active)\n # or when unmappable effects modify the residual structure.\n needs_pip <- params$unmappable_effects != \"none\" || !is.null(params$slot_prior)\n if (needs_pip && params$convergence_method != \"pip\") {\n if (params$unmappable_effects != \"none\") {\n warning_message(\"Unmappable effects models (inf/ash) do not have a well \",\n \"defined ELBO and require PIP convergence. \",\n \"Setting convergence_method='pip'.\")\n } else {\n warning_message(\"Slot activity model modifies fitted values \",\n \"by slot weights, making the standard ELBO invalid. \",\n \"Setting convergence_method='pip'.\")\n }\n params$convergence_method <- \"pip\"\n }\n\n # Check for incompatible parameter combinations\n if (!is.null(params$refine) && params$refine && params$unmappable_effects != \"none\") {\n stop(\"Refinement is not supported with unmappable effects (inf/ash) as it relies on ELBO, \",\n \"which is not well-defined for these models. Please set refine = FALSE.\")\n }\n\n # Override prior estimation method when estimation is disabled,\n # unless using a fixed mixture prior (which does not estimate V but\n # still needs the mixture BF computation path)\n if (!params$estimate_prior_variance &&\n params$estimate_prior_method != \"fixed_mixture\") {\n params$estimate_prior_method <- \"none\"\n }\n\n # Handle NIG parameters for small sample correction\n if (params$estimate_residual_method == \"NIG\") {\n params$use_NIG <- TRUE\n\n # Require a valid sample size n. The default alpha0/beta0 scale as\n # 1/sqrt(n), so n must be a positive finite scalar. susie() infers\n # this from nrow(X); susie_ss()'s constructor enforces it; susie_rss()\n # allows n = NULL by default, so users who select NIG must also\n # supply `n` explicitly.\n if (is.null(params$n) || !is.numeric(params$n) || length(params$n) != 1 ||\n !is.finite(params$n) || params$n < 1) {\n stop(\"estimate_residual_method = \\\"NIG\\\" requires a valid sample \",\n \"size `n` (got n = \", paste(params$n, collapse = \"\"), \"). \",\n \"susie() infers n from nrow(X); for susie_ss() and susie_rss(), \",\n \"pass `n` explicitly.\")\n }\n\n # Validate NIG prior parameters: both must be strictly positive for a proper\n # Inverse-Gamma prior. Otherwise compute_null_loglik_NIG() evaluates\n # lgamma(alpha0 / 2) at <= 0 and the marginal log-likelihood (and ELBO)\n # become Inf or NaN.\n if (!is.numeric(params$alpha0) || length(params$alpha0) != 1 ||\n !is.finite(params$alpha0) || params$alpha0 <= 0 ||\n !is.numeric(params$beta0) || length(params$beta0) != 1 ||\n !is.finite(params$beta0) || params$beta0 <= 0) {\n stop(\"estimate_residual_method = \\\"NIG\\\" requires \",\n \"alpha0 > 0 and beta0 > 0 (proper Inverse-Gamma prior). \",\n \"Got alpha0 = \", params$alpha0, \", beta0 = \", params$beta0, \". \",\n \"The default is alpha0 = beta0 = 1/sqrt(n).\")\n }\n\n # The NIG prior inherently estimates residual variance (integrates out sigma^2).\n # If estimate_residual_variance is FALSE, override it -- the user chose a method\n # that estimates sigma^2 by design. To suppress this warning, explicitly set\n # estimate_residual_variance = TRUE in the function call.\n if (!isTRUE(params$estimate_residual_variance)) {\n warning_message(\"NIG prior integrates out residual variance, \",\n \"implying estimate_residual_variance = TRUE. \",\n \"Setting estimate_residual_variance = TRUE. \",\n \"To suppress this warning, explicitly set \",\n \"estimate_residual_variance = TRUE in the function call.\")\n params$estimate_residual_variance <- TRUE\n }\n\n # Override convergence method only when L > 1\n if (params$L > 1 && params$convergence_method != \"pip\") {\n warning_message(\"NIG method with L > 1 requires PIP convergence. Setting convergence_method='pip'.\")\n params$convergence_method <- \"pip\"\n }\n\n # Override prior variance estimation method (only when estimation is enabled)\n if (params$estimate_prior_variance && params$estimate_prior_method != \"EM\") {\n warning_message(\"NIG method works better with EM. Setting estimate_prior_method='EM'.\")\n params$estimate_prior_method <- \"EM\"\n }\n } else {\n params$use_NIG <- FALSE\n params$alpha0 <- NULL\n params$beta0 <- NULL\n }\n\n return(params)\n}\n\n# =============================================================================\n# MODEL INITIALIZATION\n#\n# Functions that set up initial model states, create model matrices,\n# and handle model configuration. These prepare the SuSiE model object\n# for iterative fitting.\n#\n# Functions: initialize_null_index, assign_names,\n# adjust_L, prune_single_effects, add_null_effect\n# =============================================================================\n\n# Initialize Null Index\n#' @keywords internal\ninitialize_null_index <- function(data, model) {\n if (is.null(model$null_weight) || model$null_weight == 0) {\n null_idx <- 0\n } else {\n null_idx <- data$p\n }\n return(null_idx)\n}\n\n# Helper function to assign variable names to model components\n#' @keywords internal\nassign_names <- function(data, model, variable_names) {\n if (!is.null(variable_names)) {\n if (!is.null(model$null_weight) && model$null_weight != 0 && !is.null(model$null_index) && model$null_index != 0) {\n variable_names[length(variable_names)] <- \"null\"\n names(model$pip) <- variable_names[-data$p]\n } else {\n names(model$pip) <- variable_names\n }\n colnames(model$alpha) <- variable_names\n colnames(model$mu) <- variable_names\n colnames(model$mu2) <- variable_names\n colnames(model$lbf_variable) <- variable_names\n }\n return(model)\n}\n\n# Expand scaled_prior_variance into a length-L vector of prior variances.\n# Accepts either a scalar (recycled to length L) or a length-L vector\n# (used as-is, one prior variance per single-effect slot).\n#' @keywords internal\nexpand_scaled_prior_variance <- function(scaled_prior_variance, var_y, L) {\n if (length(scaled_prior_variance) == 1) {\n rep(scaled_prior_variance * var_y, L)\n } else {\n scaled_prior_variance * var_y\n }\n}\n\n# Adjust the number of effects\n#' @keywords internal\nadjust_L <- function(params, model_init_pruned, var_y) {\n num_effects <- nrow(model_init_pruned$alpha)\n L <- params$L\n\n if (num_effects > L) {\n warning_message(paste0(\n \"Requested L = \", L,\n \" is smaller than the \", num_effects,\n \" effects in model_init after pruning; \",\n \"using L = \", num_effects, \" instead.\"\n ))\n L <- num_effects\n }\n\n V <- expand_scaled_prior_variance(params$scaled_prior_variance, var_y, L)\n model_init <- prune_single_effects(model_init_pruned, L = L, V = V)\n\n return(list(model_init = model_init, L = L))\n}\n\n# Prune single effects to given number L in susie model object.\n#' @keywords internal\nprune_single_effects <- function(model_init, L = 0, V = NULL) {\n num_effects <- nrow(model_init$alpha)\n if (L == 0) {\n # Filtering will be based on non-zero elements in model_init$V.\n if (!is.null(model_init$V)) {\n L <- length(which(model_init$V > 0))\n } else {\n L <- num_effects\n }\n }\n if (L == num_effects) {\n model_init$sets <- NULL\n return(model_init)\n }\n if (!is.null(model_init$sets$cs_index)) {\n effects_rank <- c(model_init$sets$cs_index, setdiff(1:num_effects, model_init$sets$cs_index))\n } else {\n effects_rank <- 1:num_effects\n }\n\n if (L > num_effects) {\n message(paste(\n \"Specified number of effects L =\", L,\n \"is greater the number of effects\", num_effects,\n \"in input SuSiE model. The SuSiE model will be expanded\",\n \"to have\", L, \"effects.\"\n ))\n\n model_init$alpha <- rbind(\n model_init$alpha[effects_rank, ],\n matrix(1 / ncol(model_init$alpha), L - num_effects, ncol(model_init$alpha))\n )\n for (n in c(\"mu\", \"mu2\", \"lbf_variable\")) {\n if (!is.null(model_init[[n]])) {\n model_init[[n]] <- rbind(\n model_init[[n]][effects_rank, ],\n matrix(0, L - num_effects, ncol(model_init[[n]]))\n )\n }\n }\n for (n in c(\"KL\", \"lbf\")) {\n if (!is.null(model_init[[n]])) {\n model_init[[n]] <- c(model_init[[n]][effects_rank], rep(NA, L - num_effects))\n }\n }\n if (!is.null(V)) {\n if (length(V) > 1) {\n if (!is.null(model_init$V)) {\n V[1:num_effects] <- model_init$V[effects_rank]\n }\n } else {\n V <- rep(V, L)\n }\n }\n model_init$V <- V\n }\n model_init$sets <- NULL\n return(model_init)\n}\n\n# Add a null effect to the model object\n#' @keywords internal\nadd_null_effect <- function(model_init, V) {\n p <- ncol(model_init$alpha)\n model_init$alpha <- rbind(model_init$alpha, 1 / p)\n model_init$mu <- rbind(model_init$mu, rep(0, p))\n model_init$mu2 <- rbind(model_init$mu2, rep(0, p))\n model_init$lbf_variable <- rbind(model_init$lbf_variable, rep(0, p))\n model_init$V <- c(model_init$V, V)\n return(model_init)\n}\n\n# =============================================================================\n# MATRIX-VECTOR PRODUCT HELPERS\n#\n# Unified helpers for predictor-matrix-times-vector operations across\n# SS (XtX) and RSS-lambda (R) data types. These dispatch on what's available\n# on the data object: data$X (low-rank factor), data$XtX, or data$R.\n# When data$X is stored (Bxp, B < p), the two-step product X'(Xv) avoids\n# forming the pxp matrix, reducing cost from O(p^2) to O(Bp).\n#\n# Functions: compute_Rv, compute_BR\n# =============================================================================\n\n# Compute R*v product: X'(Xv), XtX*v, or R*v.\n# For multi-panel rss_lambda, pass Rv_matrix = model$X_meta to use the\n# current R(omega) factor instead of data$X.\n#' @keywords internal\ncompute_Rv <- function(data, v, Rv_matrix = NULL) {\n if (!is.null(Rv_matrix)) {\n return(as.vector(crossprod(Rv_matrix, Rv_matrix %*% v)))\n }\n if (!is.null(data$X)) {\n return(as.vector(crossprod(data$X, data$X %*% v)))\n } else if (!is.null(data$XtX)) {\n return(as.vector(data$XtX %*% v))\n } else if (!is.null(data$R)) {\n return(as.vector(data$R %*% v))\n }\n stop(\"No predictor matrix available on data object.\")\n}\n\n# Compute B_mat %*% predictor-matrix: (Lxp) times (pxp) -> (Lxp)\n# Used in get_ER2.ss for the quadratic form B %*% XtX\n#' @keywords internal\ncompute_BR <- function(data, B_mat) {\n if (!is.null(data$X)) {\n return((B_mat %*% t(data$X)) %*% data$X)\n } else if (!is.null(data$XtX)) {\n return(B_mat %*% data$XtX)\n }\n stop(\"No predictor matrix available for compute_BR.\")\n}\n\n# =============================================================================\n# CORE ALGORITHM COMPONENTS\n#\n# Key computational functions that implement the mathematical core of the\n# SuSiE algorithm. These handle eigen decompositions, posterior computations,\n# and log Bayes factor calculations.\n#\n# Functions: compute_eigen_decomposition, add_eigen_decomposition,\n# compute_omega_quantities, scale_design_matrix, compute_theta_blup,\n# lbf_stabilization, compute_posterior_weights, compute_lbf_gradient\n# =============================================================================\n\n# Compute eigenvalue decomposition for unmappable methods\n# When X (low-rank factor) is available, uses thin SVD (O(pB^2)) instead\n# of eigen decomposition of XtX (O(p^3)).\n#' @keywords internal\ncompute_eigen_decomposition <- function(XtX, n, X = NULL) {\n if (!is.null(X)) {\n # Thin SVD: O(p*B^2) instead of O(p^3)\n p <- ncol(X)\n sv <- svd(X, nu = 0)\n V <- sv$v # p x min(B,p) right singular vectors\n Dsq <- pmax(sv$d^2, 0) # eigenvalues of X'X\n # Pad to length p with zeros (null-space eigenvectors)\n if (ncol(V) < p) {\n V <- cbind(V, matrix(0, p, p - ncol(V)))\n Dsq <- c(Dsq, rep(0, p - length(Dsq)))\n }\n idx <- order(Dsq, decreasing = TRUE)\n return(list(V = V[, idx], Dsq = Dsq[idx], VtXty = NULL))\n }\n\n LD <- XtX / n\n eig <- eigen(LD, symmetric = TRUE)\n idx <- order(eig$values, decreasing = TRUE)\n\n list(\n V = eig$vectors[, idx],\n Dsq = pmax(eig$values[idx] * n, 0),\n VtXty = NULL\n )\n}\n\n# Add eigen decomposition to ss data objects for unmappable methods\n#' @keywords internal\nadd_eigen_decomposition <- function(data, params, individual_data = NULL) {\n # Compute eigen decomposition (thin SVD when X is available)\n eigen_decomp <- compute_eigen_decomposition(data$XtX, data$n, X = data$X)\n\n # Append eigen components to data object\n data$eigen_vectors <- eigen_decomp$V\n data$eigen_values <- eigen_decomp$Dsq\n data$VtXty <- t(eigen_decomp$V) %*% data$Xty\n\n return(data)\n}\n\n#' Scale design matrix using centering and scaling parameters\n#'\n#' Applies column-wise centering and scaling to match the space used by\n#' compute_XtX() and compute_Xty() for unmappable effects methods.\n#'\n#' @param X Matrix to scale (n x p)\n#' @param center Vector of column means to subtract (length p), or NULL\n#' @param scale Vector of column SDs to divide by (length p), or NULL\n#'\n#' @return Scaled matrix with centered and scaled columns\n#'\n#' @keywords internal\nscale_design_matrix <- function(X, center = NULL, scale = NULL) {\n if (is.null(center)) center <- rep(0, ncol(X))\n if (is.null(scale)) scale <- rep(1, ncol(X))\n\n X_centered <- sweep(X, 2, center, \"-\")\n X_scaled <- sweep(X_centered, 2, scale, \"/\")\n\n return(X_scaled)\n}\n\n# Compute Omega-weighted quantities for unmappable effects methods\n#' @keywords internal\ncompute_omega_quantities <- function(data, tau2, sigma2) {\n # Compute variance in eigen space\n omega_var <- tau2 * data$eigen_values + sigma2\n\n # Compute diagonal of X'OmegaX\n diagXtOmegaX <- rowSums(sweep(data$eigen_vectors^2, 2,\n (data$eigen_values / omega_var), `*`))\n\n return(list(\n omega_var = omega_var,\n diagXtOmegaX = diagXtOmegaX\n ))\n}\n\n# Compute unmappable effects coefficient vector using BLUP\n#' @keywords internal\ncompute_theta_blup <- function(data, model) {\n # Calculate diagXtOmegaX, diagonal variances, and Beta\n omega_res <- compute_omega_quantities(data, model$tau2, model$sigma2)\n b <- colSums(model$mu * model$alpha)\n\n # Compute XtOmegaXb, XtOmegay, and XtOmegar\n XtOmegaXb <- data$eigen_vectors %*% ((t(data$eigen_vectors) %*% b) *\n data$eigen_values / omega_res$omega_var)\n XtOmegay <- data$eigen_vectors %*% (data$VtXty / omega_res$omega_var)\n XtOmegar <- XtOmegay - XtOmegaXb\n\n # Compute theta\n theta <- model$tau2 * XtOmegar\n\n return(theta)\n}\n\n# Stabilize log Bayes factors and compute log posterior odds\n#' @keywords internal\nlbf_stabilization <- function(lbf, prior_weights, shat2) {\n lpo <- lbf + log(prior_weights + sqrt(.Machine$double.eps))\n\n # When shat2 is infinite, set lbf=0 and lpo to prior (no information from data)\n infinite_idx <- is.infinite(shat2)\n lbf[infinite_idx] <- 0\n lpo[infinite_idx] <- log(prior_weights[infinite_idx] + sqrt(.Machine$double.eps))\n\n return(list(lbf = lbf, lpo = lpo))\n}\n\n# Compute alpha and lbf for each effect\n#' @keywords internal\ncompute_posterior_weights <- function(lpo) {\n\n w_weighted <- exp(lpo - max(lpo))\n weighted_sum_w <- sum(w_weighted)\n alpha <- w_weighted / weighted_sum_w\n\n return(list(\n alpha = alpha,\n lbf_model = log(weighted_sum_w) + max(lpo)\n ))\n}\n\n# Compute gradient for prior variance optimization\n#' @keywords internal\ncompute_lbf_gradient <- function(alpha, betahat, shat2, V, use_NIG = FALSE) {\n # No gradient computation for NIG prior\n if (use_NIG) {\n return(NULL)\n }\n\n T2 <- betahat^2 / shat2\n grad_components <- 0.5 * (1 / (V + shat2)) * ((shat2 / (V + shat2)) * T2 - 1)\n grad_components[is.nan(grad_components)] <- 0\n gradient <- sum(alpha * grad_components)\n return(gradient)\n}\n\n# =============================================================================\n# VARIANCE ESTIMATION\n#\n# Functions specifically for estimating variance components using different\n# methods (MLE, MoM, NIG). These handle both standard SuSiE\n# and unmappable effects models.\n#\n# Functions: mom_unmappable, mle_unmappable, create_ash_grid,\n# compute_lbf_NIG_univariate, posterior_mean_NIG,\n# posterior_var_NIG, compute_stats_NIG, update_prior_variance_NIG_EM,\n# compute_kl_NIG, inv_gamma_factor, compute_null_loglik_NIG,\n# compute_marginal_loglik, est_residual_variance, update_model_variance\n# =============================================================================\n\n# Method of Moments variance estimation for unmappable effects methods\n#' @keywords internal\nmom_unmappable <- function(data, params, model, omega, tau2, est_tau2 = TRUE, est_sigma2 = TRUE) {\n L <- nrow(model$mu)\n\n A <- matrix(0, nrow = 2, ncol = 2)\n A[1, 1] <- data$n\n A[1, 2] <- sum(data$eigen_values)\n A[2, 1] <- A[1, 2]\n A[2, 2] <- sum(data$eigen_values^2)\n\n # Compute diag(V'MV)\n b <- colSums(model$mu * model$alpha)\n Vtb <- crossprod(data$eigen_vectors, b)\n diagVtMV <- Vtb^2\n tmpD <- rep(0, data$p)\n\n for (l in seq_len(L)) {\n bl <- model$mu[l, ] * model$alpha[l, ]\n Vtbl <- crossprod(data$eigen_vectors, bl)\n diagVtMV <- diagVtMV - Vtbl^2\n tmpD <- tmpD + model$alpha[l, ] * (model$mu[l, ]^2 + 1 / omega[l, ])\n }\n\n diagVtMV <- diagVtMV + rowSums(sweep(t(data$eigen_vectors)^2, 2, tmpD, `*`))\n\n # Compute x\n x <- rep(0, 2)\n x[1] <- data$yty - 2 * sum(b * data$Xty) + sum(data$eigen_values * diagVtMV)\n x[2] <- sum(data$Xty^2) - 2 * sum(Vtb * data$VtXty * data$eigen_values) +\n sum(data$eigen_values^2 * diagVtMV)\n\n if (est_tau2) {\n sol <- solve(A, x)\n if (sol[1] > 0 && sol[2] > 0) {\n sigma2 <- sol[1]\n tau2 <- sol[2]\n } else {\n sigma2 <- x[1] / data$n\n tau2 <- 0\n }\n if (params$verbose) {\n message(sprintf(\"Update (sigma^2,tau^2) to (%f,%e)\\n\", sigma2, tau2))\n }\n } else if (est_sigma2) {\n sigma2 <- (x[1] - A[1, 2] * tau2) / data$n\n if (params$verbose) {\n message(sprintf(\"Update sigma^2 to %f\\n\", sigma2))\n }\n }\n return(list(sigma2 = sigma2, tau2 = tau2))\n}\n\n# MLE variance estimation for unmappable effects\n#' @keywords internal\nmle_unmappable <- function(data, params, model, omega, est_tau2 = TRUE, est_sigma2 = TRUE) {\n L <- nrow(model$alpha)\n\n # Set default ranges\n sigma2_range <- c(0.2 * data$yty / data$n, 1.2 * data$yty / data$n)\n tau2_range <- c(1e-12, 1.2 * data$yty / (data$n * data$p))\n\n # Compute diag(V'MV)\n b <- colSums(model$mu * model$alpha)\n Vtb <- crossprod(data$eigen_vectors, b)\n diagVtMV <- Vtb^2\n tmpD <- rep(0, data$p)\n\n for (l in seq_len(L)) {\n bl <- model$mu[l, ] * model$alpha[l, ]\n Vtbl <- crossprod(data$eigen_vectors, bl)\n diagVtMV <- diagVtMV - Vtbl^2\n tmpD <- tmpD + model$alpha[l, ] * (model$mu[l, ]^2 + 1 / omega[l, ])\n }\n\n diagVtMV <- diagVtMV + rowSums(sweep(t(data$eigen_vectors)^2, 2, tmpD, `*`))\n\n # Negative ELBO as function of x = (sigma^2, tau^2)\n f <- function(x) {\n sigma2_val <- x[1]\n tau2_val <- x[2]\n var_val <- tau2_val * data$eigen_values + sigma2_val\n\n 0.5 * (data$n - data$p) * log(sigma2_val) + 0.5 / sigma2_val * data$yty +\n sum(0.5 * log(var_val) -\n 0.5 * tau2_val / sigma2_val * data$VtXty^2 / var_val -\n Vtb * data$VtXty / var_val +\n 0.5 * data$eigen_values / var_val * diagVtMV)\n }\n\n # Negative ELBO for sigma^2 only (when tau^2 is fixed)\n g <- function(sigma2_val) {\n f(c(sigma2_val, model$tau2))\n }\n\n # Initialize with current values\n sigma2 <- model$sigma2\n tau2 <- model$tau2\n\n if (est_tau2) {\n # Optimize both sigma^2 and tau^2\n res <- optim(\n par = c(model$sigma2, model$tau2),\n fn = f,\n method = \"L-BFGS-B\",\n lower = c(sigma2_range[1], tau2_range[1]),\n upper = c(sigma2_range[2], tau2_range[2])\n )\n\n if (res$convergence == 0) {\n sigma2 <- res$par[1]\n tau2 <- res$par[2]\n if (params$verbose) {\n message(sprintf(\"Update (sigma^2,tau^2) to (%f,%e)\\n\", sigma2, tau2))\n }\n } else {\n warning_message(\"MLE optimization failed to converge; keeping previous parameters\")\n }\n } else if (est_sigma2) {\n # Optimize only sigma^2\n res <- optim(\n par = model$sigma2,\n fn = g,\n method = \"L-BFGS-B\",\n lower = sigma2_range[1],\n upper = sigma2_range[2]\n )\n\n if (res$convergence == 0) {\n sigma2 <- res$par\n if (params$verbose) {\n message(sprintf(\"Update sigma^2 to %f\\n\", sigma2))\n }\n } else {\n warning_message(\"MLE optimization failed to converge; keeping previous parameters\")\n }\n }\n\n return(list(sigma2 = sigma2, tau2 = tau2))\n}\n\n# Extract NIG sufficient statistics from model, regardless of data type\n# This is the ONLY function that needs to know whether we have individual or SS data.\n# All other NIG functions work with (yy, sxy, tau) uniformly.\n#' @keywords internal\nget_nig_sufficient_stats <- function(data, model) {\n if (!is.null(model$raw_residuals)) {\n # Individual data path: compute from raw residuals\n yy <- sum(model$raw_residuals^2)\n sxy <- drop(cor(data$X, model$raw_residuals))\n tau <- 1\n } else {\n # SS/RSS path: use pre-computed quantities\n yy <- model$yy_residual\n sxy <- model$residuals / sqrt(model$predictor_weights * yy)\n # Clamp sxy to [-1, 1]: with approximate R from a finite reference,\n # Cauchy-Schwarz may be violated numerically, giving |sxy| > 1.\n # This would make rss = yy*(1 - r0*sxy^2) negative, producing NaN in log BF.\n sxy <- pmin(pmax(sxy, -1), 1)\n tau <- if (!is.null(model$shat2_inflation)) model$shat2_inflation else 1\n }\n list(yy = yy, sxy = sxy, tau = tau)\n}\n\n# Inputs for compute_kl_NIG: single-IG projection of the SER posterior.\n# a_post = (alpha0+n)/2; b_post = (beta0 + sum_j alpha_j RSS_j)/2 with\n# RSS_j = yy*(1 - r0_j*sxy_j^2); s_j_sq = r0_j * tau / xx_j.\n#' @keywords internal\nnig_kl_inputs <- function(data, params, model, l) {\n nig_ss <- get_nig_sufficient_stats(data, model)\n V_l <- model$V[l]\n r0 <- V_l / (V_l + nig_ss$tau / model$predictor_weights)\n s_j_sq <- r0 * nig_ss$tau / model$predictor_weights\n\n alpha_l <- model$alpha[l, ]\n rss_avg <- nig_ss$yy * (1 - sum(alpha_l * r0 * nig_ss$sxy^2))\n\n list(\n a_post = (params$alpha0 + data$n) / 2,\n b_post = (params$beta0 + rss_avg) / 2,\n s_j_sq = s_j_sq\n )\n}\n\n# Compute log Bayes factor for NIG prior (univariate form on raw x, y)\n#' @keywords internal\ncompute_lbf_NIG_univariate <- function(x, y, s0, alpha0 = 0, beta0 = 0) {\n x <- x - mean(x)\n y <- y - mean(y)\n n <- length(x)\n xx <- sum(x * x)\n xy <- sum(x * y)\n yy <- sum(y * y)\n r0 <- s0 / (s0 + 1 / xx)\n sxy <- xy / sqrt(xx * yy)\n ratio <- (beta0 + yy * (1 - r0 * sxy^2)) / (beta0 + yy)\n return((log(1 - r0) - (n + alpha0) * log(ratio)) / 2)\n}\n\n# Posterior mean for NIG prior using sufficient statistics\n#' @keywords internal\nposterior_mean_NIG <- function(xtx, xty, s0_t = 1) {\n omega <- (xtx + (1 / s0_t^2))^(-1)\n b_bar <- omega %*% xty\n return(b_bar)\n}\n\n# Posterior variance for NIG prior using sufficient statistics\n#' @keywords internal\nposterior_var_NIG <- function(xtx, xty, yty, n, s0_t = 1) {\n\n # If prior variance is too small, return 0.\n if (s0_t < 1e-5) {\n return(list(post_var = 0, beta1 = 0))\n }\n\n omega <- (xtx + (1 / s0_t^2))^(-1)\n b_bar <- omega %*% xty\n beta1 <- (yty - b_bar * (omega^(-1)) * b_bar)\n post_var_up <- 0.5 * (yty - b_bar * (omega^(-1)) * b_bar)\n post_var_down <- 0.5 * (n * (1 / omega))\n post_var <- omega * (post_var_up / post_var_down) * n / (n - 2)\n\n return(list(post_var = post_var, beta1 = beta1))\n}\n\n# Compute the (log) Bayes factors and additional statistics under Normal-Inverse-Gamma (NIG) prior\n#' @keywords internal\ncompute_stats_NIG <- function(n, xx, xy, yy, sxy, s0, a0, b0, tau = 1) {\n\n r0 <- s0 / (s0 + tau / xx)\n rss <- yy * (1 - r0 * sxy^2)\n\n # Update inverse-gamma parameters\n a1 <- a0 + n\n b1 <- b0 + rss\n\n # Compute log Bayes factor for each variable\n lbf <- -(log(1 + s0 * xx / tau) + a1 * log(b1 / (b0 + yy))) / 2\n\n # Compute least-squares estimate for each variable\n bhat <- xy / xx\n\n # Compute posterior mean\n post_mean <- r0 * bhat\n\n # Compute posterior variance\n post_var <- b1 / (a1 - 2) * r0 * tau / xx\n\n # Posterior mean of residual variance under IG((a0+n)/2, (b0+RSS)/2)\n rv <- (b1 / 2) / (a1 / 2 - 1)\n\n return(list(\n lbf = lbf,\n post_mean = post_mean,\n post_mean2 = post_var + post_mean^2,\n post_var = post_var,\n rv = rv\n ))\n}\n\n# Compute log Bayes factors under Normal-Inverse-Gamma (NIG) prior\n#' @keywords internal\ncompute_lbf_NIG <- function(n, xx, xy, yy, sxy, s0, a0, b0, tau = 1) {\n r0 <- s0 / (s0 + tau / xx)\n rss <- yy * (1 - r0 * sxy^2)\n\n # Update inverse-gamma parameters\n a1 <- a0 + n\n b1 <- b0 + rss\n\n # Compute log Bayes factor for each variable\n lbf <- -(log(1 + s0 * xx / tau) + a1 * log(b1 / (b0 + yy))) / 2\n\n return(lbf)\n}\n\n# Compute posterior moments under Normal-Inverse-Gamma (NIG) prior\n#' @keywords internal\ncompute_posterior_moments_NIG <- function(n, xx, xy, yy, sxy, s0, a0, b0, tau = 1) {\n r0 <- s0 / (s0 + tau / xx)\n rss <- yy * (1 - r0 * sxy^2)\n\n # Update inverse-gamma parameters\n a1 <- a0 + n\n b1 <- b0 + rss\n\n # Compute least-squares estimate for each variable\n bhat <- xy / xx\n\n # Compute posterior mean\n post_mean <- r0 * bhat\n\n # Compute posterior variance\n post_var <- b1 / (a1 - 2) * r0 * tau / xx\n\n # Posterior mean of residual variance under IG((a0+n)/2, (b0+RSS)/2)\n rv <- (b1 / 2) / (a1 / 2 - 1)\n\n return(list(\n post_mean = post_mean,\n post_mean2 = post_var + post_mean^2,\n post_var = post_var,\n s_j_sq = r0 * tau / xx,\n rv = rv\n ))\n}\n\n# EM update for prior variance under Normal-Inverse-Gamma (NIG) prior\n#' @keywords internal\nupdate_prior_variance_NIG_EM <- function(n, xx, xy, yy, sxy, pip, s0, a0, b0, tau = 1) {\n r0 <- s0 / (s0 + tau / xx)\n rss <- yy * (1 - r0 * sxy^2)\n\n # Update inverse-gamma parameters\n a1 <- a0 + n\n b1 <- b0 + rss\n\n # Compute posterior mean and variance component\n bhat <- xy / xx\n post_mean <- r0 * bhat\n post_var <- r0 * tau / xx\n\n u <- gamma(1/2) / beta(a1/2, 1/2)\n mb <- post_mean * sqrt(2 / b1) * u\n vb <- post_var + post_mean^2 * 2 / b1 * (1 / beta(a1/2, 1) - u^2)\n\n return(sum(pip * (vb + mb^2)))\n}\n\n# KL divergence for the NIG variational form. KL_beta uses the Gaussian-\n# Gaussian KL with shared sigma^2 scaling (sigma^2 log-dets cancel; only\n# mu^2/(sigma^2 V) survives). KL_sigma2 is the closed form for IG||IG.\n#' @keywords internal\ncompute_kl_NIG <- function(alpha, post_mean, post_mean2, pi, V, a0, b0, a_post, b_post,\n s_j_sq) {\n eps <- .Machine$double.eps\n\n # KL for categorical assignment q(gamma) || p(gamma)\n KL_gamma <- sum(alpha * (log(pmax(alpha, eps)) - log(pmax(pi, eps))))\n\n # KL for b given sigma^2, integrated over q(sigma^2)\n E_inv_sigma2 <- a_post / b_post\n KL_beta <- 0.5 * sum(alpha * (\n log(V) - log(pmax(s_j_sq, eps)) + s_j_sq / V +\n post_mean^2 * E_inv_sigma2 / V - 1\n ))\n\n # KL between IG posterior and IG prior (closed form)\n KL_sigma2 <- lgamma(a0) - lgamma(a_post) +\n a0 * log(b_post / b0) +\n (a_post - a0) * digamma(a_post) -\n a_post + (a_post * b0) / b_post\n\n return(as.numeric(KL_gamma + KL_beta + KL_sigma2))\n}\n\n# Compute log-normalizing factor for the IG(a,b) distribution\n#' @keywords internal\ninv_gamma_factor <- function(a, b) {\n return(a * log(b) - lgamma(a))\n}\n\n# Compute null log-likelihood under NIG prior\n#' @keywords internal\ncompute_null_loglik_NIG <- function(n, yy, a0, b0, use_NIG = FALSE) {\n # No null log-likelihood for non-NIG prior\n if (!use_NIG) {\n return(NULL)\n }\n\n return(-n * log(2 * pi) / 2 +\n inv_gamma_factor(a0 / 2, b0 / 2) -\n inv_gamma_factor((a0 + n) / 2, (b0 + yy) / 2))\n}\n\n# Compute marginal log-likelihood for single effect regression\n#' @keywords internal\ncompute_marginal_loglik <- function(lbf_model, n, yy, a0, b0, use_NIG = FALSE) {\n # No marginal log-likelihood computation for non-NIG prior\n if (!use_NIG) {\n return(NULL)\n }\n\n ll0 <- compute_null_loglik_NIG(n, yy, a0, b0, use_NIG = TRUE)\n return(lbf_model + ll0)\n}\n\n# Estimate residual variance\n#' @keywords internal\nest_residual_variance <- function(data, model) {\n resid_var <- (1 / data$n) * get_ER2(data, model)\n if (resid_var < 0) {\n stop(\"est_residual_variance() failed: the estimated value is negative\")\n }\n return(resid_var)\n}\n\n\n# =============================================================================\n# SuSiE-ASH SHARED UTILITIES\n#\n# Functions shared between individual-level and summary-statistics ash paths.\n# The masking logic is data-type-agnostic (only needs correlation matrix),\n# while the mr.ash fitting is dispatched to either mr.ash (individual) or\n# mr.ash.rss (summary stats).\n#\n# Design: individual-level data uses mr.ash directly, SS data uses mr.ash.rss.\n# The init/masking/cleanup logic is shared since it depends only on model\n# dimensions (n, p, L), not on data representation.\n# =============================================================================\n\n# Initialize ash tracking fields on a model object\n#\n# Shared between individual and SS model initialization.\n# Individual models store X_theta (n-vector); SS models store XtX_theta (p-vector).\n#\n# @param model Model object to augment\n# @param n Number of observations (used only by individual path for X_theta)\n# @param p Number of predictors\n# @param L Number of single effects\n# @param is_individual Whether this is individual-level data\n#\n# @return Model with ash tracking fields added\n#\n# @keywords internal\ninit_ash_fields <- function(model, n, p, L, is_individual = FALSE) {\n model$tau2 <- 0\n model$theta <- rep(0, p)\n model$ash_iter <- 0\n model$ash_pi <- NULL\n model$ash_s0 <- NULL\n\n if (is_individual) {\n model$X_theta <- rep(0, n)\n } else {\n model$XtX_theta <- rep(0, p)\n }\n\n return(model)\n}\n\ninit_ash_fields_filter_archived <- function(model, n, p, L, is_individual = FALSE) {\n model <- init_ash_fields(model, n, p, L, is_individual)\n\n # Additional tracking fields for the archived filter-based masking\n model$masked <- rep(FALSE, p)\n model$diffuse_iter_count <- rep(0, L)\n model$prev_sentinel <- rep(0, L)\n model$unmask_candidate_iters <- rep(0, p)\n model$ever_unmasked <- rep(FALSE, p)\n model$force_exposed_iter <- rep(0, p)\n model$ever_diffuse <- rep(0, L)\n model$second_chance_used <- rep(FALSE, p)\n model$prev_case <- rep(0, L)\n\n return(model)\n}\n\n# Update ash variance components: coordinate SuSiE and Mr.ASH\n#\n# Manages the interaction between SuSiE's sparse effects (beta) and\n# Mr.ASH's dense effects (theta). Uses three zones to prevent Mr.ASH\n# from absorbing signals SuSiE is fine-mapping:\n#\n# SUBTRACT: Trusted effects are fully removed from Mr.ASH residuals.\n# Mr.ASH cannot see or absorb these confirmed signals.\n# MASK: Emerging effects have theta forced to 0 in their LD\n# neighborhoods. Mr.ASH cannot absorb signal here, giving SuSiE\n# time to resolve these effects.\n# EXPOSE: Positions not covered by subtraction or masking. Mr.ASH\n# absorbs signal freely. LD spillover and false positives that\n# get flagged and unmasked end up here.\n#\n# Spillover is detected in two ways:\n# Across-SER: Two effects whose sentinels are in tight LD (|r| > 0.9)\n# are colliding on the same signal. Both get flagged.\n# Within-SER: A sentinel that jumps to a distant variant (|r| < 0.5)\n# indicates the effect is not well-localized. Gets flagged.\n#\n# Flagged effects are initially masked (protected). After unmask_delay\n# iterations, the OLD sentinel's LD neighborhood is selectively exposed\n# to Mr.ASH, allowing absorption of spillover at the confusion point\n# while the effect's current position stays protected.\n#\n# @param data Data object (individual or SS).\n# @param model Current SuSiE model.\n# @param params Parameters object.\n#\n# @return List of updated model fields (sigma2, tau2, theta, etc.)\n# to be merged into model via modifyList.\n#\n# @keywords internal\n## V0-faithful three-case classification for BB+ash filter\n## Replaces the body of update_ash_variance_components()\n## Key change: standard purity (not effect_purity) for case classification\n## + force_mask for diffuse slots' sentinel LD (from V0)\n\nupdate_ash_variance_components <- function(data, model, params) {\n\n # BB+ash filter: V0's 3-tier classifier (diffuse / uncertain / confident)\n # with c_hat marginalization of CASE 3 subtraction.\n # Output: b_confident (subtract from mr.ash residual) and mask.\n\n # --- User parameters ---\n purity_threshold <- if (!is.null(params$purity_threshold)) params$purity_threshold else 0.5\n pip_threshold <- if (!is.null(params$pip_threshold)) params$pip_threshold else 0.1\n ld_threshold <- if (!is.null(params$ld_threshold)) params$ld_threshold else 0.5\n\n # --- Internal constants ---\n diffuse_purity <- 0.1 # purity below this = CASE 1\n cs_threshold <- 0.9 # working CS coverage\n neighborhood_pip_threshold <- 0.4 # LD-spread mask threshold\n collision_threshold <- 0.9 # strong LD = same signal\n tight_ld_threshold <- 0.95 # WTE exposure region\n diffuse_iter_count <- 2L # CASE 2 stable iters before WTE\n second_chance_wait <- 3L # iters after expose before re-mask\n delayed_unmask_iter <- 2L # iters unwanted before unmask\n\n is_individual <- inherits(data, \"individual\")\n L <- nrow(model$alpha)\n p <- ncol(model$alpha)\n if (is.null(model$ash_iter)) model$ash_iter <- 0L\n model$ash_iter <- model$ash_iter + 1L\n\n # Lazy-init state\n if (is.null(model$prev_case)) model$prev_case <- rep(0L, L)\n if (is.null(model$prev_sentinel)) model$prev_sentinel <- rep(0L, L)\n if (is.null(model$ever_diffuse)) model$ever_diffuse <- rep(0L, L)\n if (is.null(model$diffuse_iter_count)) model$diffuse_iter_count <- rep(0L, L)\n if (is.null(model$masked)) model$masked <- rep(FALSE, p)\n if (is.null(model$ever_unmasked)) model$ever_unmasked <- rep(FALSE, p)\n if (is.null(model$unmask_candidate_iters)) model$unmask_candidate_iters <- rep(0L, p)\n if (is.null(model$force_exposed_iter)) model$force_exposed_iter <- rep(0L, p)\n if (is.null(model$second_chance_used)) model$second_chance_used <- rep(FALSE, p)\n\n xcorr_result <- get_xcorr(data)\n Xcorr <- xcorr_result$Xcorr\n data <- xcorr_result$data\n\n # c_hat = BB posterior slot-active weight (fallback 1 = V0).\n c_hat <- if (!is.null(model$slot_weights)) model$slot_weights else rep(1, L)\n\n # First pass: sentinels, purity, activity\n sentinels <- apply(model$alpha, 1, which.max)\n effect_purity <- rep(1.0, L)\n is_active <- rep(FALSE, L)\n for (l in 1:L) {\n a <- model$alpha[l, ]\n is_active[l] <- (max(a) - min(a)) >= 5e-5\n alpha_order <- order(a, decreasing = TRUE)\n cs_size <- min(sum(cumsum(a[alpha_order]) <= cs_threshold) + 1L, p)\n if (cs_size > 1) {\n cs_indices <- alpha_order[1:cs_size]\n R_cs <- abs(Xcorr[cs_indices, cs_indices])\n effect_purity[l] <- min(R_cs[upper.tri(R_cs)])\n }\n }\n\n # Collision: sentinels of two active slots in strong LD -> bump ever_diffuse\n current_collision <- rep(FALSE, L)\n for (l in which(is_active)) {\n others <- setdiff(which(is_active), l)\n if (length(others) == 0) next\n if (any(abs(Xcorr[sentinels[l], sentinels[others]]) > collision_threshold)) {\n current_collision[l] <- TRUE\n model$ever_diffuse[l] <- model$ever_diffuse[l] + 1L\n }\n }\n\n b_confident <- rep(0, p)\n alpha_protected <- matrix(0, nrow = L, ncol = p)\n force_unmask <- rep(FALSE, p)\n force_mask <- rep(FALSE, p)\n\n # Second pass: classify slots\n current_case <- rep(0L, L)\n for (l in 1:L) {\n purity <- effect_purity[l]\n sentinel <- sentinels[l]\n\n # Sentinel-jump reset: if sentinel moved to a non-tight-LD position, reset\n # the CASE 2 stability counter so WTE doesn't fire on a newly-picked signal.\n if (sentinel != model$prev_sentinel[l] && model$prev_sentinel[l] > 0L) {\n if (abs(Xcorr[sentinel, model$prev_sentinel[l]]) < tight_ld_threshold) {\n model$diffuse_iter_count[l] <- 0L\n }\n }\n\n can_be_confident <- (purity >= purity_threshold) && (model$ever_diffuse[l] == 0L)\n\n if (purity < diffuse_purity) {\n # CASE 1: diffuse. Narrow protection + force_mask on sentinel LD.\n current_case[l] <- 1L\n model$diffuse_iter_count[l] <- 0L\n moderate_ld <- abs(Xcorr[sentinel, ]) > ld_threshold\n to_protect <- moderate_ld | (model$alpha[l, ] > 5 / p)\n alpha_protected[l, to_protect] <- model$alpha[l, to_protect]\n force_mask <- force_mask | moderate_ld\n } else if (!can_be_confident) {\n # CASE 2: uncertain. Collision -> reset counter only (no alpha protection).\n # Otherwise full alpha protection + wait-then-expose.\n current_case[l] <- 2L\n if (current_collision[l]) {\n model$diffuse_iter_count[l] <- 0L\n } else {\n model$diffuse_iter_count[l] <- model$diffuse_iter_count[l] + 1L\n alpha_protected[l, ] <- model$alpha[l, ]\n if (model$diffuse_iter_count[l] >= diffuse_iter_count) {\n tight_ld <- abs(Xcorr[sentinel, ]) > tight_ld_threshold\n expose <- tight_ld & !model$second_chance_used\n newly <- expose & (model$force_exposed_iter == 0L)\n model$force_exposed_iter[newly] <- model$ash_iter\n if (any(newly)) model$diffuse_iter_count[l] <- 0L\n alpha_protected[l, expose] <- 0\n force_unmask <- force_unmask | expose\n }\n }\n } else {\n # CASE 3: confident. Full protection + c_hat-weighted subtraction.\n current_case[l] <- 3L\n model$diffuse_iter_count[l] <- 0L\n alpha_protected[l, ] <- model$alpha[l, ]\n b_confident <- b_confident + c_hat[l] * model$alpha[l, ] * model$mu[l, ]\n }\n }\n\n # Oscillation: slot flipping between CASE 2 and CASE 3 is unstable -> mark\n # sticky-diffuse, and if it landed on CASE 3 this iter, reverse the\n # subtraction we just added (slot is not trustworthy yet).\n oscillated <- model$prev_case != 0L & current_case != 0L &\n ((model$prev_case == 2L & current_case == 3L) |\n (model$prev_case == 3L & current_case == 2L))\n unstable_case3 <- oscillated & (current_case == 3L)\n model$ever_diffuse[oscillated] <- model$ever_diffuse[oscillated] + 1L\n for (l in which(unstable_case3)) {\n b_confident <- b_confident - c_hat[l] * model$alpha[l, ] * model$mu[l, ]\n }\n model$prev_case <- current_case\n model$prev_sentinel <- sentinels\n\n # Mask: PIP-based union, with per-position persistence\n pip_protected <- susie_get_pip(alpha_protected)\n LD_adj <- abs(Xcorr) > ld_threshold\n neighborhood_pip <- as.vector(LD_adj %*% pip_protected)\n want_masked <- (neighborhood_pip > neighborhood_pip_threshold) |\n (pip_protected > pip_threshold) |\n force_mask\n\n # Delayed unmask: count iters a masked position is no longer wanted\n reset_idx <- want_masked | !model$masked\n model$unmask_candidate_iters[!reset_idx] <- model$unmask_candidate_iters[!reset_idx] + 1L\n model$unmask_candidate_iters[reset_idx] <- 0L\n ready_to_unmask <- model$masked &\n ((model$unmask_candidate_iters >= delayed_unmask_iter & !model$ever_unmasked) | force_unmask)\n\n model$ever_unmasked[ready_to_unmask] <- TRUE\n masked <- (model$masked | want_masked) & !ready_to_unmask & !model$ever_unmasked\n\n # Second chance\n should_restore <- (model$force_exposed_iter > 0L) &\n (model$ash_iter - model$force_exposed_iter >= second_chance_wait) &\n !model$second_chance_used\n if (any(should_restore)) {\n model$second_chance_used[should_restore] <- TRUE\n model$force_exposed_iter[should_restore] <- 0L\n model$ever_unmasked[should_restore] <- FALSE\n masked[should_restore] <- TRUE\n }\n model$masked <- masked\n mask <- masked\n\n # Mr.ASH fit\n .skip_mrash <- getOption(\"susie.skip_mrash\", FALSE)\n model$theta[mask] <- 0\n if (.skip_mrash) {\n theta_new <- model$theta; theta_new[mask] <- 0\n ash_result <- list(\n beta = theta_new,\n sigma2 = if (!is.null(model$sigma2)) model$sigma2 else 1,\n pi = model$ash_pi,\n tau2 = if (!is.null(model$tau2)) model$tau2 else 0)\n } else {\n convtol <- if (model$ash_iter < 2) 1e-3 else 1e-4\n if (is_individual) {\n ash_result <- compute_ash_from_individual_data(\n data$X, data$y, b_confident, model, params, convtol)\n } else {\n ash_result <- compute_ash_from_summary_stats(\n data, b_confident, model, params, convtol)\n }\n theta_new <- ash_result$beta\n theta_new[mask] <- 0\n }\n\n # Diagnostic\n .ash_debug <- TRUE\n if (.ash_debug) {\n model$ever_uncertain <- model$ever_diffuse > 0\n diag_df <- diagnose_bb_ash_iter(\n model, Xcorr, mask, b_confident,\n sentinels, current_collision,\n current_case == 3L, current_case == 3L,\n which(current_case == 2L), which(model$V > 0), c_hat,\n list(beta = theta_new, sigma2 = ash_result$sigma2, pi = ash_result$pi),\n p,\n high_chat = integer(0), low_chat = integer(0),\n collision_threshold = collision_threshold,\n purity_threshold = ld_threshold,\n masking_threshold = ld_threshold,\n nPIP_threshold = pip_threshold,\n c_hat_excess_threshold = NA,\n alpha_entropy_threshold = NA,\n slot_prior = params$slot_prior,\n mask_smoothness = effect_purity,\n mask_amount = c_hat,\n mask_concentration = current_case,\n mask_burnin = model$ever_diffuse,\n mask_spread_pip_at_sent = pip_protected[sentinels],\n mask_pip_prot_at_sent = pip_protected[sentinels])\n if (is.null(model$.diag_env)) model$.diag_env <- new.env(parent = emptyenv())\n if (is.null(model$.diag_env$history)) model$.diag_env$history <- list()\n model$.diag_env$history[[length(model$.diag_env$history) + 1]] <- diag_df\n }\n\n result <- list(\n sigma2 = ash_result$sigma2,\n tau2 = ash_result$tau2,\n theta = theta_new,\n ash_pi = ash_result$pi,\n ash_iter = model$ash_iter,\n prev_case = model$prev_case,\n prev_sentinel = model$prev_sentinel,\n ever_diffuse = model$ever_diffuse,\n diffuse_iter_count = model$diffuse_iter_count,\n masked = model$masked,\n ever_unmasked = model$ever_unmasked,\n unmask_candidate_iters = model$unmask_candidate_iters,\n force_exposed_iter = model$force_exposed_iter,\n second_chance_used = model$second_chance_used,\n .diag_env = model$.diag_env\n )\n\n if (is_individual) {\n result$X_theta <- as.vector(data$X %*% theta_new)\n } else {\n result$XtX_theta <- as.vector(compute_Rv(data, theta_new))\n }\n\n return(result)\n}\n\n# Archived: Original filter-based ash variance component update\n#\n# Performs the full ash update cycle with the Diffusion-Aware masking\n# heuristic: get correlation matrix, compute masking (3-case classification,\n# WaitThenExpose, collision detection, nPIP masking), fit mr.ash, mask theta.\n# This is the original SuSiE-ASH implementation with 9+ tuning parameters\n# and per-effect/per-variant tracking arrays.\n#\n# Kept for internal diagnostics/archiving via unmappable_effects=\"ash_filter_archived\".\n# The default \"ash\" path now uses update_ash_variance_components() (c_hat + 3 LD rules).\n#\n# @param data Data object (individual or SS)\n# @param model Current SuSiE model\n# @param params Parameters object\n#\n# @return List with sigma2, tau2, theta, fitted theta, and all tracking fields\n#\n# @keywords internal\nupdate_ash_variance_components_filter_archived <- function(data, model, params) {\n is_individual <- inherits(data, \"individual\")\n\n # Step 1: Get correlation matrix (cached after first call)\n xcorr_result <- get_xcorr(data)\n Xcorr <- xcorr_result$Xcorr\n data <- xcorr_result$data\n\n # Step 2: Compute masking (shared 3-case classification)\n mask_result <- compute_ash_masking(Xcorr, model, params)\n b_confident <- mask_result$b_confident\n masked <- mask_result$masked\n model <- mask_result$model\n\n # Step 3: Fit Mr.ASH (dispatch to individual or SS backend)\n # Set options(susie.skip_mrash = TRUE) to diagnose without mr.ash.\n .skip_mrash <- getOption(\"susie.skip_mrash\", FALSE)\n if (.skip_mrash) {\n p_v0 <- ncol(model$alpha)\n mrash_output <- list(\n beta = model$theta, sigma2 = if (!is.null(model$sigma2)) model$sigma2 else 1,\n pi = model$ash_pi, tau2 = if (!is.null(model$tau2)) model$tau2 else 0,\n sa2 = if (!is.null(model$ash_s0)) model$ash_s0 else 0)\n mrash_output$beta[masked] <- 0\n } else {\n convtol <- if (model$ash_iter < 2) 1e-3 else 1e-4\n if (is_individual) {\n mrash_output <- compute_ash_from_individual_data(\n data$X, data$y, b_confident, model, params, convtol\n )\n } else {\n mrash_output <- compute_ash_from_summary_stats(\n data, b_confident, model, params, convtol\n )\n }\n }\n\n # Step 4: Zero out theta for masked variants\n theta_new <- mrash_output$beta\n theta_new[masked] <- 0\n\n # V0 diagnostic: capture data.frame and accumulate on model\n .ash_debug <- TRUE\n if (.ash_debug) {\n diag_df <- diagnose_ash_filter_archived_iter(\n model, Xcorr, masked, b_confident,\n mask_result$sentinels, mask_result$effect_purity,\n mask_result$current_case, mask_result$current_collision,\n mrash_output)\n if (is.null(model$.diag_env)) model$.diag_env <- new.env(parent = emptyenv())\n if (is.null(model$.diag_env$history)) model$.diag_env$history <- list()\n model$.diag_env$history[[length(model$.diag_env$history) + 1]] <- diag_df\n }\n\n # Step 5: Compute fitted theta (data-representation-specific)\n result <- list(\n sigma2 = mrash_output$sigma2,\n tau2 = mrash_output$tau2,\n theta = theta_new,\n ash_pi = mrash_output$pi,\n sa2 = mrash_output$sa2,\n ash_iter = model$ash_iter,\n diffuse_iter_count = model$diffuse_iter_count,\n prev_sentinel = model$prev_sentinel,\n masked = masked,\n unmask_candidate_iters = model$unmask_candidate_iters,\n ever_unmasked = model$ever_unmasked,\n force_exposed_iter = model$force_exposed_iter,\n second_chance_used = model$second_chance_used,\n ever_diffuse = model$ever_diffuse,\n prev_case = model$prev_case,\n .diag_env = model$.diag_env\n )\n\n if (is_individual) {\n result$X_theta <- as.vector(data$X %*% theta_new)\n } else {\n result$XtX_theta <- as.vector(compute_Rv(data, theta_new))\n }\n\n return(result)\n}\n\n# Remove ash-specific runtime fields from model\n#\n# Shared between cleanup_model.individual() and cleanup_model.ss().\n#\n# @param model Model object\n#\n# @return Model with ash runtime fields removed\n#\n# @keywords internal\ncleanup_ash_fields <- function(model) {\n # Remove internal tracking fields from the new ash path.\n # Keep: tau2, theta, ash_pi (user-visible results)\n for (field in c(\"X_theta\", \"XtX_theta\", \"ash_iter\", \"ash_s0\",\n \"ever_uncertain\", \"prev_sentinel\")) {\n model[[field]] <- NULL\n }\n return(model)\n}\n\ncleanup_ash_fields_filter_archived <- function(model) {\n # Remove internal tracking fields from the archived filter path.\n for (field in c(\"X_theta\", \"XtX_theta\", \"ash_iter\", \"ash_s0\",\n \"masked\", \"diffuse_iter_count\", \"prev_sentinel\",\n \"unmask_candidate_iters\", \"ever_unmasked\",\n \"force_exposed_iter\", \"ever_diffuse\",\n \"second_chance_used\", \"prev_case\")) {\n model[[field]] <- NULL\n }\n return(model)\n}\n\n# Get or compute correlation matrix for ash masking\n#\n# For SS data: derives from XtX via safe_cov2cor (cheap scaling).\n# For individual data: computes cor(X) and caches it on the data object.\n#\n# @param data Data object\n#\n# @return List with Xcorr and (possibly updated) data object\n#\n# @keywords internal\nget_xcorr <- function(data) {\n # Check for cached correlation matrix\n if (!is.null(data$Xcorr_cache)) {\n return(list(Xcorr = data$Xcorr_cache, data = data))\n }\n\n if (!is.null(data$XtX)) {\n # SS path: derive from XtX\n if (any(!(diag(data$XtX) %in% c(0, 1)))) {\n Xcorr <- safe_cov2cor(data$XtX)\n } else {\n Xcorr <- data$XtX\n }\n } else if (!is.null(data$X)) {\n # Individual path: compute correlation from X\n Xcorr <- safe_cor(data$X)\n } else {\n stop(\"Cannot compute correlation matrix: data has neither XtX nor X\")\n }\n\n # Cache for future iterations\n data$Xcorr_cache <- Xcorr\n return(list(Xcorr = Xcorr, data = data))\n}\n\n# Compute ash masking: classify effects, determine protection/masking\n#\n# KEY INSIGHT: Protect SuSiE's sparse effects from Mr.ASH absorption,\n# but let Mr.ASH absorb unmappable and unreliable signals.\n#\n# Two types of diffusion (both indicate unreliable effects):\n# 1. WITHIN-EFFECT: Low purity - spread across variants not in tight LD\n# 2. CROSS-EFFECT: Sentinel collision - multiple effects compete for\n# same position (composite signal, not clean single causal)\n#\n# Classification into three cases:\n# CASE 1 (diffuse): purity < 0.1 - protect neighborhood loosely\n# CASE 2 (uncertain): low purity OR ever_diffuse - expose to Mr.ASH\n# CASE 3 (confident): purity >= 0.5 AND never diffuse - subtract from residuals\n#\n# Cross-effect diffusion tracking:\n# - Detect via sentinel collision (sentinels in tight LD across effects)\n# - Mark effect as ever_diffuse (sticky, effect-level)\n# - ever_diffuse effects get zero protection permanently\n# - Real signals survive Mr.ASH competition; composites get absorbed\n#\n# Low purity (non-diffuse) effects:\n# - Use wait-then-expose mechanism\n# - After diffuse_iter_count stable iterations, expose sentinel neighborhood\n# - If Mr.ASH absorbs it, the signal was synthetic\n# - Second-chance mechanism: after wait period, restore masking to check\n#\n# @param Xcorr Correlation matrix (p x p)\n# @param model Current SuSiE model (with alpha, mu, tracking fields)\n# @param params Parameters object\n#\n# @return List with b_confident, masked, and updated model tracking fields\n#\n# @keywords internal\ncompute_ash_masking <- function(Xcorr, model, params) {\n # --- Protection thresholds ---\n neighborhood_pip_threshold <- if (!is.null(params$neighborhood_pip_threshold)) params$neighborhood_pip_threshold else 0.4\n direct_pip_threshold <- if (!is.null(params$direct_pip_threshold)) params$direct_pip_threshold else 0.1\n signal_separation_ld <- if (!is.null(params$signal_separation_ld)) params$signal_separation_ld else 0.5\n\n # --- Purity thresholds ---\n cs_threshold <- if (!is.null(params$working_cs_threshold)) params$working_cs_threshold else 0.9\n cs_formation_threshold <- if (!is.null(params$cs_formation_threshold)) params$cs_formation_threshold else 0.1\n purity_threshold <- if (!is.null(params$purity_threshold)) params$purity_threshold else 0.5\n\n # --- LD thresholds for collision and exposure ---\n collision_threshold <- if (!is.null(params$collision_threshold)) params$collision_threshold else 0.9\n tight_ld_threshold <- if (!is.null(params$tight_ld_threshold)) params$tight_ld_threshold else 0.95\n\n # --- Iteration counters for CASE 2 ---\n diffuse_iter_count <- if (!is.null(params$diffuse_iter_count)) params$diffuse_iter_count else 2\n track_sentinel <- if (!is.null(params$track_sentinel)) params$track_sentinel else TRUE\n\n # --- Second chance mechanism ---\n second_chance_wait <- if (!is.null(params$second_chance_wait)) params$second_chance_wait else 3\n\n # --- Unmasking stability ---\n delayed_unmask_iter <- 2\n\n L <- nrow(model$alpha)\n p <- ncol(model$alpha)\n model$ash_iter <- model$ash_iter + 1\n\n # =========================================================================\n # First pass: Compute sentinels and purity\n # =========================================================================\n sentinels <- apply(model$alpha, 1, which.max)\n effect_purity <- rep(NA, L)\n\n for (l in 1:L) {\n alpha_order <- order(model$alpha[l,], decreasing = TRUE)\n cumsum_alpha <- cumsum(model$alpha[l, alpha_order])\n cs_size <- sum(cumsum_alpha <= cs_threshold) + 1\n cs_indices <- alpha_order[1:min(cs_size, p)]\n effect_purity[l] <- get_purity(cs_indices, X = NULL, Xcorr = Xcorr, use_rfast = FALSE)[1]\n }\n\n # Detect current collision and update ever_diffuse\n current_collision <- rep(FALSE, L)\n for (l in 1:L) {\n if (max(model$alpha[l,]) - min(model$alpha[l,]) < 5e-5) next\n sentinel_l <- sentinels[l]\n for (other_l in (1:L)[-l]) {\n if (max(model$alpha[other_l,]) - min(model$alpha[other_l,]) < 5e-5) next\n if (abs(Xcorr[sentinel_l, sentinels[other_l]]) > collision_threshold) {\n current_collision[l] <- TRUE\n }\n }\n model$ever_diffuse[l] <- model$ever_diffuse[l] + current_collision[l]\n }\n\n # Initialize per-iteration outputs\n b_confident <- rep(0, p)\n alpha_protected <- matrix(0, nrow = L, ncol = p)\n force_unmask <- rep(FALSE, p)\n force_mask <- rep(FALSE, p)\n\n # =========================================================================\n # Second pass: Classify effects and determine protection\n # =========================================================================\n current_case <- rep(0, L)\n\n for (l in 1:L) {\n purity <- effect_purity[l]\n sentinel <- sentinels[l]\n\n if (track_sentinel && sentinel != model$prev_sentinel[l] && model$prev_sentinel[l] > 0) {\n if (abs(Xcorr[sentinel, model$prev_sentinel[l]]) < tight_ld_threshold) {\n model$diffuse_iter_count[l] <- 0\n }\n }\n\n is_ever_diffuse <- model$ever_diffuse[l] > 0\n can_be_confident <- (purity >= purity_threshold) && !is_ever_diffuse\n\n if (purity < cs_formation_threshold) {\n # CASE 1: Diffuse within effect\n current_case[l] <- 1\n model$diffuse_iter_count[l] <- 0\n moderate_ld_with_sentinel <- abs(Xcorr[sentinel,]) > signal_separation_ld\n meaningful_alpha <- model$alpha[l,] > 5/p\n to_protect <- moderate_ld_with_sentinel | meaningful_alpha\n alpha_protected[l, to_protect] <- model$alpha[l, to_protect]\n force_mask <- force_mask | moderate_ld_with_sentinel\n } else if (!can_be_confident) {\n # CASE 2: Uncertain\n current_case[l] <- 2\n if (current_collision[l]) {\n model$diffuse_iter_count[l] <- 0\n } else {\n model$diffuse_iter_count[l] <- model$diffuse_iter_count[l] + 1\n if (model$diffuse_iter_count[l] >= diffuse_iter_count) {\n tight_ld_with_sentinel <- abs(Xcorr[sentinel,]) > tight_ld_threshold\n newly_exposed <- tight_ld_with_sentinel &\n !model$second_chance_used &\n (model$force_exposed_iter == 0)\n model$force_exposed_iter[newly_exposed] <- model$ash_iter\n if (any(newly_exposed)) {\n model$diffuse_iter_count[l] <- 0\n }\n alpha_protected[l,] <- model$alpha[l,]\n expose_positions <- tight_ld_with_sentinel & !model$second_chance_used\n alpha_protected[l, expose_positions] <- 0\n force_unmask <- force_unmask | expose_positions\n } else {\n alpha_protected[l,] <- model$alpha[l,]\n }\n }\n } else {\n # CASE 3: Confident\n current_case[l] <- 3\n model$diffuse_iter_count[l] <- 0\n b_confident <- b_confident + model$alpha[l,] * model$mu[l,]\n alpha_protected[l,] <- model$alpha[l,]\n }\n\n model$prev_sentinel[l] <- sentinel\n }\n\n # =========================================================================\n # Oscillation detection\n # =========================================================================\n for (l in 1:L) {\n prev <- model$prev_case[l]\n curr <- current_case[l]\n if (curr == 0 || prev == 0) next\n if ((prev == 2 && curr == 3) || (prev == 3 && curr == 2)) {\n model$ever_diffuse[l] <- model$ever_diffuse[l] + 1\n if (curr == 3) {\n b_confident <- b_confident - model$alpha[l,] * model$mu[l,]\n }\n }\n }\n model$prev_case <- current_case\n\n # =========================================================================\n # Masking logic\n # =========================================================================\n pip_protected <- susie_get_pip(alpha_protected)\n\n LD_adj <- abs(Xcorr) > signal_separation_ld\n neighborhood_pip <- as.vector(LD_adj %*% pip_protected)\n want_masked <- (neighborhood_pip > neighborhood_pip_threshold) |\n (pip_protected > direct_pip_threshold) |\n force_mask\n\n dont_want_mask <- !want_masked\n model$unmask_candidate_iters[model$masked & dont_want_mask] <-\n model$unmask_candidate_iters[model$masked & dont_want_mask] + 1\n model$unmask_candidate_iters[want_masked | !model$masked] <- 0\n\n ready_to_unmask <- (model$masked &\n (model$unmask_candidate_iters >= delayed_unmask_iter) &\n !model$ever_unmasked) |\n (model$masked & force_unmask)\n\n model$ever_unmasked[ready_to_unmask] <- TRUE\n masked <- (model$masked | want_masked) & !ready_to_unmask & !model$ever_unmasked\n\n # Second chance\n waited_long_enough <- (model$force_exposed_iter > 0) &\n (model$ash_iter - model$force_exposed_iter) >= second_chance_wait\n should_restore <- waited_long_enough & !model$second_chance_used\n if (any(should_restore)) {\n model$second_chance_used[should_restore] <- TRUE\n model$force_exposed_iter[should_restore] <- 0\n model$ever_unmasked[should_restore] <- FALSE\n masked[should_restore] <- TRUE\n }\n\n list(\n b_confident = b_confident,\n masked = masked,\n model = model,\n sentinels = sentinels,\n effect_purity = effect_purity,\n current_case = current_case,\n current_collision = current_collision\n )\n}\n\n# Run Mr.ASH on individual-level data\n#\n# Computes residuals from raw X, y and calls mr.ash directly.\n#\n# @param X Design matrix (n x p)\n# @param y Response vector (n)\n# @param b_confident Vector of confident effects to subtract from residuals\n# @param model Current SuSiE model\n# @param params Parameters object\n# @param convtol Convergence tolerance for mr.ash\n#\n# @return List with beta, sigma2, pi, sa2, tau2\n#\n# @keywords internal\ncompute_ash_from_individual_data <- function(X, y, b_confident, model, params, convtol = 1e-4) {\n residuals <- y - X %*% b_confident\n\n mrash_output <- mr.ash(\n X = X,\n y = residuals,\n intercept = FALSE,\n standardize = FALSE,\n sigma2 = model$sigma2,\n update.sigma2 = params$estimate_residual_variance,\n beta.init = model$theta,\n pi = model$ash_pi,\n tol = list(convtol = convtol, epstol = 1e-12),\n verbose = params$verbose,\n max.iter = 1000\n )\n\n list(\n beta = mrash_output$beta,\n sigma2 = mrash_output$sigma2,\n pi = mrash_output$pi,\n sa2 = mrash_output$data$sa2,\n tau2 = sum(mrash_output$data$sa2 * mrash_output$pi) * mrash_output$sigma2\n )\n}\n\n# Run Mr.ASH using summary statistics (via mr.ash.rss)\n#\n# Computes residual summary statistics from sufficient statistics and\n# calls mr.ash.rss. This enables the \"ash\" unmappable effects mode\n# for susie_ss() and susie_rss() without requiring raw X and y.\n#\n# @param data Data object (must have $XtX, $Xty, $yty, $n)\n# @param b_confident Vector of confident effects to subtract from residuals\n# @param model Current SuSiE model\n# @param params Parameters object\n# @param convtol Convergence tolerance for mr.ash.rss\n#\n# @return List with beta, sigma2, pi, sa2, tau2\n#\n# @keywords internal\ncompute_ash_from_summary_stats <- function(data, b_confident, model, params, convtol = 1e-4) {\n # Compute residual sufficient statistics: r = y - X*b_confident\n # X'r = X'y - X'X * b_confident\n Xtr <- as.vector(data$Xty - data$XtX %*% b_confident)\n # r'r = y'y - 2*b'*X'y + b'*X'X*b\n rtr <- data$yty - 2 * sum(b_confident * data$Xty) +\n as.numeric(t(b_confident) %*% data$XtX %*% b_confident)\n\n XtXdiag <- diag(data$XtX)\n bhat <- Xtr / XtXdiag\n # Use n-2 df to match PVE adjustment in mr.ash.rss\n shat <- sqrt(pmax(0, (rtr - Xtr^2 / XtXdiag) / ((data$n - 2) * XtXdiag)))\n R_mat <- safe_cov2cor(data$XtX)\n var_r <- rtr / (data$n - 1)\n\n # Default prior grid (matching mr.ash defaults)\n if (is.null(model$ash_s0)) {\n sa2 <- (2^((0:24) / 25) - 1)^2\n model$ash_s0 <- sa2 / median(XtXdiag) * data$n\n }\n K <- length(model$ash_s0)\n if (is.null(model$ash_pi)) model$ash_pi <- rep(1 / K, K)\n\n fit <- mr.ash.rss(\n bhat = bhat, shat = shat, R = R_mat,\n var_y = var_r, n = data$n,\n sigma2_e = model$sigma2, s0 = model$ash_s0, w0 = model$ash_pi,\n mu1_init = model$theta,\n tol = convtol, max_iter = 1000,\n update_w0 = TRUE,\n update_sigma = params$estimate_residual_variance\n )\n\n list(\n beta = fit$beta,\n sigma2 = fit$sigma2,\n pi = fit$pi,\n sa2 = model$ash_s0,\n tau2 = sum(model$ash_s0 * fit$pi) * fit$sigma2\n )\n}\n\n# Run final Mr.ASH pass after SuSiE convergence\n#\n# After SuSiE converges, run one final Mr.ASH pass with ALL SuSiE effects\n# removed (unmasked) to get the final unmappable effects estimate.\n# Individual-level data uses mr.ash directly; SS data uses mr.ash.rss.\n#\n# @param data Data object\n# @param params Parameters object\n# @param model Converged SuSiE model\n#\n# @return Model with updated theta, tau2, ash_pi, and fitted theta values\n#\n# @keywords internal\nrun_final_ash_pass <- function(data, params, model) {\n b_susie <- colSums(model$alpha * model$mu)\n is_individual <- inherits(data, \"individual\")\n\n # Dispatch to individual (mr.ash) or SS (mr.ash.rss) backend\n if (is_individual) {\n mrash_output <- compute_ash_from_individual_data(\n data$X, data$y, b_susie, model, params\n )\n } else {\n mrash_output <- compute_ash_from_summary_stats(data, b_susie, model, params)\n }\n\n # Update model (shared across both paths)\n model$theta <- mrash_output$beta\n model$tau2 <- mrash_output$tau2\n model$ash_pi <- mrash_output$pi\n\n # Compute fitted theta (data-representation-specific)\n if (is_individual) {\n model$X_theta <- as.vector(data$X %*% model$theta)\n } else {\n model$XtX_theta <- compute_Rv(data, model$theta)\n }\n\n return(model)\n}\n\n# Compute ELBO for infinitesimal effects model\n#' @keywords internal\ncompute_elbo_inf <- function(alpha, mu, omega, lbf, sigma2, tau2, n, p,\n eigen_vectors, eigen_values, VtXty, yty) {\n L <- nrow(mu)\n\n b <- colSums(mu * alpha)\n Vtb <- t(eigen_vectors) %*% b\n diagVtMV <- Vtb^2\n tmpD <- rep(0, p)\n\n for (l in seq_len(L)) {\n bl <- mu[l, ] * alpha[l, ]\n Vtbl <- t(eigen_vectors) %*% bl\n diagVtMV <- diagVtMV - Vtbl^2\n tmpD <- tmpD + alpha[l, ] * (mu[l, ]^2 + 1 / omega[l, ])\n }\n\n diagVtMV <- diagVtMV + rowSums(sweep(t(eigen_vectors)^2, 2, tmpD, `*`))\n\n # Compute variance\n var <- tau2 * eigen_values + sigma2\n\n # Compute negative ELBO\n neg_elbo <- 0.5 * (n - p) * log(sigma2) + 0.5 / sigma2 * yty +\n sum(0.5 * log(var) -\n 0.5 * tau2 / sigma2 * VtXty^2 / var -\n Vtb * VtXty / var +\n 0.5 * eigen_values / var * diagVtMV)\n\n elbo <- -neg_elbo\n\n return(elbo)\n}\n\n# =============================================================================\n# CREDIBLE SETS & POST-PROCESSING\n#\n# Functions for generating final output including credible sets, posterior\n# inclusion probabilities, and summary statistics. These process the fitted\n# model into interpretable results.\n#\n# Functions: n_in_CS_x, in_CS_x, n_in_CS, in_CS, get_purity\n# =============================================================================\n\n# Find how many variables in the CS.\n# x is a probability vector.\n#' @keywords internal\nn_in_CS_x <- function(x, coverage = 0.9) {\n sum(cumsum(sort(x, decreasing = TRUE)) < coverage) + 1\n}\n\n# Return binary vector indicating if each point is in CS.\n# x is a probability vector.\n#' @keywords internal\nin_CS_x <- function(x, coverage = 0.9) {\n n <- n_in_CS_x(x, coverage)\n o <- order(x, decreasing = TRUE)\n result <- rep(0, length(x))\n result[o[1:n]] <- 1\n return(result)\n}\n\n# Returns an l-by-p binary matrix indicating which variables are in\n# susie credible sets.\n#' @keywords internal\nin_CS <- function(res, coverage = 0.9) {\n if (inherits(res, \"susie\")) {\n res <- res$alpha\n }\n return(t(apply(res, 1, function(x) in_CS_x(x, coverage))))\n}\n\n#' @keywords internal\nn_in_CS <- function(res, coverage = 0.9) {\n if (inherits(res, \"susie\")) {\n res <- res$alpha\n }\n return(apply(res, 1, function(x) n_in_CS_x(x, coverage)))\n}\n\n# Subsample and compute min, mean, median and max abs corr.\n#' @importFrom stats median\n#' @keywords internal\nget_purity <- function(pos, X, Xcorr, squared = FALSE, n = 100,\n use_rfast = NULL) {\n if (is.null(use_rfast)) {\n use_rfast <- requireNamespace(\"Rfast\", quietly = TRUE)\n }\n if (use_rfast) {\n get_upper_tri <- Rfast::upper_tri\n get_median <- Rfast::med\n } else {\n get_upper_tri <- function(R) R[upper.tri(R)]\n get_median <- median\n }\n if (length(pos) == 1) {\n return(c(1, 1, 1))\n } else {\n if (is.null(Xcorr)) {\n if (length(pos) > n) {\n pos <- sample(pos, n)\n }\n X_sub <- X[, pos]\n X_sub <- as.matrix(X_sub)\n value <- abs(get_upper_tri(safe_cor(X_sub)))\n } else {\n value <- abs(get_upper_tri(Xcorr[pos, pos]))\n }\n if (squared) {\n value <- value^2\n }\n result <- c(\n min(value),\n sum(value) / length(value),\n get_median(value)\n )\n if (any(is.na(result) | is.nan(result))) {\n stop(\"get_purity returned NaN/NA. Check for constant columns or data issues.\")\n }\n return(result)\n }\n}\n" }, { "path": "R/susie_workhorse.R", "content": "#' SuSiE workhorse function\n#'\n#' Main orchestration for the IBSS algorithm. When `params$L_greedy`\n#' is non-NULL, runs a greedy outer loop that grows `L` in linear\n#' steps of `params$L_greedy` until the fit has at least one empty\n#' slot (`min(lbf) < params$greedy_lbf_cutoff`, default `0.1`) or `L` reaches\n#' `params$L`. With `params$L_greedy = NULL` (default), runs a\n#' single fixed-`L` IBSS, output bit-identical to prior susieR.\n#'\n#' @param data Data object (individual, ss, or rss_lambda).\n#' @param params Validated params object.\n#' @return Complete fitted SuSiE model.\n#'\n#' @export\n#' @keywords internal\nsusie_workhorse <- function(data, params) {\n\n # Greedy-L outer loop. Saturation detected when any one slot's\n # lbf falls below greedy_lbf_cutoff (slot-invariant, single-round verdict).\n # Warm-start across rounds via params$model_init.\n if (!is.null(params$L_greedy)) {\n L_max <- params$L\n L_step <- params$L_greedy\n greedy_lbf_cutoff <- if (is.null(params$greedy_lbf_cutoff)) 0.1 else params$greedy_lbf_cutoff\n verbose <- isTRUE(params$verbose)\n history <- list()\n\n current_L <- min(L_step, L_max)\n fit <- NULL\n round_n <- 0L\n\n repeat {\n round_n <- round_n + 1L\n params_round <- params\n params_round$L_greedy <- NULL # avoid recursion\n params_round$L <- current_L\n if (!is.null(fit)) params_round$model_init <- fit\n fit <- susie_workhorse(data, params_round)\n\n min_lbf <- min(fit$lbf, na.rm = TRUE)\n action <- if (current_L >= L_max) \"L_max reached\"\n else if (min_lbf < greedy_lbf_cutoff) \"saturated\"\n else \"grow\"\n history[[round_n]] <- list(L = current_L, min_lbf = min_lbf,\n action = action)\n if (action != \"grow\") break\n current_L <- min(current_L + L_step, L_max)\n }\n if (verbose) {\n message(sprintf(\"[L_greedy] %d round%s, greedy_lbf_cutoff=%.3f, final L=%d\",\n round_n, if (round_n == 1L) \"\" else \"s\",\n greedy_lbf_cutoff, current_L))\n message(sprintf(\"%-6s %-5s %-10s %s\",\n \"round\", \"L\", \"min(lbf)\", \"action\"))\n for (i in seq_along(history)) {\n h <- history[[i]]\n message(sprintf(\"%-6d %-5d %-10.3f %s\",\n i, h$L, h$min_lbf, h$action))\n }\n }\n return(fit)\n }\n\n # Initialize model object\n model <- ibss_initialize(data, params)\n\n # Initialize ELBO & tracking\n elbo <- rep(as.numeric(NA), params$max_iter + 1)\n elbo[1] <- -Inf\n tracking <- list()\n\n # Initialize runtime state (convergence tracking, cleaned up at finalization)\n model$runtime <- list(\n prev_elbo = -Inf,\n prev_alpha = model$alpha\n )\n\n # Main IBSS iteration loop\n for (iter in seq_len(params$max_iter)) {\n # Store iteration snapshot for track_fit\n tracking <- track_ibss_fit(data, params, model, tracking, iter, elbo)\n\n # Update all L effects\n model <- ibss_fit(data, params, model)\n\n # Calculate objective and check convergence\n elbo[iter + 1] <- get_objective(data, params, model)\n model <- check_convergence(data, params, model, elbo, iter)\n\n # Update convergence state for next iteration\n model$runtime$prev_elbo <- elbo[iter + 1]\n model$runtime$prev_alpha <- model$alpha\n\n if (model$converged) {\n break\n }\n\n # Update variance components if not converged.\n # The method itself checks params to decide what to update,\n # allowing S3 overrides to update additional model parameters\n model <- update_model_variance(data, params, model)\n\n }\n\n # Check final convergence status\n if (!model$converged) {\n warning_message(paste(\"IBSS algorithm did not converge in\", params$max_iter, \"iterations!\"))\n }\n\n # Set ELBO from iterations\n model$elbo <- elbo[2:(iter + 1)]\n\n # For NIG prior, scale prior variance by residual variance mode.\n if (isTRUE(params$use_NIG))\n model$V <- model$V * model$rv\n \n # Zero out effects with negligible prior variance\n model <- trim_null_effects(data, params, model)\n\n model <- ibss_finalize(data, params, model, elbo, iter, tracking)\n\n # Run refinement if requested\n if (params$refine && !is.null(model$sets) && length(model$sets$cs) > 0) {\n model <- run_refine(model, data, params)\n }\n\n return(model)\n}\n" }, { "path": "R/univariate_regression.R", "content": "#' @title Perform Univariate Linear Regression Separately for Columns of X\n#' \n#' @description This function performs the univariate linear\n#' regression y ~ x separately for each column x of X. The estimated effect size\n#' and stardard error for each variable are outputted.\n#' \n#' @param X n by p matrix of regressors.\n#' \n#' @param y n-vector of response variables.\n#' \n#' @param Z Optional n by k matrix of covariates to be included in all\n#' regresions. If Z is not \\code{NULL}, the linear effects of\n#' covariates are removed from y first, and the resulting residuals\n#' are used in place of y.\n#' \n#' @param center If \\code{center = TRUE}, center X, y and Z.\n#' \n#' @param scale If \\code{scale = TRUE}, scale X, y and Z.\n#' \n#' @param return_residuals Whether or not to output the residuals if Z\n#' is not \\code{NULL}.\n#'\n#' @param method Either \\dQuote{sumstats} (faster implementation) or\n#' \\dQuote{lmfit} (uses \\code{\\link[stats]{.lm.fit}}).\n#'\n#' @return A list with two vectors containing the least-squares\n#' estimates of the coefficients (\\code{betahat}) and their standard\n#' errors (\\code{sebetahat}). Optionally, and only when a matrix of\n#' covariates \\code{Z} is provided, a third vector \\code{residuals}\n#' containing the residuals is returned.\n#' \n#' @examples\n#' set.seed(1)\n#' n = 1000\n#' p = 1000\n#' beta = rep(0,p)\n#' beta[1:4] = 1\n#' X = matrix(rnorm(n*p),nrow = n,ncol = p)\n#' X = scale(X,center = TRUE,scale = TRUE)\n#' y = drop(X %*% beta + rnorm(n))\n#' res = univariate_regression(X,y)\n#' plot(res$betahat/res$sebetahat)\n#' \n#' @importFrom stats lm\n#' @importFrom stats .lm.fit\n#' @importFrom stats coef\n#' @importFrom stats summary.lm\n#'\n#' @export\n#' \nunivariate_regression = function (X, y, Z = NULL, center = TRUE,\n scale = FALSE, return_residuals = FALSE,\n method = c(\"lmfit\", \"sumstats\")) {\n method <- match.arg(method)\n y_na <- which(is.na(y))\n if (length(y_na)) {\n X = X[-y_na,]\n y = y[-y_na]\n }\n if (center) {\n y = y - mean(y)\n X = scale(X,center = TRUE,scale = scale)\n } else \n X = scale(X,center = FALSE,scale = scale)\n X[is.nan(X)] = 0\n if (!is.null(Z)) {\n if (center)\n Z = scale(Z,center = TRUE,scale = scale)\n y = .lm.fit(Z,y)$residuals\n }\n\n # fast implementation: computes X'X and X'y without forming X\n if (method == \"sumstats\") {\n output <- try({\n n <- length(y)\n sy <- sum(y)\n yy <- sum(y * y)\n p <- ncol(X)\n res <- matrix(NA_real_, nrow = p, ncol = 2)\n \n for (i in seq_len(p)) {\n x <- X[, i]\n sx <- sum(x)\n sxx <- sum(x * x)\n sxy <- sum(x * y)\n\n # XtX and Xty for [1, x]\n # XtX = [[ n, sx ],\n # [ sx, sxx]]\n detXtX <- n * sxx - sx * sx\n if (!is.finite(detXtX) || detXtX <= 0) {\n warning_message(\"Column \", i, \" has zero variance after centering/scaling\")\n res[i, ] <- c(0, 0) # constant/degenerate column\n next\n }\n\n XtX <- matrix(c(n, sx, sx, sxx), nrow = 2, ncol = 2)\n Xty <- c(sy, sxy)\n\n # Solve (XtX) beta = Xty via Cholesky\n R <- chol(XtX) # XtX = R^T R\n beta <- backsolve(R, forwardsolve(t(R), Xty)) # slope is beta[2]\n\n # RSS = y'y - 2 beta^T X'y + beta^T XtX beta (no need to form\n # residuals)\n rss <- yy - 2 * sum(beta * Xty) +\n as.numeric(crossprod(beta, XtX %*% beta))\n sigma2 <- rss / (n - 2) # p = 2 (intercept + slope)\n\n # Var(beta) = sigma2 * (XtX)^{-1}; se(slope) = sqrt( ... [2,2] )\n XtX_inv <- chol2inv(R)\n se_slope <- sqrt(sigma2 * XtX_inv[2, 2])\n res[i, ] <- c(beta[2], se_slope)\n }\n res\n }, silent = TRUE)\n } else {\n # original .lm.fit-based implementation\n output = try(do.call(rbind,\n lapply(1:ncol(X), function (i) {\n g = .lm.fit(cbind(1,X[,i]),y)\n return(c(coef(g)[2],calc_stderr(cbind(1,X[,i]),\n g$residuals)[2]))\n })),\n silent = TRUE)\n }\n\n # Exception occurs, fall back to a safer but slower calculation.\n if (inherits(output,\"try-error\")) {\n output = matrix(0,ncol(X),2)\n for (i in 1:ncol(X)) {\n fit = summary(lm(y ~ X[,i]))$coef\n if (nrow(fit) == 2)\n output[i,] = as.vector(summary(lm(y ~ X[,i]))$coef[2,1:2])\n else {\n warning_message(\"Column \", i, \" has zero variance after centering/scaling\")\n output[i,] = c(0,0)\n }\n }\n }\n if (return_residuals && !is.null(Z)) \n return(list(betahat = output[,1],sebetahat = output[,2],residuals = y))\n else\n return(list(betahat = output[,1],sebetahat = output[,2]))\n}\n\n#' @rdname univariate_regression\n#' @export\ncalc_z = function (X, Y, center = FALSE, scale = FALSE) {\n univariate_z = function(X,Y,center,scale) {\n out = univariate_regression(X,Y,center = center,scale = scale)\n return(out$betahat/out$sebetahat)\n }\n if (is.null(dim(Y)))\n return(univariate_z(X,Y,center,scale))\n else\n return(do.call(cbind,lapply(1:ncol(Y),\n function(i) univariate_z(X,Y[,i],\n center = center,\n scale = scale))))\n}\n\n\n#' @title Per-Position Marginal OLS Regression of `Y` on Each Column of `X`\n#'\n#' @description Computes the marginal OLS regression coefficient and\n#' standard error for each `(X column, Y column)` pair, treating\n#' the regressions as independent. `X` is assumed column-centred\n#' (no intercept term in the per-pair regression); each `Y`\n#' column is treated independently. Returns the J x T matrices\n#' `Bhat` and `Shat`.\n#'\n#' Used internally by single-effect-regression style routines that\n#' need a per-position marginal estimate. Vectorised across columns\n#' of `Y` so callers can pass either a numeric vector (T = 1) or a\n#' numeric matrix (T > 1) without looping at the call site.\n#'\n#' @param X numeric matrix `n x J`, expected column-centred.\n#' @param Y numeric matrix `n x T` or numeric vector of length `n`.\n#' When a vector, is treated as a one-column matrix.\n#' @param predictor_weights optional numeric vector of length `J`\n#' giving `colSums(X^2)`. Computed internally when `NULL`.\n#' Callers that have this cached on the data object pass it\n#' through to avoid recomputation.\n#' @param sigma2 optional numeric scalar giving a known residual\n#' variance. When supplied, `Shat[j, t] = sqrt(sigma2 /\n#' predictor_weights[j])` (single-effect-residual form). When\n#' `NULL`, `Shat` is the per-pair empirical residual standard\n#' error: for each `(j, t)` pair, the sample SD of `Y[, t] -\n#' X[, j] * Bhat[j, t]` divided by `sqrt(n - 1)`. The latter\n#' matches the form used by data-driven prior init routines\n#' (e.g., for fitting a normal-mixture prior via `ashr::ash`).\n#'\n#' @return list with elements `Bhat` (`J x T`) and `Shat` (`J x T`).\n#'\n#' @examples\n#' set.seed(1)\n#' X <- matrix(rnorm(50 * 5), 50, 5)\n#' X <- scale(X, center = TRUE, scale = FALSE)\n#' Y <- matrix(rnorm(50 * 3), 50, 3)\n#' out <- compute_marginal_bhat_shat(X, Y)\n#' dim(out$Bhat) # 5 x 3\n#' dim(out$Shat) # 5 x 3\n#'\n#' @importFrom Rfast colVars\n#' @export\ncompute_marginal_bhat_shat <- function(X, Y,\n predictor_weights = NULL,\n sigma2 = NULL) {\n if (is.null(dim(Y))) {\n Y <- matrix(Y, ncol = 1)\n }\n n <- nrow(Y)\n J <- ncol(X)\n T_y <- ncol(Y)\n\n if (is.null(predictor_weights)) {\n predictor_weights <- colSums(X^2)\n }\n\n Bhat <- crossprod(X, Y) / predictor_weights # J x T\n\n if (!is.null(sigma2)) {\n Shat <- matrix(sqrt(sigma2 / predictor_weights), nrow = J, ncol = T_y)\n } else {\n Shat <- vapply(\n seq_len(T_y),\n function(t) Rfast::colVars(Y[, t] - sweep(X, 2, Bhat[, t], \"*\")),\n numeric(J)\n )\n if (!is.matrix(Shat)) Shat <- matrix(Shat, nrow = J, ncol = T_y)\n Shat <- sqrt(pmax(Shat, 1e-64)) / sqrt(n - 1)\n }\n\n list(Bhat = Bhat, Shat = Shat)\n}\n\n# ----------------------------------------------------------------------\n# Some miscellaneuous auxiliary functions are listed below.\n# Some functions are directly copied from varbvs,\n# https://github.com/pcarbo/varbvs\n# ----------------------------------------------------------------------\n\n# Remove covariate effects Regresses Z out from X and y; that is, X\n# and y are projected into the space orthogonal to Z.\n#' \n#' @importFrom Matrix forceSymmetric\n#'\nremove_covariate <- function (X, y, Z, standardize = FALSE, intercept = TRUE) {\n \n # check if Z is null and intercept = FALSE\n if (is.null(Z) & (intercept == FALSE)) {\n return(list(X = X, y = y, Z = Z,\n ZtZiZX = rep(0,dim(X)[2]), ZtZiZy = 0))\n }\n \n # redefine y\n y = c(as.double(y))\n n = length(y)\n \n # add intercept if intercept = TRUE\n if (intercept) {\n if (is.null(Z))\n Z <- matrix(1,n,1)\n else\n Z <- cbind(1,Z)\n }\n \n if (ncol(Z) == 1) {\n ZtZ = forceSymmetric(crossprod(Z)) # (Z^T Z) symmetric\n ZtZiZy = as.vector(solve(ZtZ,c(y %*% Z))) # (Z^T Z)^{-1} Z^T y\n ZtZiZX = as.matrix(solve(ZtZ,t(Z) %*% X)) # (Z^T Z)^{-1} Z^T X\n X = scale(X, center = intercept, scale = standardize)\n alpha = mean(y)\n y = y - alpha\n \n } else {\n ZtZ = forceSymmetric(crossprod(Z)) # (Z^T Z) symmetric\n ZtZiZy = as.vector(solve(ZtZ,c(y %*% Z))) # (Z^T Z)^{-1} Z^T y\n ZtZiZX = as.matrix(solve(ZtZ,t(Z) %*% X)) # (Z^T Z)^{-1} Z^T X\n \n # y = y - Z (Z^T Z)^{-1} Z^T y\n # X = X - Z (Z^T Z)^{-1} Z^T X \n y = y - c(Z %*% ZtZiZy)\n X = X - Z %*% ZtZiZX\n }\n \n return(list(X = X, y = y, Z = Z,\n ZtZiZX = ZtZiZX, ZtZiZy = ZtZiZy))\n}\n\n#' @title Ordering of Predictors from Univariate Regression\n#' \n#' @description This function extracts the ordering of the predictors\n#' according to the coefficients estimated in a basic univariate\n#' regression; in particular, the predictors are ordered in decreasing\n#' order by magnitude of the univariate regression coefficient\n#' estimate.\n#' \n#' @param X An input design matrix. This may be centered and/or\n#' standardized prior to calling function.\n#' \n#' @param y A vector of response variables.\n#'\n#' @return An ordering of the predictors.\n#' \n#' @examples\n#' ### generate synthetic data\n#' set.seed(1)\n#' n = 200\n#' p = 300\n#' X = matrix(rnorm(n*p),n,p)\n#' beta = double(p)\n#' beta[1:10] = 1:10\n#' y = X %*% beta + rnorm(n)\n#' \n#' univ.order = univar.order(X,y)\n#' \n#' @export\n#' \nunivar.order = function(X, y) {\n colnorm = c(colMeans(X^2))\n return (order(abs(c(t(X) %*% y) / colnorm), decreasing = TRUE))\n}\n\n#' @title Ordering of Predictors from Coefficient Estimates \n#' \n#' @param beta A vector of estimated regression coefficients.\n#' \n#' @description This function orders the predictors by decreasing\n#' order of the magnitude of the estimated regression coefficient.\n#'\n#' @return An ordering of the predictors.\n#' \n#' @examples\n#' ### generate synthetic data\n#' set.seed(1)\n#' n = 200\n#' p = 300\n#' X = matrix(rnorm(n*p),n,p)\n#' beta = double(p)\n#' beta[1:10] = 1:10\n#' y = X %*% beta + rnorm(n)\n#'\n#' ### order predictors by magnitude of univariate regression coefficient\n#' beta.hat = univariate_regression(X,y)$betahat\n#' order = absolute.order(beta.hat)\n#'\n#' @export\n#'\nabsolute.order = function (beta) {\n abs_order = c(order(abs(beta), decreasing = TRUE))\n return (abs_order)\n}\n\n#' @title Ordering of Predictors by Regularization Path\n#' \n#' @param fit A fit object whose \\code{coef()} method returns a matrix of\n#' coefficients with the intercept in the first row and one column per\n#' penalty strength (as produced by typical penalized-regression\n#' implementations).\n#' \n#' @description This function determines an ordering of the predictors\n#' based on the regularization path of the penalized regression; in\n#' particular, the predictors are ordered based on the order in which\n#' the coefficients are included in the model as the penalty strength\n#' decreases.\n#' \n#' @return An ordering of the predictors.\n#' \n#' @examples\n#' ### generate synthetic data\n#' set.seed(1)\n#' n = 200\n#' p = 30\n#' X = matrix(rnorm(n*p),n,p)\n#' beta = double(p)\n#' beta[1:10] = 1:10\n#' y = X %*% beta + rnorm(n)\n#'\n#' ### build a minimal example 'fit' object with the same structure as a\n#' ### fit from a penalized regression: a coefficient matrix with the\n#' ### intercept in row 1 and one column per (decreasing) penalty value.\n#' beta_path = matrix(0, p + 1, p)\n#' for (k in 1:p) beta_path[k + 1, k:p] = 1\n#' fit = list(coefficients = beta_path)\n#' order = path.order(fit)\n#'\n#' @export\n#'\npath.order = function (fit) {\n beta_path = coef(fit)[-1,]\n K = dim(beta_path)[2]\n path_order = c()\n for (k in 1:K) {\n crt_path = which(beta_path[,k] != 0)\n if (length(crt_path) != 0 & length(path_order) == 0) {\n path_order = c(path_order, crt_path)\n } else if(length(crt_path) != 0) {\n path_order = c(path_order, crt_path[-which(crt_path %in% path_order)] )\n }\n }\n path_order = unname(path_order)\n index_order = c(path_order, seq(1,dim(beta_path)[1])[-path_order])\n return (index_order)\n}\n" }, { "path": "README.md", "content": "# susieR\n\n[![CI](https://github.com/stephenslab/susieR/actions/workflows/ci.yml/badge.svg)](https://github.com/stephenslab/susieR/actions/workflows/ci.yml)\n[![CRAN status badge](https://www.r-pkg.org/badges/version/susieR)](https://cran.r-project.org/package=susieR)\n[![Codecov test coverage](https://codecov.io/gh/StatFunGen/susieR/graph/badge.svg)](https://app.codecov.io/gh/stephenslab/susieR)\n\nThe `susieR` package implements a simple new way to perform variable\nselection in multiple regression ($y=Xb+e$). The methods implemented\nhere are particularly well-suited to settings where some of the X\nvariables are highly correlated, and the true effects are highly\nsparse (e.g. <20 non-zero effects in the vector $b$). One example of\nthis is genetic fine-mapping applications, and this application was a\nmajor motivation for developing these methods. However, the methods\nshould also be useful more generally.\n\nThe methods are based on a new model for sparse multiple regression,\nwhich we call the \"Sum of Single Effects\" (SuSiE) model. This model,\nwhich is described in [Wang et al. (2020)](https://doi.org/10.1111/rssb.12388), lends itself to a particularly simple and intuitive fitting \nprocedure -- effectively a Bayesian modification of simple forward \nselection, which we call \"Iterative Bayesian Step-wise Selection\".\n\nThe output of the fitting procedure is a number of \"Credible Sets\"\n(CSs), which are each designed to have high probability to contain a\nvariable with non-zero effect, while at the same time being as small\nas possible. You can think of the CSs as being a set of \"highly\ncorrelated\" variables that are each associated with the response: you\ncan be confident that one of the variables has a non-zero coefficient,\nbut they are too correlated to be sure which one.\n\nThe package was initially developed by Gao Wang, Peter Carbonetto,\nYuxin Zou, Kaiqian Zhang, and Matthew Stephens from the\n[Stephens Lab](https://stephenslab.uchicago.edu) at the University of\nChicago. It was later extended with new methods and implementations by\nAlexander McCreight from the [StatFunGen Lab](https://wanggroup.org/) at\nColumbia University.\n\nPlease\n[post issues](https://github.com/stephenslab/susieR/issues) to ask\nquestions, get our support or provide us feedback; please\n[send pull requests](https://github.com/stephenslab/susieR/pulls) if\nyou have helped fixing bugs or making improvements to the source code.\n\n## Quick Start\n\nInstall susieR from [CRAN](https://cran.r-project.org/package=susieR):\n\n```R\ninstall.packages(\"susieR\")\n```\n\nAlternatively, install the latest development version of `susieR`\nfrom GitHub:\n\n```R\n# install.packages(\"remotes\")\nremotes::install_github(\"stephenslab/susieR\")\n```\n\nSee [here](https://stephenslab.github.io/susieR/articles/mwe.html) for\na brief illustration of `susieR`. For more documentation and examples\nplease visit https://stephenslab.github.io/susieR\n\n## Citing this work\n\nIf you find the `susieR` package or any of the source code in this\nrepository useful for your work, please cite both:\n\n> Wang, G., Sarkar, A., Carbonetto, P. & Stephens, M. (2020). A\n> simple new approach to variable selection in regression, with\n> application to genetic fine mapping. *Journal of the Royal\n> Statistical Society, Series B* **82**, 1273–1300.\n> https://doi.org/10.1111/rssb.12388\n\n> McCreight, A., Cho, Y., Li, R., Nachun, D., Gan, H-Y., Carbonetto, P., Stephens,\n> M., Denault, W.R.P. & Wang, G. (2025). SuSiE 2.0:\n> improved methods and implementations for genetic fine-mapping and\n> phenotype prediction. Submitting to *Genome Biology*.\n\nIf you use any of the summary data methods such as `susie_ss` or \n`susie_rss`, please also cite:\n\n> Zou, Y., Carbonetto, P., Wang, G. & Stephens, M. (2022). Fine-mapping\n> from summary data with the \"Sum of Single Effects\" model. *PLoS\n> Genetics* **18**, e1010299. https://doi.org/10.1371/journal.pgen.1010299\n\nIf you use the Servin-Stephens prior on residual variance estimates\n(`estimate_residual_method = \"NIG\"`), please also cite:\n\n> Denault, W.R.P., Carbonetto, P., Li, R., Alzheimer's Disease Functional\n> Genomics Consortium, Wang, G. & Stephens, M. (2025). Accounting for\n> uncertainty in residual variances improves calibration of the \"Sum of\n> Single Effects\" model for small sample sizes. *bioRxiv*, 2025-05.\n> Under review for *Nature Methods*.\n\nIf you use infinitesimal effects modeling (`unmappable_effects = \"inf\"`), \nplease also cite:\n\n> Cui, R., Elzur, R.A., Kanai, M. et al. (2024). Improving fine-mapping\n> by modeling infinitesimal effects. *Nature Genetics* **56**, 162–169.\n> https://doi.org/10.1038/s41588-023-01597-3\n\n## Developer notes\n\n\n+ The `Makefile` contains various R commands to build and maintain the package. \nFor example to build the website via `pkgdown`:\n\n ```bash\n make pkgdown\n ```\n\n+ When any changes are made to `roxygen2` markup, run\n`make document` to update package `NAMESPACE` and documentation\nfiles.\n\n\n+ To format R codes in the `R` folder,\n\n ```bash\n for i in `ls R/*.R`; do bash inst/misc/format_r_code.sh $i; done\n ```\n\n[susie-preprint]: https://doi.org/10.1101/501114\n" }, { "path": "_pkgdown.yml", "content": "url: https://stephenslab.github.io/susieR\n\ntemplate:\n bootstrap: 5\n light-switch: true\n math-rendering: katex\n bslib:\n base_font: { google: \"Roboto\" }\n heading_font: { google: \"Roboto Slab\" }\n code_font: { google: \"JetBrains Mono\" }\n\ndevelopment:\n mode: auto\n\nhome:\n links:\n - text: Learn more\n href: https://github.com/stephenslab/susieR\n - text: Report a bug\n href: https://github.com/stephenslab/susieR/issues\n\nnavbar:\n structure:\n left: [intro, reference, articles, news]\n right: [search, github, lightswitch]\n components:\n intro:\n icon: fa fa-play-circle\n text: Get Started\n href: articles/mwe.html\n aria-label: Get started with susieR\n reference:\n icon: fa fa-file-code\n text: Functions\n href: reference/index.html\n aria-label: Function reference\n articles:\n icon: fa fa-book-reader\n text: Vignettes\n href: articles/index.html\n aria-label: Articles and vignettes\n news:\n icon: fa fa-newspaper\n text: News\n href: articles/announcements.html\n aria-label: Package news\n github:\n icon: fab fa-github\n href: https://github.com/stephenslab/susieR\n aria-label: View source on GitHub\n\narticles:\n - title: \"Getting Started\"\n navbar: ~\n contents:\n - mwe\n - title: \"Fine-mapping Applications\"\n desc: >\n Detailed tutorials for genetic fine-mapping using susieR with \n individual-level and summary statistics data.\n contents:\n - finemapping\n - finemapping_summary_statistics\n - susie_rss\n - susierss_diagnostic\n - small_sample\n - title: \"Advanced Topics\"\n desc: >\n Advanced features and specialized applications of the susieR package.\n contents:\n - sparse_susie_eval\n - susie_refine\n - l0_initialization\n - trend_filtering\n - susie_unmappable_effects\n - title: \"Package Information\"\n navbar: ~\n contents:\n - announcements\n\nfooter:\n structure:\n left: developed_by\n right: built_with\n" }, { "path": "inst/CITATION", "content": "citHeader(\"To cite the susieR package, please use both:\")\n\nbibentry(bibtype = \"Article\",\n title = paste(\"A simple new approach to variable selection in\",\n \"regression, with application to genetic fine\",\n \"mapping\"),\n author = c(person(\"Gao\",\"Wang\"),\n person(\"Abhishek\",\"Sarkar\"),\n person(\"Peter\",\"Carbonetto\"),\n person(\"Matthew\",\"Stephens\")),\n journal = \"Journal of the Royal Statistical Society, Series B\",\n year = \"2020\",\n volume = \"82\",\n pages = \"1273-1300\",\n doi = \"10.1111/rssb.12388\",\n textVersion =\n paste(\"Wang, G., Sarkar, A., Carbonetto, P. & Stephens, M. (2020).\",\n \"A simple new approach to variable selection in regression,\",\n \"with application to genetic fine mapping. Journal of the\",\n \"Royal Statistical Society, Series B 82, 1273-1300.\",\n \"https://doi.org/10.1111/rssb.12388\"))\n\nbibentry(bibtype = \"Article\",\n title = paste(\"SuSiE 2.0: improved methods and implementations for\",\n \"genetic fine-mapping and phenotype prediction\"),\n author = c(person(\"Alexander\", \"McCreight\"),\n person(\"Yanghyeon\", \"Cho\"),\n person(\"Daniel\", \"Nachun\"),\n person(\"Ruixi\", \"Li\"),\n person(\"Hao-Yu\", \"Gan\"),\n person(\"Matthew\", \"Stephens\"),\n person(\"Peter\", \"Carbonetto\"),\n person(\"William\", \"R.P. Denault\"),\n person(\"Gao\", \"Wang\")),\n journal = \"Submitting to Genome Biology\",\n year = \"2025\",\n textVersion =\n paste(\"McCreight, A., Cho, Y., Nachun, D., Li, R., Gan, H-Y., Stephens,\",\n \"M., Carbonetto, P., Denault, W.R.P. & Wang, G. (2025). SuSiE 2.0:\",\n \"improved methods and implementations for genetic fine-mapping and\",\n \"phenotype prediction. Submitting to Genome Biology.\"))\n\nbibentry(header = \"If susie_suff_stat or susie_rss is used, please also cite:\",\n bibtype = \"Article\",\n title = paste('Fine-mapping from summary data with the',\n '\"Sum of Single Effects\" model'),\n author = c(person(\"Yuxin\",\"Zou\"),\n person(\"Peter\",\"Carbonetto\"),\n person(\"Gao\",\"Wang\"),\n person(\"Matthew\",\"Stephens\")),\n journal = \"PLoS Genetics\",\n volume = \"18\",\n year = \"2022\",\n pages = \"e1010299\",\n doi = \"10.1371/journal.pgen.1010299\",\n textVersion =\n paste('Zou, Y., Carbonetto, P., Wang, G. & Stephens, M. (2022).',\n 'Fine-mapping from summary data with the \"Sum of Single',\n 'Effects\" model. PLoS Genetics 18, e1010299.',\n 'https://doi.org/10.1371/journal.pgen.1010299'))\n\nbibentry(header = paste(\"If estimate_residual_method = 'NIG' is used,\",\n \"please also cite:\"),\n bibtype = \"Article\",\n title = paste(\"Accounting for uncertainty in residual variances\",\n \"improves calibration of the 'Sum of Single Effects'\",\n \"model for small sample sizes\"),\n author = c(person(\"William\", \"R.P. Denault\"),\n person(\"Peter\", \"Carbonetto\"),\n person(\"Ruixi\", \"Li\"),\n person(\"Alzheimer's Disease Functional Genomics Consortium\"),\n person(\"Gao\", \"Wang\"),\n person(\"Matthew\", \"Stephens\")),\n journal = \"bioRxiv\",\n year = \"2025\",\n note = \"Under review for Nature Methods\",\n textVersion =\n paste(\"Denault, W.R.P., Carbonetto, P., Li, R., Alzheimer's Disease\",\n \"Functional Genomics Consortium, Wang, G. & Stephens, M. (2025).\",\n \"Accounting for uncertainty in residual variances improves\",\n \"calibration of the 'Sum of Single Effects' model for small\",\n \"sample sizes. bioRxiv, 2025-05. Under review for Nature Methods.\"))\n\nbibentry(header = paste(\"If unmappable_effects = 'inf' is used,\",\n \"please also cite:\"),\n bibtype = \"Article\",\n title = \"Improving fine-mapping by modeling infinitesimal effects\",\n author = c(person(\"Rui\", \"Cui\"),\n person(\"R.A.\", \"Elzur\"),\n person(\"M.\", \"Kanai\"),\n person(c(\"et\", \"al.\"))),\n journal = \"Nature Genetics\",\n volume = \"56\",\n year = \"2024\",\n pages = \"162-169\",\n doi = \"10.1038/s41588-023-01597-3\",\n textVersion =\n paste(\"Cui, R., Elzur, R.A., Kanai, M. et al. (2024).\",\n \"Improving fine-mapping by modeling infinitesimal effects.\",\n \"Nature Genetics 56, 162-169.\",\n \"https://doi.org/10.1038/s41588-023-01597-3\"))\n" }, { "path": "inst/analysis/optimize.Rmd", "content": "---\ntitle: \"optimize\"\nauthor: \"Matthew Stephens\"\ndate: \"4/15/2018\"\noutput: html_document\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(echo = TRUE)\n```\n\nDiagnose optimization issues with Lei's example\n```{r}\nset.seed(777)\ndevtools::load_all(\".\")\nX <- matrix(rnorm(1010 * 1000), 1010, 1000)\nbeta <- rep(0, 1000)\nbeta[1 : 200] <- 100\ny <- X %*% beta + rnorm(1010)\ns = susie(X,y,L=1,estimate_residual_variance = TRUE)\nY = y-s$Xr\ns2 = s$sigma2\nx = seq(1,100000,length=100)\nl = rep(0,100)\nlg = rep(0,100)\nfor(i in 1:100){\n l[i] = loglik(x[i],Y,X,s2)\n lg[i] = loglik.grad(x[i],Y,X,s2)\n}\nplot(x,l)\nplot(x,lg)\n# > which.max(l)\n# [1] 23\n# > lg[23]\n# [1] -2.398905e-07\n# > lg[22]\n# [1] 6.282734e-07\n\nlx = log(x)\nl2=l\nlg2=lg\nfor(i in 1:100){\n l2[i] = negloglik.logscale(lx[i],Y,X,s2)\n lg2[i] = negloglik.grad.logscale(lx[i],Y,X,s2)\n}\nplot(lx,l2)\nplot(lx,lg2)\n\ny = seq(0,20,length=100)\nl3=l2\nlg3=lg2\nfor(i in 1:100){\n l3[i] = negloglik.logscale(y[i],Y,X,s2)\n lg3[i] = negloglik.grad.logscale(y[i],Y,X,s2)\n}\nplot(y,l3)\nplot(y,lg3)\nuniroot(negloglik.grad.logscale,c(-20,20),extendInt = \"upX\",Y=Y,X=X,s2=s2)\n\n```\n\nSo, to summarize, problem seems to be that optim has issues with\nvery flat initial gradient near 0.\n" }, { "path": "inst/analysis/test_susie_auto.Rmd", "content": "---\ntitle: \"Test susie auto\"\nauthor: \"Matthew Stephens\"\ndate: \"5/2/2018\"\noutput: html_document\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(echo = TRUE)\n```\n\nThe goal here is to test the function `susie_auto` which tries\nto make susie run well even in some tricky situations (eg where $L$ is big,\nwhich susie is not well suited to).\n\nThis is an example Lei Sun showed us from the paper demonstrating that\nfalse positives occur early on the Lasso path. Here I change L to 20 instead\nof 200 to make it run fast to begin with.\n```{r}\nset.seed(777)\nlibrary(susieR)\nL <- 20\nX <- matrix(rnorm(1010 * 1000), 1010, 1000)\nbeta <- rep(0, 1000)\nbeta[1 : L] <- 100\ny <- X %*% beta + rnorm(1010)\n```\n\n```{r}\ns <- susie_auto(X,y,verbose=TRUE)\ns$sa2\n```\n\n\nNow try L=200\n```{r}\nset.seed(777)\nL <- 200\nX <- matrix(rnorm(1010 * 1000), 1010, 1000)\nbeta <- rep(0, 1000)\nbeta[1 : L] <- 100\ny <- X %*% beta + rnorm(1010)\ns2 <- susie_auto(X,y,verbose=TRUE)\ns2$sa2\n```\n\n" }, { "path": "inst/analysis/testing.Rmd", "content": "---\ntitle: \"test.Rmd\"\nauthor: \"Matthew Stephens\"\ndate: \"4/14/2018\"\noutput: html_document\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(echo = TRUE)\n```\n\n# simulate data\n\nThis is Lei's example\n```{r}\nset.seed(777)\nlibrary(susieR)\nX <- matrix(rnorm(1010 * 1000), 1010, 1000)\nbeta <- rep(0, 1000)\nbeta[1 : 200] <- 100\ny <- X %*% beta + rnorm(1010)\ns = susie(X,y,L=200)\n\nplot(coef(s),beta)\ns$sigma2\n\n# fit <- lm(y ~ X - 1)\n# mlr.p <- log(summary(fit)$coefficients[, 4])\n# \nmar.p <- c()\nmar.betahat = c()\nfor (i in 1 : 1000) {\n fit <- lm(y ~ X[, i] - 1)\n mar.p[i] <- log(summary(fit)$coefficients[, 4])\n mar.betahat[i] <- summary(fit)$coefficients[, 1]\n}\n# \n# pdf(\"pvalue.pdf\", width = 10, height = 5)\n# par(mfrow = c(1, 2))\n# plot(mlr.p, ylab = \"log(p-value)\", main = \"Multiple Linear Regression\")\n# abline(h = log(0.05 / 1000), lty = 2, col = \"red\")\n# legend(\"right\", lty = 2, col = \"red\", \"log(0.05/p)\")\n# \n# plot(mar.p, ylab = \"log(p-value)\", main = \"One-on-One Linear Regression\")\n# abline(h = log(0.05 / 1000), lty = 2, col = \"red\")\n```\n\nNotice that the coefficients are monotonic with betahat. Some shrinkage of zero values is evident, but it is not enough... presumably because sigma2 is way over-estimated. And further we see excessive shrinkage of true signals, presumably because sa2 is too small.\n```{r}\nplot(coef(s),mar.betahat)\n```\n\n\nHere we try fixing $L$ and residual variance to true value.\n```{r}\nstrue = susie(X,y,L=200,residual_variance =1,estimate_residual_variance =FALSE)\nplot(coef(strue),beta)\nstrue$elbo\n```\nit works!!\n\n```{r}\nplot(strue$alpha[1,])\nplot(strue$alpha[2,])\n```\n\nTry with very small residual variance\n```{r}\ns3 = susie(X,y,L=200, residual_variance = 0.01,estimate_residual_variance = FALSE)\nplot(coef(s3))\ns4 = susie(X,y,s_init = s3)\nplot(coef(s4))\ns4$elbo\n```\nThat is weird it goes away from the solution!\n\nTry with estimating prior:\n```{r}\ns5 = susie(X,y,s_init = s3, estimate_prior_variance = TRUE)\nplot(coef(s5))\ns5$elbo\nsqrt(s5$sa2)\nsqrt(s4$sa2)\n```\nmuch better!\n\n\nNow try too many effects\n```{r}\ns3.300 = susie(X,y,L=300, residual_variance = 0.01,estimate_residual_variance = FALSE)\ns5.300 = susie(X,y,s_init = s3.300, estimate_prior_variance = TRUE)\nplot(coef(s3.300))\nplot(coef(s5.300))\ns3.300$elbo\ns5.300$elbo\nsum(s5.300$sa2>0)\n```\n\nNow try too many effects but just a very small number of iterations for initial case:\n```{r}\ns3.300.5 = susie(X,y,L=300, residual_variance = 0.01,estimate_residual_variance = FALSE, max_iter = 5)\ns5.300.5 = susie(X,y,s_init = s3.300.5, estimate_prior_variance = TRUE)\nplot(coef(s3.300.5))\nplot(coef(s5.300.5))\ns3.300.5$elbo\ns5.300.5$elbo\nplot(colSums(s5.300.5$alpha))\n```\n\nQ: does the initial run with small variance gradually find the smaller effects, or does it get them from the first iteration?\nCould look at that by doing one iteration at a time.\n```{r}\ns3.300.1 = susie(X,y,L=300, residual_variance = 0.01,estimate_residual_variance = FALSE, max_iter = 1)\nplot(coef(s3.300.1))\ns3.300.2 = susie(X,y,s_init=s3.300.1,estimate_residual_variance = FALSE, max_iter = 1)\nplot(coef(s3.300.2))\ns3.300 = susie(X,y,s_init=s3.300.2,estimate_residual_variance = TRUE)\n\n```\n\n" }, { "path": "inst/code/caviar.R", "content": "#!/usr/bin/env Rscript\nlibrary(dplyr)\nlibrary(readr)\nlibrary(magrittr)\n\n#' CAVIAR I/O\nwrite_caviar_sumstats <- function(z, prefix) {\n cfg = list(z=paste0(prefix,\".z\"),\n set=paste0(prefix,\"_set\"),\n post=paste0(prefix,\"_post\"),\n log=paste0(prefix,\".log\"))\n write.table(z,cfg$z,quote=F,col.names=F)\n return(cfg)\n}\n\n#' Run CAVIAR\n#' https://github.com/fhormoz/caviar\n\nrun_caviar <- function(z, LD_file, args = \"\", prefix=\"data\")\n{\n cfg = write_caviar_sumstats(z, prefix)\n cmd = paste(\"CAVIAR\", \"-z\", cfg$z, \"-l\", LD_file, \"-o\", prefix, args)\n dscrutils::run_cmd(cmd)\n if(!all(file.exists(cfg$post, cfg$set, cfg$log))) {\n stop(\"Cannot find one of the post, set, and log files\")\n }\n \n log <- readLines(cfg$log)\n\n # read output tables\n snp <- read.delim(cfg$post) \n stopifnot(ncol(snp) == 3)\n names(snp) <- c(\"snp\", \"snp_prob_set\", \"snp_prob\")\n snp$snp <- as.character(snp$snp)\n snp <- rank_snp(snp)\n\n # `set` of snps\n set <- readLines(cfg$set)\n set_ordered <- left_join(data_frame(snp = set), snp, by = \"snp\") %>% \n arrange(rank) %$% snp\n return(list(snp=snp, set=set_ordered))\n}\n\nrank_snp <- function(snp) {\n snp <- arrange(snp, -snp_prob) %>%\n mutate(\n rank = seq(1, n()),\n snp_prob_cumsum = cumsum(snp_prob) / sum(snp_prob)) %>%\n select(rank, snp, snp_prob, snp_prob_cumsum, snp_prob_set)\n return(snp) \n}\n\nfinemap_mcaviar <- function(zscore, LD_file, args, prefix) {\n if (is.null(dim(zscore))) {\n zscore = matrix(ncol=1,zscore)\n }\n return(parallel::mclapply(1:ncol(zscore), function(r)\n run_caviar(zscore[,r], LD_file, args, \n paste0(prefix, '_condition_', r)), \n mc.cores = min(8, ncol(zscore))))\n}\n\neval(parse(text=commandArgs(T)))\ndat = readRDS(input)\nsumstats = dat$sumstats\nld = tempfile(fileext = \".ld\")\nwrite.table(cor(dat$data$X),ld,quote=F,col.names=F,row.names=F)\nposterior = finemap_mcaviar(sumstats[1,,] / sumstats[2,,],\n ld,\n args, prefix=tempfile(fileext = \".caviar\"))\nsaveRDS(posterior, paste0(output, '.rds'))\n" }, { "path": "inst/code/compute_ss_memory.R", "content": "# export MEM_CHECK_INTERVAL=0.01\n# python3 monitor_memory.py Rscript compute_ss_memory.R\n#\n# NOTES:\n#\n# - Without any improvements:\n# Size of X: 0.3 GB\n# max rss_memory: 1.65 GB\n#\n# - The original centering and scaling steps require about 1 GB.\n#\n# - With the improvements:\n# Size of X: 0.3 GB\n# max rss_memory: 0.66 GB\n#\n# set.seed(1)\n# p <- 2000\n# n <- 20000\n# X <- matrix(rnorm(n*p),n,p)\n# y <- rnorm(n)\n# save(list = c(\"X\",\"y\"),file = \"compute_ss_data.RData\")\n# library(susieR)\ndevtools::load_all()\nset.seed(1)\nload(\"compute_ss_data.RData\")\ncat(\"Size of X:\\n\")\nprint(object.size(X),unit = \"GB\")\ncat(\"Running compute_ss.\\n\")\nout <- compute_ss(X,y,standardize = TRUE)\n" }, { "path": "inst/code/dap-g.py", "content": "#!/usr/bin/env python3\nimport sys\nimport subprocess\nimport pandas as pd\nimport numpy as np\n\ndef write_dap_full(x,y,prefix,r):\n names = np.array([('geno', i+1, f'group{r}') for i in range(x.shape[1])])\n with open(f'{prefix}.data', 'w') as f:\n print(*(['pheno', 'pheno', f'group{r}'] + list(np.array(y).ravel())), file=f)\n np.savetxt(f, np.hstack((names, x.T)), fmt = '%s', delimiter = ' ')\n \ndef run_dap_full(prefix, args):\n cmd = ['dap-g', '-d', f'{prefix}.data', '-o', f'{prefix}.result', '--output_all'] + ' '.join(args).split()\n subprocess.Popen(cmd, stdout=subprocess.PIPE, stderr=subprocess.PIPE).communicate() \n \ndef write_dap_ss(z,prefix):\n '''z-score vesion of dap input is the same as FINEMAP'''\n ids = np.array([str(i+1) for i in range(z.shape[0])])\n with open(f'{prefix}.z', 'w') as f:\n np.savetxt(f, np.vstack((ids, z)).T, fmt = '%s', delimiter = ' ')\n\ndef run_dap_z(ld, prefix, args):\n cmd = ['dap-g', '-d_z', f'{prefix}.z', '-d_ld', ld, '-o', f'{prefix}.result', '--all'] + ' '.join(args).split()\n subprocess.Popen(cmd, stdout=subprocess.PIPE, stderr=subprocess.PIPE).communicate() \n \ndef extract_dap_output(prefix):\n out = [x.strip().split() for x in open(f'{prefix}.result').readlines()]\n pips = []\n clusters = []\n still_pip = True\n for line in out:\n if len(line) == 0:\n continue\n if len(line) > 2 and line[2] == 'cluster_pip':\n still_pip = False\n continue\n if still_pip and (not line[0].startswith('((')):\n continue\n if still_pip:\n pips.append([line[1], float(line[2]), float(line[3]), int(line[4])])\n else:\n clusters.append([len(clusters) + 1, float(line[2]), float(line[3])])\n pips = pd.DataFrame(pips, columns = ['snp', 'snp_prob', 'snp_log10bf', 'cluster'])\n clusters = pd.DataFrame(clusters, columns = ['cluster', 'cluster_prob', 'cluster_avg_r2'])\n clusters = pd.merge(clusters, pips.groupby(['cluster'])['snp'].apply(','.join).reset_index(), on = 'cluster')\n return {'snp': pips, 'set': clusters}\n\ndef dap_single(x, y, prefix, r, args):\n write_dap_full(x,y,prefix,r)\n run_dap_full(prefix,args)\n return extract_dap_output(prefix)\n\ndef dap_single_z(z, ld, prefix, args):\n write_dap_ss(z,prefix)\n run_dap_z(ld,prefix,args)\n return extract_dap_output(prefix)\n\ndef dap_batch(X, Y, prefix, *args):\n return dict([(f'V{r+1}', dap_single(X, Y[:,r], f'{prefix}_condition_{r+1}', r+1, args)) for r in range(Y.shape[1])])\n\ndef dap_batch_z(z, ld, prefix, *args):\n return dict([(f'V{r+1}', dap_single_z(z[:,r], ld, f'{prefix}_condition_{r+1}', args)) for r in range(z.shape[1])])\n\nimport os\nfrom dsc.dsc_io import load_rds, save_rds\nimport tempfile\nimport warnings\nif not sys.warnoptions:\n warnings.simplefilter(\"ignore\")\n\ninput_file = os.path.expanduser(sys.argv[1])\noutput_file = os.path.expanduser(sys.argv[2])\nargs = sys.argv[3:]\ndata = load_rds(input_file)['data']\ncache = tempfile.NamedTemporaryFile(suffix = '.dap')\nposterior = dap_batch(data['X'], data['Y'], cache.name, ' '.join(args))\nsave_rds(posterior, output_file + '.rds')\n" }, { "path": "inst/code/finemap.R", "content": "#!/usr/bin/env Rscript\nlibrary(dplyr)\nlibrary(readr)\nlibrary(magrittr)\n\n#' FINEMAP I/O\nwrite_finemap_sumstats <- function(z, LD_file, n, k, prefix) {\n cfg = list(z=paste0(prefix,\".z\"),\n ld=LD_file,\n snp=paste0(prefix,\".snp\"),\n config=paste0(prefix,\".config\"),\n k=paste0(prefix,\".k\"),\n log=paste0(prefix,\".log\"),\n meta=paste0(prefix,\".master\"))\n write.table(z,cfg$z,quote=F,col.names=F)\n if (!is.null(k)) {\n write.table(t(k),cfg$k,quote=F,col.names=F,row.names=F)\n write(\"z;ld;snp;config;k;log;n-ind\",file=cfg$meta)\n write(paste(cfg$z, cfg$ld, cfg$snp, cfg$config, cfg$k, cfg$log, n, sep=\";\"),\n file=cfg$meta,append=TRUE)\n } else {\n write(\"z;ld;snp;config;log;n-ind\",file=cfg$meta)\n write(paste(cfg$z, cfg$ld, cfg$snp, cfg$config, cfg$log, n, sep=\";\"),\n file=cfg$meta,append=TRUE)\n }\n return(cfg)\n}\n\n#' Run FINEMAP version 1.1\n#' http://www.christianbenner.com\n## FIXME: read the finemapr implementation for data sanity check.\n## Can be useful as a general data sanity checker (in previous modules)\n\nrun_finemap <- function(z, LD_file, n, k, args = \"\", prefix=\"data\")\n{\n cfg = write_finemap_sumstats(z, LD_file, n, k, prefix)\n cmd = paste(\"finemap --sss --log\", \"--in-files\", cfg$meta, args)\n dscrutils::run_cmd(cmd)\n\n # read output tables\n snp = read.table(cfg$snp,header=TRUE,sep=\" \")\n snp$snp = as.character(snp$snp)\n\n snp = rank_snp(snp)\n config = read.table(cfg$config,header=TRUE,sep=\" \")\n\n # Only keep configurations with cumulative 95% probability\n # config = within(config, config_prob_cumsum <- cumsum(config_prob))\n # config = config[config$config_prob_cumsum <= 0.95,]\n\n # extract number of causal\n ncausal = finemap_extract_ncausal(cfg$log)\n return(list(snp=snp, set=config, ncausal=ncausal))\n}\n\nrank_snp <- function(snp) {\n snp <- arrange(snp, -snp_prob) %>%\n mutate(\n rank = seq(1, n()),\n snp_prob_cumsum = cumsum(snp_prob) / sum(snp_prob)) %>%\n select(rank, snp, snp_prob, snp_prob_cumsum, snp_log10bf)\n return(snp)\n}\n\nfinemap_extract_ncausal <- function(logfile)\n{\n lines <- grep(\"->\", readLines(logfile), value = TRUE)\n lines <- gsub(\"\\\\(|\\\\)|>\", \"\", lines)\n splits <- strsplit(lines, \"\\\\s+\")\n tab <- data.frame(\n ncausal_num = sapply(splits, function(x) as.integer(x[2])),\n ncausal_prob = sapply(splits, function(x) as.double(x[4])))\n tab <- mutate(tab, type = ifelse(duplicated(ncausal_num), \"post\", \"prior\"))\n return(tab)\n}\n\nfinemap_mvar <- function(zscore, LD_file, n, k, args, prefix, parallel = FALSE) {\n if (is.null(dim(zscore))) {\n zscore = matrix(ncol=1,zscore)\n }\n\n single_core = function(r) \n run_finemap(zscore[,r], LD_file, n, k, args, \n paste0(prefix, '_condition_', r))\n if (parallel)\n return(parallel::mclapply(1:ncol(zscore), function(r) single_core(r),\n mc.cores = min(8, ncol(zscore))))\n else\n return(lapply(1:ncol(zscore), function(r) single_core(r)))\n}\n\neval(parse(text=commandArgs(T)))\ndat = readRDS(input)\nsumstats = dat$sumstats\nN = nrow(dat$data$X)\nld = tempfile(fileext = \".ld\")\nwrite.table(cor(dat$data$X),ld,quote=F,col.names=F,row.names=F)\nposterior = finemap_mvar(sumstats[1,,] / sumstats[2,,],\n ld, N, k=NULL,\n args, prefix=tempfile(fileext = \".finemap\"))\nsaveRDS(posterior, paste0(output, '.rds'))\n" }, { "path": "inst/code/finemap_1p4.R", "content": "#!/usr/bin/env Rscript\nlibrary(dplyr)\nlibrary(readr)\nlibrary(magrittr)\n\n#' FINEMAP I/O\nwrite_finemap_sumstats <- function(beta, se, LD_file, n, k, prefix) {\n cfg = list(z=paste0(prefix,\".z\"),\n ld=LD_file,\n snp=paste0(prefix,\".snp\"),\n config=paste0(prefix,\".config\"),\n cred=paste0(prefix, \".cred\"),\n k=paste0(prefix,\".k\"),\n log=paste0(prefix,\".log\"),\n meta=paste0(prefix,\".master\"))\n se = replace(se, se == 0, 'nan')\n z = data.frame(chromosome=\"chr\", position=seq(1, length(beta)), allele1='nan', allele2='nan', maf='nan', beta, se)\n z = cbind(rsid=z$position, z)\n write.table(z,cfg$z,quote=F,col.names=T,row.names=F)\n if (!is.null(k)) {\n write.table(t(k),cfg$k,quote=F,col.names=F,row.names=F)\n write(\"z;ld;snp;config;cred;n_samples;k;log\",file=cfg$meta)\n write(paste(cfg$z, cfg$ld, cfg$snp, cfg$config, cfg$cred, n, cfg$k, cfg$log, sep=\";\"),\n file=cfg$meta,append=TRUE)\n } else {\n write(\"z;ld;snp;config;cred;n_samples;log\",file=cfg$meta)\n write(paste(cfg$z, cfg$ld, cfg$snp, cfg$config, cfg$cred, n, cfg$log, sep=\";\"),\n file=cfg$meta,append=TRUE)\n }\n return(cfg)\n}\n\n#' Run FINEMAP version 1.4\n#' http://www.christianbenner.com\n## FIXME: read the finemapr implementation for data sanity check.\n## Can be useful as a general data sanity checker (in previous modules)\n\nrun_finemap <- function(beta, se, LD_file, n, k, args = \"\", prefix=\"data\")\n{\n cfg = write_finemap_sumstats(beta, se, LD_file, n, k, prefix)\n cmd = paste(\"finemap --sss --log\", \"--in-files\", cfg$meta, args)\n dscrutils::run_cmd(cmd)\n cfg$log = paste0(cfg$log, \"_sss\")\n\n # read output tables\n snp = read.table(cfg$snp,header=TRUE,sep=\" \")\n snp$snp = as.character(snp$rsid)\n\n snp = rank_snp(snp)\n # we add snp-prob for backwards-compatability with code that used this script with FINEMAP v1.1\n snp$prob = snp$snp_prob\n config = read.table(cfg$config,header=TRUE,sep=\" \")\n\n # Only keep configurations with cumulative 95% probability\n # config = within(config, config_prob_cumsum <- cumsum(config_prob))\n # config = config[config$config_prob_cumsum <= 0.95,]\n\n # extract number of causal\n ncausal = finemap_extract_ncausal(cfg$log)\n return(list(snp=snp, set=config, ncausal=ncausal))\n}\n\nrank_snp <- function(snp) {\n snp <- arrange(snp, -prob) %>%\n mutate(\n rank = seq(1, n()),\n prob_cumsum = cumsum(prob) / sum(prob)) %>%\n select(rank, snp, prob, prob_cumsum, log10bf)\n return(snp)\n}\n\nfinemap_extract_ncausal <- function(logfile)\n{\n lines <- grep(\"->\", readLines(logfile), value = TRUE)\n lines <- gsub(\"\\\\(|\\\\)|>\", \"\", lines)\n splits <- strsplit(lines, \"\\\\s+\")\n tab <- data.frame(\n ncausal_num = sapply(splits, function(x) as.integer(x[2])),\n ncausal_prob = sapply(splits, function(x) as.double(x[4])))\n tab <- mutate(tab, type = ifelse(duplicated(ncausal_num), \"post\", \"prior\"))\n return(tab)\n}\n\nfinemap_mvar <- function(beta, se, LD_file, n, k, args, prefix, parallel = FALSE) {\n if (is.null(dim(beta))) {\n beta = matrix(ncol=1,beta)\n }\n if (is.null(dim(se))) {\n se = matrix(ncol=1,se)\n }\n\n single_core = function(r) \n run_finemap(beta[,r], se[,r], LD_file, n, k, args, \n prefix=paste0(prefix, '_condition_', r))\n if (parallel)\n return(parallel::mclapply(1:ncol(beta), function(r) single_core(r),\n mc.cores = min(8, ncol(beta))))\n else\n return(lapply(1:ncol(beta), function(r) single_core(r)))\n}\n\neval(parse(text=commandArgs(T)))\ndat = readRDS(input)\nsumstats = dat$sumstats\nN = nrow(dat$data$X)\nld = tempfile(fileext = \".ld\")\nld_mat = cor(dat$data$X)\nld_mat[is.na(ld_mat)] = 'nan'\nwrite.table(ld_mat,ld,quote=F,col.names=F,row.names=F)\nposterior = finemap_mvar(sumstats[1,,], sumstats[2,,],\n ld, N, k=NULL,\n args, prefix=tempfile(fileext = \".finemap\"))\nsaveRDS(posterior, paste0(output, '.rds'))\n" }, { "path": "inst/code/gen_original_results.R", "content": "## results from original susie\ndevtools::install_github(\"stephenslab/susieR\")\nlibrary(susieR)\n\ncreate_sparsity_mat = function(sparsity, n, p){\n nonzero = round(n*p*(1-sparsity))\n nonzero.idx = sample(n*p, nonzero)\n mat = numeric(n*p)\n mat[nonzero.idx] = 1\n mat = matrix(mat, nrow=n, ncol=p)\n return(mat)\n}\n\nset.seed(1)\nn = 100\np = 200\nbeta = rep(0,p)\nbeta[1] = 10\nbeta[2] = 10\nbeta[3] = 10\nbeta[4] = 10\nX.dense = create_sparsity_mat(0.99,n,p)\ny = c(X.dense %*% beta + rnorm(n))\nL = 10\nresidual_variance = 0.8\nscaled_prior_variance = 0.2\ns = list(alpha=matrix(1/p,nrow=L,ncol=p),\n mu=matrix(2,nrow=L,ncol=p),\n mu2=matrix(3,nrow=L,ncol=p),\n Xr=rep(5,n), KL=rep(1.2,L),\n sigma2=residual_variance, V=scaled_prior_variance * as.numeric(var(y)))\nX = susieR:::set_X_attributes(X.dense)\nEb = rep(1, p)\nEb2 = rep(1, p)\ns2 = residual_variance\nV = scaled_prior_variance\n\n\nobjective.original.res = susieR::susie_get_objective(s)\nsaveRDS(objective.original.res, 'objective_original_res.rds')\n\nEloglik.original.res = susieR:::Eloglik(X,y,s)\nsaveRDS(Eloglik.original.res, 'Eloglik_original_res.rds')\n\nER2.original.res = susieR:::get_ER2(X,y,s)\nsaveRDS(ER2.original.res, 'ER2_original_res.rds')\n\nSER.original.res = susieR:::SER_posterior_e_loglik(X,y,s2,Eb,Eb2)\nsaveRDS(SER.original.res, 'SER_original_res.rds')\n\nsingleReg.original.res = susieR:::single_effect_regression(y,X,V)\nsaveRDS(singleReg.original.res, 'singleReg_original_res.rds')\n\nvbupdate.original.res = susieR:::update_each_effect(X, y, s)\nsaveRDS(vbupdate.original.res, 'vbupdate_original_res.rds')\n\nsusiefit.original.res = susie(X.dense,y)\nsaveRDS(susiefit.original.res, 'susiefit_original_res.rds')\n\nsusiefit.original.res2 = susie(X.dense, y, standardize = TRUE, intercept = FALSE)\nsusiefit.original.res3 = susie(X.dense, y, standardize = FALSE, intercept = TRUE)\nsusiefit.original.res4 = susie(X.dense, y, standardize = FALSE, intercept = FALSE)\nsaveRDS(susiefit.original.res2, 'susiefit_original_res2.rds')\nsaveRDS(susiefit.original.res3, 'susiefit_original_res3.rds')\nsaveRDS(susiefit.original.res4, 'susiefit_original_res4.rds')\n" }, { "path": "inst/code/monitor_memory.py", "content": "#!/usr/bin/env python3\n#\n# Copyright (c) 2012 Realz Slaw, 2017 Gao Wang\n#\n# Permission is hereby granted, free of charge, to any person\n# obtaining a copy of this software and associated documentation files\n# (the \"Software\"), to deal in the Software without restriction,\n# including without limitation the rights to use, copy, modify, merge,\n# publish, distribute, sublicense, and/or sell copies of the Software,\n# and to permit persons to whom the Software is furnished to do so,\n# subject to the following conditions:\n#\n# The above copyright notice and this permission notice shall be\n# included in all copies or substantial portions of the Software.\n#\n# THE SOFTWARE IS PROVIDED \"AS IS\", WITHOUT WARRANTY OF ANY KIND,\n# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF\n# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND\n# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS\n# BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN\n# ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN\n# CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE\n# SOFTWARE.\n\nimport time\nimport psutil\nimport subprocess\n\nclass ProcessTimer:\n def __init__(self, command, interval = 1):\n self.command = command\n self.execution_state = False\n self.interval = interval\n\n def execute(self):\n self.max_vms_memory = 0\n self.max_rss_memory = 0\n\n self.t0 = time.time()\n self.t1 = None\n self.max_t = [self.t0]\n try:\n self.p = subprocess.Popen(self.command, shell=False)\n except FileNotFoundError:\n self.p = None\n sys.exit(\"Invalid command `{}`\".format(sys.argv[1]))\n self.execution_state = True\n\n def poll(self):\n if not self.check_execution_state():\n return False\n\n self.t1 = time.time()\n\n try:\n pp = psutil.Process(self.p.pid)\n\n # Obtain a list of the subprocess and all its descendants.\n descendants = list(pp.children(recursive=True))\n descendants = descendants + [pp]\n\n rss_memory = 0\n vms_memory = 0\n\n # Calculate and sum up the memory of the subprocess and all its\n # descendants.\n for descendant in descendants:\n try:\n mem_info = descendant.memory_info()\n\n rss_memory += mem_info[0]\n vms_memory += mem_info[1]\n except (psutil.NoSuchProcess, psutil.ZombieProcess, psutil.AccessDenied):\n \n # Sometimes a subprocess descendant will have terminated\n # between the time we obtain a list of descendants, and the\n # time we actually poll this descendant's memory usage.\n pass\n if int(self.max_vms_memory * 1E-8) < int(vms_memory * 1E-8):\n \n # Peak memory updated, at ~100-MB resolution.\n self.max_t = [self.t1]\n if int(self.max_vms_memory * 1E-8) == int(vms_memory * 1E-8):\n \n # Peak memory maintained.\n self.max_t = [self.max_t[0], self.t1]\n self.max_vms_memory = max(self.max_vms_memory,vms_memory)\n self.max_rss_memory = max(self.max_rss_memory,rss_memory)\n\n except (psutil.NoSuchProcess, psutil.ZombieProcess, psutil.AccessDenied):\n return self.check_execution_state()\n\n return self.check_execution_state()\n\n def is_running(self):\n return psutil.pid_exists(self.p.pid) and self.p.poll() == None\n\n def check_execution_state(self):\n if not self.execution_state:\n return False\n if self.is_running():\n return True\n self.executation_state = False\n self.t1 = time.time()\n return False\n\n def close(self,kill=False):\n if self.p is not None:\n try:\n pp = psutil.Process(self.p.pid)\n if kill:\n pp.kill()\n else:\n pp.terminate()\n except (psutil.NoSuchProcess, psutil.ZombieProcess, psutil.AccessDenied):\n pass\n\ndef takewhile_excluding(iterable, value = ['|', '<', '>']):\n for it in iterable:\n if it in value:\n return\n yield it\n\nif __name__ == '__main__':\n import sys, os\n\n if len(sys.argv) <= 1:\n sys.exit()\n\n interval = float(os.environ['MEM_CHECK_INTERVAL']) if 'MEM_CHECK_INTERVAL' in os.environ else 1\n\n ptimer = ProcessTimer(takewhile_excluding(sys.argv[1:]), interval)\n\n try:\n ptimer.execute()\n \n # Poll as often as possible; otherwise the subprocess might\n # \"sneak\" in some extra memory usage while you aren't looking.\n while ptimer.poll():\n time.sleep(ptimer.interval)\n \n finally:\n \n # Make sure that we don't leave the process dangling.\n ptimer.close()\n\n sys.stderr.write('\\ntime elapsed: {:.2f}s\\n'.format(max(0, ptimer.t1 - ptimer.t0 - ptimer.interval * 0.5)))\n sys.stderr.write('peak first occurred: {:.2f}s\\n'.format(min(ptimer.max_t) - ptimer.t0))\n sys.stderr.write('peak last occurred: {:.2f}s\\n'.format(max(ptimer.max_t) - ptimer.t0))\n sys.stderr.write('max vms_memory: {:.2f}GB\\n'.format(ptimer.max_vms_memory * 1.07E-9))\n sys.stderr.write('max rss_memory: {:.2f}GB\\n'.format(ptimer.max_rss_memory * 1.07E-9))\n sys.stderr.write('memory check interval: %ss\\n' % ptimer.interval)\n sys.stderr.write('return code: %s\\n' % ptimer.p.returncode)\n" }, { "path": "inst/code/python_example/N3finemapping_python.ipynb", "content": "{\n \"cells\": [\n {\n \"cell_type\": \"markdown\",\n \"id\": \"c7ac5176-713f-4752-b055-607a22a6dc3e\",\n \"metadata\": {},\n \"source\": [\n \"# N3 fine-mapping example (Python)\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": 1,\n \"id\": \"571c6701-abff-4535-a25e-8c1bdf53d0a9\",\n \"metadata\": {},\n \"outputs\": [],\n \"source\": [\n \"import numpy as np\\n\",\n \"import pandas as pd\\n\",\n \"import rpy2.robjects as ro\\n\",\n \"from rpy2.robjects.packages import importr, data\\n\",\n \"from rpy2.robjects import numpy2ri\\n\",\n \"susie = importr('susieR')\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": 2,\n \"id\": \"4395eb9b-af70-413a-adc5-edce1f5160fa\",\n \"metadata\": {},\n \"outputs\": [],\n \"source\": [\n \"conversion_rules = numpy2ri.converter + ro.default_converter\\n\",\n \"with (conversion_rules).context(): \\n\",\n \" ro.r['set.seed'](1)\\n\",\n \" N3 = data(susie).fetch('N3finemapping')['N3finemapping']\\n\",\n \" N3_names = {v:i for i,v in enumerate(N3.names)}\\n\",\n \" n = N3[N3_names['X']].dim[0]\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": 3,\n \"id\": \"235c3ed5-4415-4301-956d-00615ff6bf48\",\n \"metadata\": {},\n \"outputs\": [\n {\n \"data\": {\n \"text/plain\": [\n \"(array([402, 652, 772]),)\"\n ]\n },\n \"execution_count\": 3,\n \"metadata\": {},\n \"output_type\": \"execute_result\"\n }\n ],\n \"source\": [\n \"b = N3[N3_names['true_coef']]\\n\",\n \"np.where(np.array(b)[:,0] != 0)\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": 4,\n \"id\": \"f50d1770-94aa-4128-8f50-659d9e366d6b\",\n \"metadata\": {},\n \"outputs\": [\n {\n \"name\": \"stderr\",\n \"output_type\": \"stream\",\n \"text\": [\n \"R[write to console]: HINT: For estimate_residual_variance = TRUE, please check that R is the \\\"in-sample\\\" LD matrix; that is, the correlation matrix obtained using the exact same data matrix X that was used for the other summary statistics. Also note, when covariates are included in the univariate regressions that produced the summary statistics, also consider removing these effects from X before computing R.\\n\",\n \"\\n\"\n ]\n },\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \" cs cs_log10bf cs_avg_r2 cs_min_r2\\n\",\n \"1 2 4.033879 1.0000000 1.0000000\\n\",\n \"2 1 6.744085 0.9634847 0.9634847\\n\",\n \"3 3 3.461470 0.9293299 0.7545197\\n\",\n \" variable\\n\",\n \"1 653\\n\",\n \"2 773,777\\n\",\n \"3 362,365,372,373,374,379,381,383,384,386,387,388,389,391,392,396,397,398,399,400,401,403,404,405,407,408,415\\n\",\n \"\\n\"\n ]\n }\n ],\n \"source\": [\n \"with (conversion_rules).context(): \\n\",\n \" sumstats = susie.univariate_regression(\\n\",\n \" N3[N3_names['X']],\\n\",\n \" np.array(N3[N3_names['Y']])[:,0]\\n\",\n \" )\\n\",\n \" z_scores = np.array(sumstats[0])/np.array(sumstats[1])\\n\",\n \" R = np.corrcoef(N3[N3_names['X']], rowvar=False)\\n\",\n \" fitted_rss1 = susie.susie_rss(\\n\",\n \" bhat=sumstats[0], \\n\",\n \" shat=sumstats[1], \\n\",\n \" R=R,\\n\",\n \" n=n,\\n\",\n \" var_y=np.var(np.array(N3[N3_names['Y']])[:,0]),\\n\",\n \" L=10,\\n\",\n \" estimate_residual_variance=True\\n\",\n \" )\\n\",\n \" print(ro.r.summary(fitted_rss1)[1])\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": 5,\n \"id\": \"f933cfd4-d5a8-4c3c-a197-289c50cad29d\",\n \"metadata\": {},\n \"outputs\": [\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \"[1] TRUE\\n\",\n \"\\n\"\n ]\n }\n ],\n \"source\": [\n \"with (conversion_rules).context(): \\n\",\n \" fitted = susie.susie(N3[N3_names['X']], \\n\",\n \" np.array(N3[N3_names['Y']])[:,0], \\n\",\n \" L=10\\n\",\n \" )\\n\",\n \" print(ro.r['all.equal'](fitted[-2], fitted_rss1[-1]))\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": 6,\n \"id\": \"7666219b-cd4f-4bbc-9ac1-e26a56953042\",\n \"metadata\": {},\n \"outputs\": [\n {\n \"name\": \"stderr\",\n \"output_type\": \"stream\",\n \"text\": [\n \"R[write to console]: HINT: For estimate_residual_variance = TRUE, please check that R is the \\\"in-sample\\\" LD matrix; that is, the correlation matrix obtained using the exact same data matrix X that was used for the other summary statistics. Also note, when covariates are included in the univariate regressions that produced the summary statistics, also consider removing these effects from X before computing R.\\n\",\n \"\\n\",\n \"R[write to console]: WARNING: XtX is not symmetric; forcing XtX to be symmetric by replacing XtX with (XtX + t(XtX))/2\\n\",\n \"\\n\",\n \"R[write to console]: Error in Xty - s$XtXr : non-conformable arrays\\n\",\n \"\\n\"\n ]\n },\n {\n \"ename\": \"RRuntimeError\",\n \"evalue\": \"Error in Xty - s$XtXr : non-conformable arrays\\n\",\n \"output_type\": \"error\",\n \"traceback\": [\n \"\\u001b[0;31m---------------------------------------------------------------------------\\u001b[0m\",\n \"\\u001b[0;31mRRuntimeError\\u001b[0m Traceback (most recent call last)\",\n \"Cell \\u001b[0;32mIn[6], line 2\\u001b[0m\\n\\u001b[1;32m 1\\u001b[0m \\u001b[38;5;28;01mwith\\u001b[39;00m (conversion_rules)\\u001b[38;5;241m.\\u001b[39mcontext(): \\n\\u001b[0;32m----> 2\\u001b[0m fitted_rss2 \\u001b[38;5;241m=\\u001b[39m \\u001b[43msusie\\u001b[49m\\u001b[38;5;241;43m.\\u001b[39;49m\\u001b[43msusie_rss\\u001b[49m\\u001b[43m(\\u001b[49m\\n\\u001b[1;32m 3\\u001b[0m \\u001b[43m \\u001b[49m\\u001b[43mz\\u001b[49m\\u001b[38;5;241;43m=\\u001b[39;49m\\u001b[43mz_scores\\u001b[49m\\u001b[43m,\\u001b[49m\\n\\u001b[1;32m 4\\u001b[0m \\u001b[43m \\u001b[49m\\u001b[43mR\\u001b[49m\\u001b[38;5;241;43m=\\u001b[39;49m\\u001b[43mR\\u001b[49m\\u001b[43m,\\u001b[49m\\n\\u001b[1;32m 5\\u001b[0m \\u001b[43m \\u001b[49m\\u001b[43mn\\u001b[49m\\u001b[38;5;241;43m=\\u001b[39;49m\\u001b[43mn\\u001b[49m\\u001b[43m,\\u001b[49m\\u001b[43m \\u001b[49m\\n\\u001b[1;32m 6\\u001b[0m \\u001b[43m \\u001b[49m\\u001b[43mvar_y\\u001b[49m\\u001b[38;5;241;43m=\\u001b[39;49m\\u001b[43mnp\\u001b[49m\\u001b[38;5;241;43m.\\u001b[39;49m\\u001b[43mvar\\u001b[49m\\u001b[43m(\\u001b[49m\\u001b[43mnp\\u001b[49m\\u001b[38;5;241;43m.\\u001b[39;49m\\u001b[43marray\\u001b[49m\\u001b[43m(\\u001b[49m\\u001b[43mN3\\u001b[49m\\u001b[43m[\\u001b[49m\\u001b[43mN3_names\\u001b[49m\\u001b[43m[\\u001b[49m\\u001b[38;5;124;43m'\\u001b[39;49m\\u001b[38;5;124;43mY\\u001b[39;49m\\u001b[38;5;124;43m'\\u001b[39;49m\\u001b[43m]\\u001b[49m\\u001b[43m]\\u001b[49m\\u001b[43m)\\u001b[49m\\u001b[43m[\\u001b[49m\\u001b[43m:\\u001b[49m\\u001b[43m,\\u001b[49m\\u001b[38;5;241;43m0\\u001b[39;49m\\u001b[43m]\\u001b[49m\\u001b[43m)\\u001b[49m\\u001b[43m,\\u001b[49m\\n\\u001b[1;32m 7\\u001b[0m \\u001b[43m \\u001b[49m\\u001b[43mL\\u001b[49m\\u001b[38;5;241;43m=\\u001b[39;49m\\u001b[38;5;241;43m10\\u001b[39;49m\\u001b[43m,\\u001b[49m\\n\\u001b[1;32m 8\\u001b[0m \\u001b[43m \\u001b[49m\\u001b[43mestimate_residual_variance\\u001b[49m\\u001b[38;5;241;43m=\\u001b[39;49m\\u001b[38;5;28;43;01mTrue\\u001b[39;49;00m\\n\\u001b[1;32m 9\\u001b[0m \\u001b[43m \\u001b[49m\\u001b[43m)\\u001b[49m\\n\",\n \"File \\u001b[0;32m~/miniforge3/envs/susie_rpy2/lib/python3.12/site-packages/rpy2/robjects/functions.py:208\\u001b[0m, in \\u001b[0;36mSignatureTranslatedFunction.__call__\\u001b[0;34m(self, *args, **kwargs)\\u001b[0m\\n\\u001b[1;32m 206\\u001b[0m v \\u001b[38;5;241m=\\u001b[39m kwargs\\u001b[38;5;241m.\\u001b[39mpop(k)\\n\\u001b[1;32m 207\\u001b[0m kwargs[r_k] \\u001b[38;5;241m=\\u001b[39m v\\n\\u001b[0;32m--> 208\\u001b[0m \\u001b[38;5;28;01mreturn\\u001b[39;00m (\\u001b[38;5;28;43msuper\\u001b[39;49m\\u001b[43m(\\u001b[49m\\u001b[43mSignatureTranslatedFunction\\u001b[49m\\u001b[43m,\\u001b[49m\\u001b[43m \\u001b[49m\\u001b[38;5;28;43mself\\u001b[39;49m\\u001b[43m)\\u001b[49m\\n\\u001b[1;32m 209\\u001b[0m \\u001b[43m \\u001b[49m\\u001b[38;5;241;43m.\\u001b[39;49m\\u001b[38;5;21;43m__call__\\u001b[39;49m\\u001b[43m(\\u001b[49m\\u001b[38;5;241;43m*\\u001b[39;49m\\u001b[43margs\\u001b[49m\\u001b[43m,\\u001b[49m\\u001b[43m \\u001b[49m\\u001b[38;5;241;43m*\\u001b[39;49m\\u001b[38;5;241;43m*\\u001b[39;49m\\u001b[43mkwargs\\u001b[49m\\u001b[43m)\\u001b[49m)\\n\",\n \"File \\u001b[0;32m~/miniforge3/envs/susie_rpy2/lib/python3.12/site-packages/rpy2/robjects/functions.py:131\\u001b[0m, in \\u001b[0;36mFunction.__call__\\u001b[0;34m(self, *args, **kwargs)\\u001b[0m\\n\\u001b[1;32m 129\\u001b[0m \\u001b[38;5;28;01melse\\u001b[39;00m:\\n\\u001b[1;32m 130\\u001b[0m new_kwargs[k] \\u001b[38;5;241m=\\u001b[39m cv\\u001b[38;5;241m.\\u001b[39mpy2rpy(v)\\n\\u001b[0;32m--> 131\\u001b[0m res \\u001b[38;5;241m=\\u001b[39m \\u001b[38;5;28;43msuper\\u001b[39;49m\\u001b[43m(\\u001b[49m\\u001b[43mFunction\\u001b[49m\\u001b[43m,\\u001b[49m\\u001b[43m \\u001b[49m\\u001b[38;5;28;43mself\\u001b[39;49m\\u001b[43m)\\u001b[49m\\u001b[38;5;241;43m.\\u001b[39;49m\\u001b[38;5;21;43m__call__\\u001b[39;49m\\u001b[43m(\\u001b[49m\\u001b[38;5;241;43m*\\u001b[39;49m\\u001b[43mnew_args\\u001b[49m\\u001b[43m,\\u001b[49m\\u001b[43m \\u001b[49m\\u001b[38;5;241;43m*\\u001b[39;49m\\u001b[38;5;241;43m*\\u001b[39;49m\\u001b[43mnew_kwargs\\u001b[49m\\u001b[43m)\\u001b[49m\\n\\u001b[1;32m 132\\u001b[0m res \\u001b[38;5;241m=\\u001b[39m cv\\u001b[38;5;241m.\\u001b[39mrpy2py(res)\\n\\u001b[1;32m 133\\u001b[0m \\u001b[38;5;28;01mreturn\\u001b[39;00m res\\n\",\n \"File \\u001b[0;32m~/miniforge3/envs/susie_rpy2/lib/python3.12/site-packages/rpy2/rinterface_lib/conversion.py:45\\u001b[0m, in \\u001b[0;36m_cdata_res_to_rinterface.._\\u001b[0;34m(*args, **kwargs)\\u001b[0m\\n\\u001b[1;32m 44\\u001b[0m \\u001b[38;5;28;01mdef\\u001b[39;00m\\u001b[38;5;250m \\u001b[39m\\u001b[38;5;21m_\\u001b[39m(\\u001b[38;5;241m*\\u001b[39margs, \\u001b[38;5;241m*\\u001b[39m\\u001b[38;5;241m*\\u001b[39mkwargs):\\n\\u001b[0;32m---> 45\\u001b[0m cdata \\u001b[38;5;241m=\\u001b[39m \\u001b[43mfunction\\u001b[49m\\u001b[43m(\\u001b[49m\\u001b[38;5;241;43m*\\u001b[39;49m\\u001b[43margs\\u001b[49m\\u001b[43m,\\u001b[49m\\u001b[43m \\u001b[49m\\u001b[38;5;241;43m*\\u001b[39;49m\\u001b[38;5;241;43m*\\u001b[39;49m\\u001b[43mkwargs\\u001b[49m\\u001b[43m)\\u001b[49m\\n\\u001b[1;32m 46\\u001b[0m \\u001b[38;5;66;03m# TODO: test cdata is of the expected CType\\u001b[39;00m\\n\\u001b[1;32m 47\\u001b[0m \\u001b[38;5;28;01mreturn\\u001b[39;00m _cdata_to_rinterface(cdata)\\n\",\n \"File \\u001b[0;32m~/miniforge3/envs/susie_rpy2/lib/python3.12/site-packages/rpy2/rinterface.py:890\\u001b[0m, in \\u001b[0;36mSexpClosure.__call__\\u001b[0;34m(self, *args, **kwargs)\\u001b[0m\\n\\u001b[1;32m 883\\u001b[0m res \\u001b[38;5;241m=\\u001b[39m rmemory\\u001b[38;5;241m.\\u001b[39mprotect(\\n\\u001b[1;32m 884\\u001b[0m openrlib\\u001b[38;5;241m.\\u001b[39mrlib\\u001b[38;5;241m.\\u001b[39mR_tryEval(\\n\\u001b[1;32m 885\\u001b[0m call_r,\\n\\u001b[1;32m 886\\u001b[0m call_context\\u001b[38;5;241m.\\u001b[39m__sexp__\\u001b[38;5;241m.\\u001b[39m_cdata,\\n\\u001b[1;32m 887\\u001b[0m error_occured)\\n\\u001b[1;32m 888\\u001b[0m )\\n\\u001b[1;32m 889\\u001b[0m \\u001b[38;5;28;01mif\\u001b[39;00m error_occured[\\u001b[38;5;241m0\\u001b[39m]:\\n\\u001b[0;32m--> 890\\u001b[0m \\u001b[38;5;28;01mraise\\u001b[39;00m embedded\\u001b[38;5;241m.\\u001b[39mRRuntimeError(_rinterface\\u001b[38;5;241m.\\u001b[39m_geterrmessage())\\n\\u001b[1;32m 891\\u001b[0m \\u001b[38;5;28;01mreturn\\u001b[39;00m res\\n\",\n \"\\u001b[0;31mRRuntimeError\\u001b[0m: Error in Xty - s$XtXr : non-conformable arrays\\n\"\n ]\n }\n ],\n \"source\": [\n \"with (conversion_rules).context(): \\n\",\n \" fitted_rss2 = susie.susie_rss(\\n\",\n \" z=z_scores,\\n\",\n \" R=R,\\n\",\n \" n=n, \\n\",\n \" var_y=np.var(np.array(N3[N3_names['Y']])[:,0]),\\n\",\n \" L=10,\\n\",\n \" estimate_residual_variance=True\\n\",\n \" )\\n\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": 7,\n \"id\": \"00063c8b-6af3-4d65-9314-4971264d0d08\",\n \"metadata\": {},\n \"outputs\": [\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \"R version 4.4.2 (2024-10-31)\\n\",\n \"Platform: x86_64-conda-linux-gnu\\n\",\n \"Running under: Red Hat Enterprise Linux 8.6 (Ootpa)\\n\",\n \"\\n\",\n \"Matrix products: default\\n\",\n \"BLAS/LAPACK: /hpfs/userws/chiouj02/software/conda_envs/susie_rpy2/lib/libopenblasp-r0.3.29.so; LAPACK version 3.12.0\\n\",\n \"\\n\",\n \"locale:\\n\",\n \" [1] LC_CTYPE=en_US.UTF-8 LC_NUMERIC=C \\n\",\n \" [3] LC_TIME=en_US.UTF-8 LC_COLLATE=en_US.UTF-8 \\n\",\n \" [5] LC_MONETARY=en_US.UTF-8 LC_MESSAGES=en_US.UTF-8 \\n\",\n \" [7] LC_PAPER=en_US.UTF-8 LC_NAME=C \\n\",\n \" [9] LC_ADDRESS=C LC_TELEPHONE=C \\n\",\n \"[11] LC_MEASUREMENT=en_US.UTF-8 LC_IDENTIFICATION=C \\n\",\n \"\\n\",\n \"time zone: America/New_York\\n\",\n \"tzcode source: system (glibc)\\n\",\n \"\\n\",\n \"attached base packages:\\n\",\n \"[1] tools stats graphics grDevices utils datasets methods \\n\",\n \"[8] base \\n\",\n \"\\n\",\n \"other attached packages:\\n\",\n \"[1] susieR_0.12.35\\n\",\n \"\\n\",\n \"loaded via a namespace (and not attached):\\n\",\n \" [1] crayon_1.5.3 mixsqp_0.3-54 vctrs_0.6.5 \\n\",\n \" [4] cli_3.6.4 rlang_1.1.5 generics_0.1.3 \\n\",\n \" [7] RcppZiggurat_0.1.6 RcppParallel_5.1.10 glue_1.8.0 \\n\",\n \"[10] colorspace_2.1-1 plyr_1.8.9 scales_1.3.0 \\n\",\n \"[13] grid_4.4.2 munsell_0.5.1 tibble_3.2.1 \\n\",\n \"[16] lifecycle_1.0.4 compiler_4.4.2 dplyr_1.1.4 \\n\",\n \"[19] irlba_2.3.5.1 Rcpp_1.0.14 pkgconfig_2.0.3 \\n\",\n \"[22] Rfast_2.1.4 lattice_0.22-6 R6_2.6.1 \\n\",\n \"[25] tidyselect_1.2.1 parallel_4.4.2 pillar_1.10.1 \\n\",\n \"[28] magrittr_2.0.3 Matrix_1.7-2 gtable_0.3.6 \\n\",\n \"[31] reshape_0.8.9 matrixStats_1.5.0 ggplot2_3.5.1 \\n\",\n \"\\n\"\n ]\n }\n ],\n \"source\": [\n \"print(ro.r.sessionInfo())\"\n ]\n }\n ],\n \"metadata\": {\n \"kernelspec\": {\n \"display_name\": \"susie_rpy2\",\n \"language\": \"python\",\n \"name\": \"susie_rpy2\"\n },\n \"language_info\": {\n \"codemirror_mode\": {\n \"name\": \"ipython\",\n \"version\": 3\n },\n \"file_extension\": \".py\",\n \"mimetype\": \"text/x-python\",\n \"name\": \"python\",\n \"nbconvert_exporter\": \"python\",\n \"pygments_lexer\": \"ipython3\",\n \"version\": \"3.12.9\"\n }\n },\n \"nbformat\": 4,\n \"nbformat_minor\": 5\n}\n" }, { "path": "inst/code/python_example/environment.yml", "content": "name: susie_rpy2\nchannels:\n - conda-forge\n - defaults\ndependencies:\n - _libgcc_mutex=0.1=conda_forge\n - _openmp_mutex=4.5=2_gnu\n - _r-mutex=1.0.1=anacondar_1\n - asttokens=3.0.0=pyhd8ed1ab_1\n - binutils_impl_linux-64=2.43=h4bf12b8_4\n - bwidget=1.10.1=ha770c72_0\n - bzip2=1.0.8=h4bc722e_7\n - c-ares=1.34.4=hb9d3cd8_0\n - ca-certificates=2025.1.31=hbcca054_0\n - cairo=1.18.2=h3394656_1\n - comm=0.2.2=pyhd8ed1ab_1\n - curl=8.12.1=h332b0f4_0\n - debugpy=1.8.12=py312h2ec8cdc_0\n - decorator=5.2.1=pyhd8ed1ab_0\n - exceptiongroup=1.2.2=pyhd8ed1ab_1\n - executing=2.1.0=pyhd8ed1ab_1\n - font-ttf-dejavu-sans-mono=2.37=hab24e00_0\n - font-ttf-inconsolata=3.000=h77eed37_0\n - font-ttf-source-code-pro=2.038=h77eed37_0\n - font-ttf-ubuntu=0.83=h77eed37_3\n - fontconfig=2.15.0=h7e30c49_1\n - fonts-conda-ecosystem=1=0\n - fonts-conda-forge=1=0\n - freetype=2.12.1=h267a509_2\n - fribidi=1.0.10=h36c2ea0_0\n - gcc_impl_linux-64=14.2.0=hdb7739f_2\n - gfortran_impl_linux-64=14.2.0=h0ee6e4a_2\n - graphite2=1.3.13=h59595ed_1003\n - gsl=2.7=he838d99_0\n - gxx_impl_linux-64=14.2.0=h2ead766_2\n - harfbuzz=10.3.0=h76408a6_0\n - icu=75.1=he02047a_0\n - importlib-metadata=8.6.1=pyha770c72_0\n - ipykernel=6.29.5=pyh3099207_0\n - ipython=8.32.0=pyh907856f_0\n - jedi=0.19.2=pyhd8ed1ab_1\n - jupyter_client=8.6.3=pyhd8ed1ab_1\n - jupyter_core=5.7.2=pyh31011fe_1\n - kernel-headers_linux-64=3.10.0=he073ed8_18\n - keyutils=1.6.1=h166bdaf_0\n - krb5=1.21.3=h659f571_0\n - ld_impl_linux-64=2.43=h712a8e2_4\n - lerc=4.0.0=h27087fc_0\n - libblas=3.9.0=31_h59b9bed_openblas\n - libcblas=3.9.0=31_he106b2a_openblas\n - libcurl=8.12.1=h332b0f4_0\n - libdeflate=1.23=h4ddbbb0_0\n - libedit=3.1.20250104=pl5321h7949ede_0\n - libev=4.33=hd590300_2\n - libexpat=2.6.4=h5888daf_0\n - libffi=3.4.6=h2dba641_0\n - libgcc=14.2.0=h767d61c_2\n - libgcc-devel_linux-64=14.2.0=h9c4974d_102\n - libgcc-ng=14.2.0=h69a702a_2\n - libgfortran=14.2.0=h69a702a_2\n - libgfortran-ng=14.2.0=h69a702a_2\n - libgfortran5=14.2.0=hf1ad2bd_2\n - libglib=2.82.2=h2ff4ddf_1\n - libgomp=14.2.0=h767d61c_2\n - libiconv=1.18=h4ce23a2_1\n - libjpeg-turbo=3.0.0=hd590300_1\n - liblapack=3.9.0=31_h7ac8fdf_openblas\n - liblzma=5.6.4=hb9d3cd8_0\n - libnghttp2=1.64.0=h161d5f1_0\n - libnsl=2.0.1=hd590300_0\n - libopenblas=0.3.29=pthreads_h94d23a6_0\n - libpng=1.6.47=h943b412_0\n - libsanitizer=14.2.0=hed042b8_2\n - libsodium=1.0.20=h4ab18f5_0\n - libsqlite=3.49.1=hee588c1_1\n - libssh2=1.11.1=hf672d98_0\n - libstdcxx=14.2.0=h8f9b012_2\n - libstdcxx-devel_linux-64=14.2.0=h9c4974d_102\n - libstdcxx-ng=14.2.0=h4852527_2\n - libtiff=4.7.0=hd9ff511_3\n - libuuid=2.38.1=h0b41bf4_0\n - libwebp-base=1.5.0=h851e524_0\n - libxcb=1.17.0=h8a09558_0\n - libxcrypt=4.4.36=hd590300_1\n - libzlib=1.3.1=hb9d3cd8_2\n - make=4.4.1=hb9d3cd8_2\n - matplotlib-inline=0.1.7=pyhd8ed1ab_1\n - ncurses=6.5=h2d0b736_3\n - nest-asyncio=1.6.0=pyhd8ed1ab_1\n - numpy=2.2.3=py312h72c5963_0\n - openssl=3.4.1=h7b32b05_0\n - packaging=24.2=pyhd8ed1ab_2\n - pandas=2.2.3=py312hf9745cd_1\n - pango=1.56.1=h861ebed_0\n - parso=0.8.4=pyhd8ed1ab_1\n - pcre2=10.44=hba22ea6_2\n - pexpect=4.9.0=pyhd8ed1ab_1\n - pickleshare=0.7.5=pyhd8ed1ab_1004\n - pip=25.0.1=pyh8b19718_0\n - pixman=0.44.2=h29eaf8c_0\n - platformdirs=4.3.6=pyhd8ed1ab_1\n - prompt-toolkit=3.0.50=pyha770c72_0\n - psutil=6.1.1=py312h66e93f0_0\n - pthread-stubs=0.4=hb9d3cd8_1002\n - ptyprocess=0.7.0=pyhd8ed1ab_1\n - pure_eval=0.2.3=pyhd8ed1ab_1\n - pygments=2.19.1=pyhd8ed1ab_0\n - python=3.12.9=h9e4cc4f_0_cpython\n - python-dateutil=2.9.0.post0=pyhff2d567_1\n - python-tzdata=2025.1=pyhd8ed1ab_0\n - python_abi=3.12=5_cp312\n - pytz=2024.1=pyhd8ed1ab_0\n - pyzmq=26.2.1=py312hbf22597_0\n - r-base=4.4.2=hc737e89_2\n - readline=8.2=h8c095d6_2\n - sed=4.8=he412f7d_0\n - setuptools=75.8.0=pyhff2d567_0\n - six=1.17.0=pyhd8ed1ab_0\n - stack_data=0.6.3=pyhd8ed1ab_1\n - sysroot_linux-64=2.17=h0157908_18\n - tk=8.6.13=noxft_h4845f30_101\n - tktable=2.10=h8bc8fbc_6\n - tornado=6.4.2=py312h66e93f0_0\n - traitlets=5.14.3=pyhd8ed1ab_1\n - typing_extensions=4.12.2=pyha770c72_1\n - tzdata=2025a=h78e105d_0\n - wcwidth=0.2.13=pyhd8ed1ab_1\n - wheel=0.45.1=pyhd8ed1ab_1\n - xorg-libice=1.1.2=hb9d3cd8_0\n - xorg-libsm=1.2.5=he73a12e_0\n - xorg-libx11=1.8.11=h4f16b4b_0\n - xorg-libxau=1.0.12=hb9d3cd8_0\n - xorg-libxdmcp=1.1.5=hb9d3cd8_0\n - xorg-libxext=1.3.6=hb9d3cd8_0\n - xorg-libxrender=0.9.12=hb9d3cd8_0\n - xorg-libxt=1.3.1=hb9d3cd8_0\n - zeromq=4.3.5=h3b0a872_7\n - zipp=3.21.0=pyhd8ed1ab_1\n - zstd=1.5.7=hb8e6e7a_1\n - pip:\n - cffi==1.17.1\n - jinja2==3.1.5\n - markupsafe==3.0.2\n - pycparser==2.22\n - rpy2==3.5.17\n - tzlocal==5.3\nprefix: /home/chiouj02/miniforge3/envs/susie_rpy2\n" }, { "path": "inst/code/simulate_lambda_pop_ld_bias.R", "content": "#!/usr/bin/env Rscript\n\n# Simulate GTEx-like eQTL summary statistics from real-LD genotype matrices,\n# then compare in-sample, ADSP-like, and UKB-like LD references with and without\n# the population-bias correction.\n\ndefault_config <- list(\n input_dir = \"/home/gw/Documents/susie_ash_test/chat_test\",\n output_dir = \"/home/gw/Documents/susie_ash_test/chat_test/lambda_pop_sim_results\",\n susie_repo = \"/home/gw/GIT/susieR\",\n simxqtl_repo = \"/home/gw/GIT/simxQTL\",\n n_reps = 20L,\n seed = 20260501L,\n p_max = 2500L,\n n_ref = 500L,\n L = 10L,\n max_iter = 80L,\n coverage = 0.95,\n min_abs_corr = 0.5,\n ld_proxy_threshold = 0.8,\n h2g = 0.15,\n n_sparse = 3L,\n n_oligogenic = 0L,\n n_inf = 0L,\n prop_h2_sparse = 1.00,\n prop_h2_oligogenic = 0.00,\n prop_h2_infinitesimal = 0.00,\n adsp_delta = 0.02,\n ukb_delta = 0.35,\n lambda_zero_tol = 0.01,\n include_map_qc = TRUE,\n verbose_fit = FALSE,\n verbose_reps = 1L,\n smoke = FALSE\n)\n\nvlog <- function(...) {\n msg <- paste0(\"[\", format(Sys.time(), \"%H:%M:%S\"), \"] \", ...)\n message(msg)\n flush.console()\n}\n\nparse_args <- function(defaults) {\n args <- commandArgs(trailingOnly = TRUE)\n cfg <- defaults\n if (!length(args)) {\n return(cfg)\n }\n for (arg in args) {\n if (!grepl(\"^--\", arg)) {\n stop(\"Arguments must be --name=value; got: \", arg)\n }\n kv <- strsplit(sub(\"^--\", \"\", arg), \"=\", fixed = TRUE)[[1]]\n key <- gsub(\"-\", \"_\", kv[1])\n value <- if (length(kv) > 1) paste(kv[-1], collapse = \"=\") else \"TRUE\"\n if (!key %in% names(cfg)) {\n stop(\"Unknown argument --\", kv[1])\n }\n old <- cfg[[key]]\n if (is.logical(old)) {\n cfg[[key]] <- tolower(value) %in% c(\"true\", \"t\", \"1\", \"yes\", \"y\")\n } else if (is.integer(old)) {\n cfg[[key]] <- as.integer(value)\n } else if (is.numeric(old)) {\n cfg[[key]] <- as.numeric(value)\n } else {\n cfg[[key]] <- value\n }\n }\n if (isTRUE(cfg$smoke)) {\n cfg$n_reps <- min(cfg$n_reps, 1L)\n cfg$p_max <- min(cfg$p_max, 300L)\n cfg$n_ref <- min(cfg$n_ref, 200L)\n cfg$L <- min(cfg$L, 6L)\n cfg$max_iter <- min(cfg$max_iter, 20L)\n }\n cfg\n}\n\nload_local_packages <- function(cfg) {\n if (!requireNamespace(\"pkgload\", quietly = TRUE)) {\n stop(\"Package 'pkgload' is required to load local susieR and simxQTL repos.\")\n }\n pkgload::load_all(cfg$susie_repo, quiet = TRUE)\n pkgload::load_all(cfg$simxqtl_repo, quiet = TRUE)\n}\n\nwrite_json <- function(x, file) {\n if (requireNamespace(\"jsonlite\", quietly = TRUE)) {\n jsonlite::write_json(x, file, pretty = TRUE, auto_unbox = TRUE, null = \"null\")\n } else {\n capture.output(str(x), file = file)\n }\n}\n\nstandardize_matrix <- function(X) {\n X <- as.matrix(X)\n X <- scale(X, center = TRUE, scale = TRUE)\n X[is.na(X)] <- 0\n storage.mode(X) <- \"double\"\n X\n}\n\nselect_variant_window <- function(G, p_max, seed) {\n G <- as.matrix(G)\n p <- ncol(G)\n if (p <= p_max) {\n return(standardize_matrix(G))\n }\n set.seed(seed)\n start <- sample.int(p - p_max + 1L, 1L)\n standardize_matrix(G[, start:(start + p_max - 1L), drop = FALSE])\n}\n\nread_genotype_files <- function(input_dir) {\n files <- list.files(input_dir, pattern = \"[.]rds$\", recursive = TRUE,\n full.names = TRUE)\n ok <- logical(length(files))\n dims <- vector(\"list\", length(files))\n for (i in seq_along(files)) {\n obj <- tryCatch(readRDS(files[i]), error = function(e) NULL)\n X <- if (!is.null(obj$G)) obj$G else obj$X\n ok[i] <- is.matrix(X) || is.data.frame(X)\n if (ok[i]) {\n dims[[i]] <- dim(X)\n }\n }\n data.frame(\n file = files[ok],\n n = vapply(dims[ok], `[`, numeric(1), 1L),\n p = vapply(dims[ok], `[`, numeric(1), 2L),\n stringsAsFactors = FALSE\n )\n}\n\nmake_reference_panel <- function(G, n_ref, delta, seed) {\n set.seed(seed)\n n <- nrow(G)\n idx <- sample.int(n, n_ref, replace = n_ref > n)\n X <- G[idx, , drop = FALSE]\n if (delta > 0) {\n E <- matrix(rnorm(n_ref * ncol(G)), n_ref, ncol(G))\n X <- sqrt(1 - delta) * X + sqrt(delta) * E\n }\n standardize_matrix(X)\n}\n\nmake_z_scores <- function(X, y) {\n z <- calc_z(X, y, center = TRUE, scale = FALSE)\n z[!is.finite(z)] <- 0\n as.numeric(z)\n}\n\nfit_susie_rss <- function(z, X_ref, n_target, cfg, method, verbose_fit = FALSE) {\n R_mismatch <- switch(method,\n no_finite_no_bias = \"none\",\n finite_only = \"none\",\n bias_map = \"map\",\n bias_map_qc = \"map_qc\",\n stop(\"Unknown method: \", method))\n R_finite <- switch(method,\n no_finite_no_bias = NULL,\n finite_only = TRUE,\n bias_map = TRUE,\n bias_map_qc = TRUE,\n stop(\"Unknown method: \", method))\n args <- list(\n z = z,\n X = X_ref,\n n = n_target,\n L = cfg$L,\n coverage = cfg$coverage,\n\t min_abs_corr = cfg$min_abs_corr,\n\t max_iter = cfg$max_iter,\n\t R_finite = R_finite,\n\t R_mismatch = R_mismatch,\n\t estimate_residual_variance = FALSE,\n\t verbose = isTRUE(verbose_fit)\n\t )\n if (isTRUE(verbose_fit)) {\n return(do.call(susie_rss, args))\n }\n withCallingHandlers(do.call(susie_rss, args),\n message = function(m) invokeRestart(\"muffleMessage\"),\n warning = function(w) invokeRestart(\"muffleWarning\"))\n}\n\nextract_lambda_table <- function(fit, rep_id, panel, method) {\n diag <- fit$R_finite_diagnostics\n lb <- diag$lambda_bias\n if (is.null(lb)) {\n lb <- rep(NA_real_, nrow(fit$alpha))\n }\n bc <- diag$B_corrected\n if (is.null(bc)) {\n bc <- rep(NA_real_, length(lb))\n }\n data.frame(\n rep = rep_id,\n panel = panel,\n method = method,\n effect = seq_along(lb),\n R_finite_B = if (is.null(diag$B)) NA_real_ else as.numeric(diag$B),\n lambda_pop = as.numeric(lb),\n B_corrected = as.numeric(bc),\n stringsAsFactors = FALSE\n )\n}\n\nmax_abs_ld_to_causal <- function(X_target, idx, causal) {\n if (!length(idx) || !length(causal)) {\n return(0)\n }\n idx <- intersect(idx, seq_len(ncol(X_target)))\n causal <- intersect(causal, seq_len(ncol(X_target)))\n if (!length(idx) || !length(causal)) {\n return(0)\n }\n C <- crossprod(X_target[, idx, drop = FALSE],\n X_target[, causal, drop = FALSE]) / (nrow(X_target) - 1)\n max(abs(C))\n}\n\ncausal_detected_by_cs <- function(X_target, cs, causal, ld_threshold) {\n if (!length(cs) || !length(causal)) {\n return(integer(0))\n }\n detected <- integer(0)\n for (j in causal) {\n if (j %in% cs) {\n detected <- c(detected, j)\n } else {\n C <- crossprod(X_target[, cs, drop = FALSE],\n X_target[, j, drop = FALSE]) / (nrow(X_target) - 1)\n if (max(abs(C)) >= ld_threshold) {\n detected <- c(detected, j)\n }\n }\n }\n unique(detected)\n}\n\nextract_cs_metrics <- function(fit, X_target, causal, rep_id, panel, method,\n ld_threshold) {\n cs_list <- fit$sets$cs\n if (is.null(cs_list) || !length(cs_list)) {\n return(data.frame(\n rep = rep_id, panel = panel, method = method, cs_name = NA_character_,\n cs_size = 0L, exact_hit = FALSE, proxy_hit = FALSE,\n max_abs_ld_to_causal = NA_real_, detected_causal = NA_character_,\n stringsAsFactors = FALSE\n ))\n }\n rows <- vector(\"list\", length(cs_list))\n for (i in seq_along(cs_list)) {\n cs <- as.integer(cs_list[[i]])\n detected <- causal_detected_by_cs(X_target, cs, causal, ld_threshold)\n rows[[i]] <- data.frame(\n rep = rep_id,\n panel = panel,\n method = method,\n cs_name = names(cs_list)[i],\n cs_size = length(cs),\n exact_hit = any(cs %in% causal),\n proxy_hit = length(detected) > 0,\n max_abs_ld_to_causal = max_abs_ld_to_causal(X_target, cs, causal),\n detected_causal = paste(detected, collapse = \";\"),\n stringsAsFactors = FALSE\n )\n }\n do.call(rbind, rows)\n}\n\nsummarize_fit <- function(fit, X_target, causal, rep_id, panel, method,\n elapsed, err = NULL, ld_threshold = 0.8) {\n if (!is.null(err)) {\n return(data.frame(\n rep = rep_id, panel = panel, method = method, status = \"error\",\n error = conditionMessage(err), elapsed_sec = elapsed,\n n_cs = NA_integer_, cs_tp_exact = NA_integer_, cs_tp_proxy = NA_integer_,\n cs_fp_proxy = NA_integer_, cs_fdr_proxy = NA_real_,\n causal_recall_proxy = NA_real_, top1_is_causal = NA,\n top1_ld_proxy = NA, max_pip_causal = NA_real_,\n mean_lambda_pop = NA_real_, max_lambda_pop = NA_real_,\n nonzero_lambda_pop = NA_integer_, R_finite_B = NA_real_,\n mean_B_corrected = NA_real_,\n max_per_variable_penalty = NA_real_, Q_art = NA_real_,\n artifact_flag = NA, mode_label = NA_character_, converged = NA,\n stringsAsFactors = FALSE\n ))\n }\n\n cs_rows <- extract_cs_metrics(fit, X_target, causal, rep_id, panel, method,\n ld_threshold)\n has_cs <- !all(is.na(cs_rows$cs_name))\n detected <- integer(0)\n if (has_cs) {\n det_str <- cs_rows$detected_causal[nzchar(cs_rows$detected_causal)]\n detected <- unique(as.integer(unlist(strsplit(paste(det_str, collapse = \";\"),\n \";\", fixed = TRUE))))\n detected <- detected[!is.na(detected)]\n }\n top1 <- which.max(fit$pip)\n diag <- fit$R_finite_diagnostics\n lb <- diag$lambda_bias\n penalty <- diag$per_variable_penalty\n data.frame(\n rep = rep_id,\n panel = panel,\n method = method,\n status = \"ok\",\n error = NA_character_,\n elapsed_sec = elapsed,\n n_cs = if (has_cs) nrow(cs_rows) else 0L,\n cs_tp_exact = if (has_cs) sum(cs_rows$exact_hit) else 0L,\n cs_tp_proxy = if (has_cs) sum(cs_rows$proxy_hit) else 0L,\n cs_fp_proxy = if (has_cs) sum(!cs_rows$proxy_hit) else 0L,\n cs_fdr_proxy = if (has_cs) mean(!cs_rows$proxy_hit) else NA_real_,\n causal_recall_proxy = length(intersect(detected, causal)) / length(causal),\n top1_is_causal = top1 %in% causal,\n top1_ld_proxy = max_abs_ld_to_causal(X_target, top1, causal) >= ld_threshold,\n max_pip_causal = max(fit$pip[causal]),\n R_finite_B = if (is.null(diag$B)) NA_real_ else as.numeric(diag$B),\n mean_lambda_pop = if (is.null(lb)) NA_real_ else mean(lb),\n max_lambda_pop = if (is.null(lb)) NA_real_ else max(lb),\n nonzero_lambda_pop = if (is.null(lb)) NA_integer_ else sum(lb > 0),\n mean_B_corrected = if (is.null(diag$B_corrected)) NA_real_ else mean(diag$B_corrected),\n max_per_variable_penalty = if (is.null(penalty)) NA_real_ else max(penalty),\n Q_art = if (is.null(diag$Q_art)) NA_real_ else diag$Q_art,\n artifact_flag = if (is.null(diag$artifact_flag)) NA else isTRUE(diag$artifact_flag),\n mode_label = if (is.null(diag$mode_label)) NA_character_ else as.character(diag$mode_label),\n converged = isTRUE(fit$converged),\n stringsAsFactors = FALSE\n )\n}\n\nwrite_ai_readme <- function(cfg, out_dir) {\n lines <- c(\n \"# Lambda-pop LD-bias simulation outputs\",\n \"\",\n \"Primary files for AI parsing:\",\n \"\",\n \"- `per_fit_metrics.csv`: one row per replicate, panel, and method. Key methods are `no_finite_no_bias`, `finite_only`, `bias_map`, and `bias_map_qc`; key columns are `R_finite_B`, `max_lambda_pop`, `mean_lambda_pop`, `mean_B_corrected`, `causal_recall_proxy`, `cs_fdr_proxy`, `top1_is_causal`, and `max_pip_causal`.\",\n \"- `per_effect_lambda.csv`: per-effect `R_finite_B`, `lambda_pop`, and `B_corrected` estimates.\",\n \"- `cs_metrics.csv`: one row per credible set, with exact and LD-proxy truth labels.\",\n \"- `replicate_metadata.csv`: source file, dimensions, causal indices, and realized h2.\",\n \"- `aggregate_summary.csv`: mean/median summaries grouped by panel and method.\",\n \"- `run_config.json`: exact simulation settings.\",\n \"\",\n \"Expected checks:\",\n \"\",\n \"1. In-sample LD with `method == bias_map` should have `lambda_pop` equal or very close to zero.\",\n \"2. `ADSP_like` should have smaller `lambda_pop` and larger `B_corrected` than `UKB_like`.\",\n \"3. `bias_map` should reduce false credible sets under biased LD without losing too much causal recall.\",\n \"\",\n paste0(\"Configured ADSP delta = \", cfg$adsp_delta,\n \"; UKB delta = \", cfg$ukb_delta,\n \"; LD proxy threshold = \", cfg$ld_proxy_threshold, \".\")\n )\n writeLines(lines, file.path(out_dir, \"AI_PARSE_ME.md\"))\n}\n\naggregate_metrics <- function(metrics) {\n ok <- metrics[metrics$status == \"ok\", , drop = FALSE]\n if (!nrow(ok)) {\n return(data.frame())\n }\n groups <- unique(ok[, c(\"panel\", \"method\")])\n rows <- vector(\"list\", nrow(groups))\n for (i in seq_len(nrow(groups))) {\n idx <- ok$panel == groups$panel[i] & ok$method == groups$method[i]\n x <- ok[idx, , drop = FALSE]\n rows[[i]] <- data.frame(\n panel = groups$panel[i],\n method = groups$method[i],\n n_ok = nrow(x),\n mean_max_lambda_pop = mean(x$max_lambda_pop, na.rm = TRUE),\n median_max_lambda_pop = median(x$max_lambda_pop, na.rm = TRUE),\n mean_lambda_pop = mean(x$mean_lambda_pop, na.rm = TRUE),\n R_finite_B = mean(x$R_finite_B, na.rm = TRUE),\n mean_B_corrected = mean(x$mean_B_corrected, na.rm = TRUE),\n mean_causal_recall_proxy = mean(x$causal_recall_proxy, na.rm = TRUE),\n mean_cs_fdr_proxy = mean(x$cs_fdr_proxy, na.rm = TRUE),\n mean_n_cs = mean(x$n_cs, na.rm = TRUE),\n mean_max_pip_causal = mean(x$max_pip_causal, na.rm = TRUE),\n artifact_flag_rate = mean(x$artifact_flag, na.rm = TRUE),\n mean_Q_art = mean(x$Q_art, na.rm = TRUE),\n top1_causal_rate = mean(x$top1_is_causal, na.rm = TRUE),\n top1_proxy_rate = mean(x$top1_ld_proxy, na.rm = TRUE),\n stringsAsFactors = FALSE\n )\n }\n do.call(rbind, rows)\n}\n\nmetric_value <- function(metrics, rep_i, panel, method, column) {\n idx <- metrics$rep == rep_i & metrics$panel == panel & metrics$method == method\n if (!any(idx)) {\n return(NA_real_)\n }\n value <- metrics[idx, column][1]\n if (is.logical(value)) {\n return(as.numeric(value))\n }\n as.numeric(value)\n}\n\nmean_metric <- function(metrics, panel, method, column) {\n idx <- metrics$status == \"ok\" & metrics$panel == panel & metrics$method == method\n if (!any(idx)) {\n return(NA_real_)\n }\n mean(as.numeric(metrics[idx, column]), na.rm = TRUE)\n}\n\nfmt_metric <- function(x, digits = 3) {\n if (!is.finite(x)) {\n return(\"NA\")\n }\n formatC(x, format = \"fg\", digits = digits)\n}\n\nprint_progress_line <- function(metrics, rep_i, cfg) {\n in_lambda <- metric_value(metrics, rep_i, \"in_sample\", \"bias_map\",\n \"max_lambda_pop\")\n adsp_lambda <- metric_value(metrics, rep_i, \"ADSP_like\", \"bias_map\",\n \"max_lambda_pop\")\n ukb_lambda <- metric_value(metrics, rep_i, \"UKB_like\", \"bias_map\",\n \"max_lambda_pop\")\n adsp_recall <- metric_value(metrics, rep_i, \"ADSP_like\", \"bias_map\",\n \"causal_recall_proxy\")\n ukb_recall <- metric_value(metrics, rep_i, \"UKB_like\", \"bias_map\",\n \"causal_recall_proxy\")\n adsp_fdr <- metric_value(metrics, rep_i, \"ADSP_like\", \"bias_map\",\n \"cs_fdr_proxy\")\n ukb_fdr <- metric_value(metrics, rep_i, \"UKB_like\", \"bias_map\",\n \"cs_fdr_proxy\")\n\n mean_in_lambda <- mean_metric(metrics, \"in_sample\", \"bias_map\",\n \"max_lambda_pop\")\n mean_adsp_lambda <- mean_metric(metrics, \"ADSP_like\", \"bias_map\",\n \"max_lambda_pop\")\n mean_ukb_lambda <- mean_metric(metrics, \"UKB_like\", \"bias_map\",\n \"max_lambda_pop\")\n mean_adsp_recall <- mean_metric(metrics, \"ADSP_like\", \"bias_map\",\n \"causal_recall_proxy\")\n mean_ukb_recall <- mean_metric(metrics, \"UKB_like\", \"bias_map\",\n \"causal_recall_proxy\")\n\n in_ok <- is.finite(in_lambda) && in_lambda <= cfg$lambda_zero_tol\n adsp_lt_ukb <- is.finite(adsp_lambda) && is.finite(ukb_lambda) &&\n adsp_lambda < ukb_lambda\n mean_adsp_lt_ukb <- is.finite(mean_adsp_lambda) &&\n is.finite(mean_ukb_lambda) && mean_adsp_lambda < mean_ukb_lambda\n\n message(\n \"PROGRESS rep=\", rep_i,\n \" current: in_lambda=\", fmt_metric(in_lambda),\n \" in_zero=\", in_ok,\n \" ADSP_lambda=\", fmt_metric(adsp_lambda),\n \" UKB_lambda=\", fmt_metric(ukb_lambda),\n \" ADSP= 1L & causal <= ncol(X_target)]\n if (!length(causal)) {\n causal <- sort(unique(which(sim$beta != 0)))\n }\n vlog(\" simulated y: h2g_real=\", fmt_metric(sim$h2g),\n \" causal=[\", paste(causal, collapse = \",\"), \"]\")\n\n panels <- list(\n in_sample = X_target,\n ADSP_like = make_reference_panel(X_target, cfg$n_ref, cfg$adsp_delta,\n rep_seed + 11L),\n UKB_like = make_reference_panel(X_target, cfg$n_ref, cfg$ukb_delta,\n rep_seed + 23L)\n )\n methods <- c(\"no_finite_no_bias\", \"finite_only\", \"bias_map\")\n if (isTRUE(cfg$include_map_qc)) {\n methods <- c(methods, \"bias_map_qc\")\n }\n\n all_meta[[rep_i]] <- data.frame(\n rep = rep_i,\n source_file = chosen[rep_i],\n n_target = nrow(X_target),\n p = ncol(X_target),\n n_causal_sparse = length(causal),\n causal_sparse = paste(causal, collapse = \";\"),\n h2g_realized = sim$h2g,\n h2_sparse_realized = sim$h2_sparse,\n h2_oligogenic_realized = sim$h2_oligogenic,\n h2_infinitesimal_realized = sim$h2_infinitesimal,\n stringsAsFactors = FALSE\n )\n\n for (panel_name in names(panels)) {\n for (method in methods) {\n verbose_fit <- isTRUE(cfg$verbose_fit) &&\n rep_i <= cfg$verbose_reps &&\n method %in% c(\"bias_map\", \"bias_map_qc\")\n if (verbose_fit) {\n message(\"VERBOSE_FIT_BEGIN rep=\", rep_i, \" panel=\", panel_name,\n \" method=\", method)\n }\n res <- run_one_fit(z, panels[[panel_name]], nrow(X_target), cfg,\n method, rep_i, panel_name, X_target, causal,\n verbose_fit = verbose_fit)\n if (verbose_fit) {\n message(\"VERBOSE_FIT_END rep=\", rep_i, \" panel=\", panel_name,\n \" method=\", method)\n }\n key <- paste(rep_i, panel_name, method, sep = \"__\")\n all_metrics[[key]] <- res$metric\n all_lambda[[key]] <- res$lambda\n all_cs[[key]] <- res$cs\n compact_fits[[key]] <- list(\n pip = if (!is.null(res$fit)) res$fit$pip else NULL,\n sets = if (!is.null(res$fit)) res$fit$sets else NULL,\n R_finite_diagnostics =\n if (!is.null(res$fit)) res$fit$R_finite_diagnostics else NULL\n )\n }\n }\n\n metrics_so_far <- do.call(rbind, all_metrics)\n write.csv(metrics_so_far, file.path(cfg$output_dir, \"per_fit_metrics.csv\"),\n row.names = FALSE)\n write.csv(do.call(rbind, all_meta),\n file.path(cfg$output_dir, \"replicate_metadata.csv\"),\n row.names = FALSE)\n if (length(all_lambda)) {\n write.csv(do.call(rbind, all_lambda),\n file.path(cfg$output_dir, \"per_effect_lambda.csv\"),\n row.names = FALSE)\n }\n if (length(all_cs)) {\n write.csv(do.call(rbind, all_cs), file.path(cfg$output_dir, \"cs_metrics.csv\"),\n row.names = FALSE)\n }\n write.csv(aggregate_metrics(metrics_so_far),\n file.path(cfg$output_dir, \"aggregate_summary.csv\"),\n row.names = FALSE)\n print_progress_line(metrics_so_far, rep_i, cfg)\n }\n\n final_metrics <- do.call(rbind, all_metrics)\n final <- list(\n config = cfg,\n metrics = final_metrics,\n lambda = if (length(all_lambda)) do.call(rbind, all_lambda) else data.frame(),\n cs = if (length(all_cs)) do.call(rbind, all_cs) else data.frame(),\n metadata = do.call(rbind, all_meta),\n aggregate = aggregate_metrics(final_metrics),\n compact_fits = compact_fits\n )\n saveRDS(final, file.path(cfg$output_dir, \"all_results.rds\"))\n write_json(list(\n completed_at = as.character(Sys.time()),\n output_dir = normalizePath(cfg$output_dir, mustWork = FALSE),\n n_reps_requested = cfg$n_reps,\n n_reps_completed = length(chosen),\n files = c(\"AI_PARSE_ME.md\", \"run_config.json\", \"genotype_file_index.csv\",\n \"replicate_metadata.csv\", \"per_fit_metrics.csv\",\n \"per_effect_lambda.csv\", \"cs_metrics.csv\",\n \"aggregate_summary.csv\", \"all_results.rds\")\n ), file.path(cfg$output_dir, \"manifest.json\"))\n vlog(\"Done. Results written to: \", cfg$output_dir)\n}\n\nmain()\n" }, { "path": "inst/code/small_sim.R", "content": "# Small script to evaluate the NIG prior version of SuSiE in\n# simulated data sets.\nlibrary(matrixStats)\nlibrary(susieR)\nsusie_version <- packageVersion(\"susieR\")\noutfile <- paste0(\"small_sim_out_v\",susie_version,\".RData\")\nprint(outfile)\nN <- 250\nn <- 40\ngeno <- readRDS(\"../datafiles/Thyroid.FMO2.1Mb.RDS\")$X\nstorage.mode(geno) <- \"double\"\n\ncausal_snps <- vector(\"list\",N)\nres_susie <- vector(\"list\",N)\nres_susie_small <- vector(\"list\",N)\nruntimes <- data.frame(susie = rep(0,N),\n susie_small = rep(0,N))\nfor (iter in 1:N) {\n cat(iter,\"\")\n set.seed(iter)\n\n # Subsample the genotypes.\n i <- sample(nrow(geno),n)\n X <- geno[i,]\n\n # Remove SNPs that show no variation in the subset.\n j <- which(colSds(X) > 0)\n X <- X[,j]\n\n # Simulate b and y.\n p <- ncol(X)\n b <- rep(0,p)\n names(b) <- colnames(X)\n p1 <- sample(3,1)\n j <- sample(p,p1)\n b[j] <- sample(c(-1,1),p1,replace = TRUE)\n e <- rnorm(n,sd = 0.1)\n y <- drop(X %*% b + e)\n y <- y/sd(y)\n causal_snps[[iter]] <- j\n\n # Run susie with normal prior.\n t0 <- proc.time()\n fit1 <- suppressMessages(\n susie(X,y,L = 10,standardize = FALSE,min_abs_corr = 0.5,\n estimate_prior_method = \"EM\",verbose = FALSE))\n t1 <- proc.time()\n res_susie[[iter]] <- fit1[c(\"V\",\"sets\")]\n runtimes[iter,\"susie\"] <- (t1 - t0)[\"elapsed\"]\n\n # Run susie with NIG prior. \n t0 <- proc.time()\n fit2 <- suppressMessages(\n susie(X,y,L = 10,standardize = FALSE,min_abs_corr = 0.5,\n estimate_residual_method = \"NIG\",\n estimate_prior_method = \"EM\",alpha0 = 0.1,beta0 = 0.1,\n verbose = FALSE))\n t1 <- proc.time()\n res_susie_small[[iter]] <- fit2[c(\"V\",\"sets\")]\n runtimes[iter,\"susie_small\"] <- (t1 - t0)[\"elapsed\"]\n}\ncat(\"\\n\")\n\n# Save the results.\nsave(list = c(\"n\",\"susie_version\",\"causal_snps\",\"res_susie\",\n \"res_susie_small\",\"runtimes\"),\n file = outfile)\n" }, { "path": "inst/code/sparse_matrix_strategy.Rmd", "content": "---\ntitle: \"Sparse matrix multiplication strategy\"\nauthor: \"Kaiqian Zhang\"\ndate: \"`r Sys.Date()`\"\noutput: rmarkdown::html_vignette\nvignette: >\n %\\VignetteIndexEntry{Sparse vs. dense matrix operations}\n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{UTF-8}\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(collapse = TRUE,comment = \"#\",fig.width = 4.5,\n fig.height = 3,fig.align = \"center\",\n fig.cap = \" \",dpi = 120)\n```\n\n## Set up environment\n\n```{r, warning=FALSE, message=FALSE}\nlibrary(susieR)\nlibrary(Matrix)\nlibrary(microbenchmark)\nlibrary(ggplot2)\nset.seed(1)\n```\n\n## Goal\n\nOur intention is to use sparse matrix multiplications to help\nreduce computation time.\n\n## General strategy\n\nGiven a large sparse matrix `X`, we want to compute some matrix\nmultiplications associated with a scaled $\\tilde{X}$. We notice\nthat after scaling, `X` becomes a dense matrix and is not possible for\na sparse matrix multiplication. So we construct formulae to apply\nsparse matrix multiplication first on a standardized `X` since\nstandardization does not affect its sparsity. Then we perform\ncentering to get the same result.\n\n## Types of matrix multiplications\n\nThere are two types of matrix multiplications we want to investigate:\n\n+ Compute $\\tilde{X}b$, where $\\tilde{X}$ is an n by p scaled matrix\n and $b$ is a p vector.\n\n+ Compute $\\tilde{X}^Ty$, where $\\tilde{X}$ is an n by p scaled matrix\n and $y$ is an n vector.\n\n## Results\n\nThis strategy has a decent performance when computing both\n$\\tilde{X}b$ and $\\tilde{X}^Ty$, compared to simple matrix\nmultiplication `%*%`.\n\n## Strategy formulae details\n\n### Computing $\\boldsymbol{\\tilde{X}b}$\n\nSuppose we want to compute $\\tilde{X}b$, where $\\tilde{X}$ is a scaled\nn by p matrix and $b$ is a p vector. Our goal is to express\n$\\tilde{X}b$ into a term involving unscaled $X$ matrix multiplication\nto achieve sparse matrix operation.\n\n\\begin{equation}\n\\begin{aligned}\n\\tilde{X}b\n&= \\sum_{j=1}^{p} \\tilde{X}_{\\cdot j} b_j \\\\\n&= \\sum_{j=1}^{p} \\frac{X_{\\cdot j}-\\mu_j}{\\sigma_j}b_j \\\\\n&= \\sum_{j=1}^{p}\\frac{X_{\\cdot j}}{\\sigma_j}b_j -\n \\sum_{j=1}^{p} \\frac{\\mu_j}{\\sigma_j}b_j \\\\\n&= X b / \\sigma - \\mu^Tb/\\sigma,\n\\end{aligned}\n\\end{equation}\n\nwhere $\\mu$ is a *p*-vector of column means, and $\\sigma$ is a\n*p*-vector of column standard deviations.\n\n### Computing $\\boldsymbol{\\tilde{X}^Ty}$\n\nSuppose we want to compute $\\tilde{X}^Ty$, where $\\tilde{X}$ is a\nscaled n by p matrix and $y$ is an n vector. Similarly, we express\n$\\tilde{X}^Ty$ using unscaled $X$ so that we can perform sparse matrix\nmultiplication. We have the following:\n\n\\begin{equation}\n\\begin{aligned}\n\\tilde{X}^Ty &= \\sum_{i=1}^{n} \\tilde{X}_{i.}y_i \\\\\n&= \\sum_{i=1}^{n} \\frac{X_{i.} - \\mu}{\\sigma}y_i \\\\\n&= \\frac{1}{\\sigma}\\sum_{i=1}^{n}X_{i.}y_i -\n \\frac{\\mu}{\\sigma}\\sum_{i=1}^{n} y_i \\\\\n&= \\frac{1}{\\sigma}(X^Ty) - \\frac{\\mu}{\\sigma}y^T 1,\n\\end{aligned}\n\\end{equation}\n\nwhere $\\mu$ is a *p*-vector of column means, and $\\sigma$ is a\n*p*-vector of columnwise standard deviations.\n\n## Simulations\n\nWe simulate an `n = 1000` by `p = 10000` matrix `X` at sparsity\n$99\\%$, i.e. $99\\%$ entries are zeros. We compare results between\nnormal matrix computation and our sparse strategy as well as comparing\nspeed using microbenchmark.\n\n```{r}\ncreate_sparsity_mat <- function(sparsity, n, p) {\n nonzero <- round(n*p*(1-sparsity))\n nonzero.idx <- sample(n*p, nonzero)\n mat <- numeric(n*p)\n mat[nonzero.idx] <- 1\n mat <- matrix(mat, nrow=n,ncol=p)\n return(mat)\n}\nn <- 1000\np <- 10000\n```\n\n```{r}\nX.dense <- create_sparsity_mat(0.99,n,p)\nX.sparse <- as(X.dense,\"sparseMatrix\")\nX.tilde <- susieR:::set_X_attributes(X.dense) #returns a scaled X if input is a dense matrix\nX <- susieR:::set_X_attributes(X.sparse) #return an unsacled sparse X if input is a sparse matrix \n #but computes column means and standard deviations\n```\n\n```{r}\nb <- rnorm(p)\ny <- rnorm(n)\n```\n\n### Benchmark for computing $\\boldsymbol{\\tilde{X}b}$\n\nThe final results of two methods when computing $\\tilde{X}b$ are very\nclose.\n\n```{r}\nres1 <- X.tilde %*% b\nres2 <- susieR:::compute_Xb(X,b)\nmax(abs(res1 - res2))\n```\n\n```{r}\ncompute_Xb_benchmark <- microbenchmark(\n dense = (use.normal.Xb <- X.tilde%*%b),\n sparse = (use.sparse.Xb <- susieR:::compute_Xb(X,b)),\n times = 20,unit = \"s\")\n```\n\nOur sparse strategy demonstrates an obvious advantage over the normal\nmatrix multiplication in computing $\\tilde{X}b$.\n\n```{r}\nautoplot(compute_Xb_benchmark)\n```\n\n### Benchmark for computing $\\boldsymbol{\\tilde{X}^Ty}$\n\nThe final results of two methods when computing $\\tilde{X}^Ty$ are\nalmost the same.\n\n```{r}\nres3 <- t(X.tilde) %*% y\nres4 <- susieR:::compute_Xty(X,y)\nmax(abs(res3 - res4))\n```\n\n```{r}\ncompute_Xty_benchmark = microbenchmark(\n dense = (use.normal.Xty <- t(X.tilde)%*%y),\n sparse = (use.sparse.Xty <- susieR:::compute_Xty(X, y)),\n times = 20,unit = \"s\")\n```\n\nOur sparse strategy evidently has a better performance than the normal\nmethod in computing $\\tilde{X}^Ty$.\n\n```{r}\nautoplot(compute_Xty_benchmark)\n```\n\n" }, { "path": "inst/code/summarize_small_sim.R", "content": "# Script to summarize the results of running small_sim.R.\nlibrary(ggplot2)\nlibrary(cowplot)\nload(\"../datafiles/small_sim_out_v0.14.48.RData\")\nruntimes <- data.frame(susie = runtimes$susie,\n susie_ss = runtimes$susie_small)\nmethods <- c(\"susie\",\"susie_ss\")\n\n# Summarize coverage, power and running times.\nN <- length(causal_snps)\npower <- c(0,0)\ncoverage <- c(0,0)\nnames(power) <- methods\nnames(coverage) <- methods\nV1_true <- NULL\nV2_true <- NULL\nV1_false <- NULL\nV2_false <- NULL\nfor (i in 1:N) {\n get_tp <- function (cs) {\n if (length(cs) == 0)\n return(NULL)\n else\n return(names(which(sapply(cs, \n function (x) length(intersect(causal_snps[[i]],x))>0))))\n }\n V1 <- res_susie[[i]]$V\n V2 <- res_susie_small[[i]]$V\n all_cs <- paste0(\"L\",1:10)\n names(V1) <- all_cs\n names(V2) <- all_cs\n x1 <- get_tp(res_susie[[i]]$sets$cs)\n x2 <- get_tp(res_susie_small[[i]]$sets$cs)\n V1_true <- c(V1_true,V1[x1])\n V2_true <- c(V2_true,V2[x2])\n V1_false <- c(V1_false,V1[setdiff(all_cs,x1)])\n V2_false <- c(V2_false,V2[setdiff(all_cs,x2)])\n power[\"susie\"] <- power[\"susie\"] + length(x1)\n power[\"susie_ss\"] <- power[\"susie_ss\"] + length(x2)\n coverage[\"susie\"] <- coverage[\"susie\"] + length(x1)\n coverage[\"susie_ss\"] <- coverage[\"susie_ss\"] + length(x2)\n}\n\nnum_causal <- sum(sapply(causal_snps,length))\nnum_susie <- sum(sapply(res_susie,function (x) length(x$sets$cs)))\nnum_susie_ss <- sum(sapply(res_susie_small,function (x) length(x$sets$cs)))\npower <- power / num_causal\ncoverage[\"susie\"] <- coverage[\"susie\"] / num_susie\ncoverage[\"susie_ss\"] <- coverage[\"susie_ss\"] / num_susie_ss\ncat(\"power:\\n\")\nprint(power)\ncat(\"coverage:\\n\")\nprint(coverage)\ncat(\"running times:\\n\")\nprint(summary(runtimes))\n\n# Summarize the CS sizes.\nget_cs_sizes <- function (res)\n unlist(lapply(res,function (x) sapply(x$sets$cs,length)))\nsizes_susie <- get_cs_sizes(res_susie)\nsizes_susie_ss <- get_cs_sizes(res_susie_small)\ncat(\"median CS size:\\n\")\ncat(\"susie =\",median(sizes_susie),\"\\n\")\ncat(\"susie_ss =\",median(sizes_susie_ss),\"\\n\")\npdat <- rbind(data.frame(method = \"susie\", size = sizes_susie),\n data.frame(method = \"susie_ss\",size = sizes_susie_ss))\npdat <- subset(pdat,size <= 50)\np1 <- ggplot(pdat,aes(x = size,fill = method)) +\n geom_histogram(color = \"white\",position = \"dodge\",bins = 16) +\n scale_fill_manual(values = c(\"darkblue\",\"dodgerblue\",\"darkorange\")) +\n labs(x = \"CS size\",y = \"number of CSs\",fill = \"\") +\n theme_cowplot(font_size = 10) +\n theme(legend.position = \"bottom\",\n legend.direction = \"vertical\")\nggsave(\"small_sim_sizes.pdf\",p1,height = 3,width = 3)\n\n# Summarize the prior variances.\npdat <- rbind(data.frame(method = \"susie\", causal = TRUE, V = V1_true),\n data.frame(method = \"susie\", causal = FALSE,V = V1_false),\n data.frame(method = \"susie_ss\",causal = TRUE, V = V2_true),\n data.frame(method = \"susie_ss\",causal = FALSE,V = V2_false))\npdat <- transform(pdat,sigma = sqrt(V))\npdat <- subset(pdat,sigma < 2)\np2 <- ggplot(pdat,aes(x = sigma,color = causal,fill = causal)) +\n facet_grid(rows = vars(method),scales = \"free_y\") +\n geom_histogram(bins = 24,position = \"dodge\",linewidth = 0.05) +\n scale_color_manual(values = c(\"darkblue\",\"orangered\")) +\n scale_fill_manual(values = c(\"darkblue\",\"orangered\")) +\n labs(x = \"prior s.d.\") +\n theme_cowplot(font_size = 10)\nggsave(\"small_sim_V.pdf\",p2,height = 3.5,width = 3)\n" }, { "path": "inst/code/susie_memory.R", "content": "# export MEM_CHECK_INTERVAL=0.01\n# python3 monitor_memory.py Rscript susie_memory.R\n#\n# NOTES:\n#\n# - Without any improvements:\n# Size of X: 1 GB\n# max rss_memory: 4.70 GB\n#\n# - With the improvements:\n# Size of X: 1 GB\n# max rss_memory: 3.00 GB\n#\n# set.seed(1)\n# p <- 16000\n# n <- 8000\n# X <- matrix(rnorm(n*p),n,p)\n# X <- scale(X,center = TRUE,scale = TRUE)\n# y <- rnorm(n)\n# save(list = c(\"X\",\"y\"),file = \"susie_data.RData\")\n# library(susieR)\ndevtools::load_all()\nload(\"susie_data.RData\")\ncat(\"Size of X:\\n\")\nprint(object.size(X),unit = \"GB\")\ncat(\"Running susie.\\n\")\nset.seed(1)\nout <- susie(X,y,estimate_prior_variance = FALSE,min_abs_corr = 0,\n verbose = TRUE)\nprint(sapply(out$sets$cs,length))\n" }, { "path": "inst/code/susie_rss_memory.R", "content": "# export MEM_CHECK_INTERVAL=0.01\n# python3 monitor_memory.py Rscript susie_rss_memory.R\n#\n# NOTES:\n#\n# - Without any improvements:\n# Size of X: 0.5 GB\n# max rss_memory: 4.15 GB\n#\n# - With some improvements, the initial steps right before the main\n# loop use 0.86 GB.\n#\n# - susie_rss right before the CS and PIP calculations uses 1.6 GB.\n#\n# library(susieR)\ndevtools::load_all()\n# set.seed(1)\n# p <- 8000\n# n <- 1000\n# X <- matrix(rnorm(n*p),n,p)\n# y <- rnorm(n)\n# ss <- susieR:::univariate_regression(X,y)\n# z <- ss$betahat/ss$sebetahat\n# R <- cor(X)\n# save(list = c(\"X\",\"y\",\"z\",\"R\"),file = \"susie_rss_data.RData\")\nload(\"susie_rss_data.RData\")\ncat(\"Size of R:\\n\")\nprint(object.size(R),unit = \"GB\")\ncat(\"Running susie_rss.\\n\")\nset.seed(1)\nout <- susie_rss(z,R,estimate_prior_variance = FALSE,min_abs_corr = 0,\n check_input = FALSE,refine = FALSE,verbose = TRUE)\nprint(sapply(out$sets$cs,length))\n" }, { "path": "inst/misc/README_susie_v2.md", "content": "# susieR 2.0 Architecture\n\n## Overview\n\nsusieR 2.0 implements a unified architecture incorporating various extensions to the Sum of Single Effects model for Bayesian variable selection regression. \nThe package supports multiple data types (individual-level, sufficient statistics, regression summary statistics) through a single algorithmic pipeline using S3 method dispatch.\n\n## Architecture Diagram\n\n```\nInterface → Constructor → Workhorse → IBSS Core → Backend Methods\n ↓ ↓\n (data, params) → model\n```\n\n## Core Object Definitions\n\nThe architecture revolves around three key objects:\n\n### **Data Object**\n- **Purpose**: Contains input data in processed, algorithm-ready form\n- **S3 Classes**: `individual`, `ss`, `rss_lambda` (determines method dispatch)\n- **Mutability**: Immutable - never modified after creation\n- **Contents**: \n - Input matrices: X/y (individual), XtX/Xty/yty (ss), z/R (rss_lambda)\n - Metadata: n, p\n - Scaling attributes: For compute_Xb() compatibility\n - Specialized fields: Eigen decomposition for unmappable effects/rss_lambda\n\n\n### **Params Object**\n- **Purpose**: Contains ALL algorithm parameters and user settings\n- **Mutability**: Immutable - never modified after validation\n- **Contents**:\n - Algorithm parameters: L, max_iter, tol, convergence_method\n - Estimation settings: estimate_prior_method, estimate_residual_method\n - Model options: unmappable_effects, refine, standardize, intercept\n\n### **Model Object**\n- **Purpose**: Contains fitted SuSiE model state, results, and algorithm outputs\n- **Mutability**: Mutable - updated throughout fitting process\n- **Contents**:\n - Model matrices: alpha, mu, mu2, V, sigma2\n - Fitted values: Xr (individual), XtXr (ss), Rz (rss_lambda)\n - Algorithm outputs: ELBO, niter, converged\n - Final results: credible sets, PIPs, intercept, z-scores\n\n## Constructor Pattern\n\n### **Constructor Workflow**:\n1. **Interface functions** (`susie()`, `susie_ss()`, and `susie_rss()`) take user inputs and call constructors functions\n2. **Constructors** create validated (data, params) objects\n3. **Workhorse** Validated (data, params) objects are directly forwarded to the workhorse function for the main SuSiE algorithm\n\n### **Constructor Functions** (`susie_constructors.R`):\n- `individual_data_constructor()` → Processes X, y matrices → (data, params)\n- `sufficient_stats_constructor()`→ Processes XtX, Xty, yty → (data, params) \n- `summary_stats_constructor()`: Routes RSS inputs based on lambda parameter\n - If `lambda = 0` → Converts RSS data to SS → `sufficient_stats_constructor()` → (data, params)\n - If `lambda > 0` → `rss_lambda_constructor()`→ Processes z, R for regularized LD → (data, params)\n\n### **Data Type Support**:\n\nEach data object receives an S3 class to automatically route to the appropriate backend function based on the data object's S3 class.\n\n- **`individual`**: Individual-level data (X, y matrices)\n- **`ss`**: Sufficient statistics (XtX, Xty, yty, n)\n- **`rss_lambda`**: RSS with regularized LD matrix (z, R, lambda > 0)\n\n## Model Components\n\n### Core Algorithm Files:\n\n1. **`susie_workhorse.R`**: Main orchestration layer\n - Manages the complete fitting pipeline: initialize → iterate → finalize\n - Coordinates variance component updates\n - Handles convergence checking based on specified method\n - Tracks fit history when `track_fit=TRUE`\n\n2. **`iterative_bayesian_stepwise_selection.R`**: IBSS algorithm\n - `ibss_initialize()`: Creates initial model state with L effects\n - `ibss_fit()`: Main iteration loop that updates each effect sequentially\n - `ibss_finalize()`: Post-processing to compute credible sets and PIPs\n\n3. **`single_effect_regression.R`**: Single Effect Regression (SER) implementation\n - `single_effect_regression()`: Fits one sparse effect at a time\n - `optimize_prior_variance()`: Optimizes the prior variance for the lth effect\n - `single_effect_update()`: Implements the complete SER update pipeline\n\n## Backend Method Implementations\n\nEach data type has a corresponding backend file implementing the S3 methods defined in `generic_methods.R`:\n\n- `individual_data_methods.R` - Methods for class `individual`\n- `sufficient_stats_methods.R` - Methods for class `ss`\n- `rss_lambda_methods.R` - Methods for class `rss_lambda`\n\nThe backend system allows the same high-level algorithm to work with different data representations through S3 method dispatch. Each backend file contains a 1:1 correspondence with the generic methods, implementing data-specific computations.\n\n## Utility Functions\n\n- **`susie_utils.R`**: Internal utility functions organized by:\n - **Fundamental Building Blocks** (general purpose-helpers, matrix operations)\n - **Data Processing & Validation** (input validation, data conversion)\n - **Model Initialization** (set up model state)\n - **Core Algorithm Components** (posterior mean calculation, lbf calculation)\n - **Variance Esimation** (residual variance and unmappable effects variance esimation)\n - **Convergence & Optimization** (Convergence checking, ELBO computation)\n - **Credible Sets & Post-processing** (Generate credible sets, pips)\n\n- **`susie_rss_utils.R`**: Internal utility functions specific to RSS data with lambda > 0, organized by:\n - **Fundamental Computations** (core RSS computations)\n - **RSS Model Methods** (lambda estimation, precomputations)\n - **Diagnostic & Quality Control** (detect allele switch)\n\n- **`susie_get_functions.R`**: Exported accessor functions for extracting results:\n - `susie_get_cs()`: Extract credible sets\n - `susie_get_pip()`: Extract posterior inclusion probabilities\n - Other accessor functions for model components\n" }, { "path": "inst/misc/format_r_code.sh", "content": "#!/bin/bash\n\n# Function to display error messages and exit the script\ndisplay_error() {\n echo \"Error: $1\"\n exit 1\n}\n\n# Check if the R file is provided as an argument\nif [ $# -eq 0 ]; then\n display_error \"Please provide the path to the R file as an argument.\"\nfi\n\n# Get the R file path from the argument\nr_file=\"$1\"\n\n# Check if the R file exists\nif [ ! -f \"$r_file\" ]; then\n display_error \"The specified R file '$r_file' does not exist.\"\nfi\n\necho \"Formatting R code in file: $r_file\"\n\n# Format the R code using formatR and capture the output\n# output=$(echo \"library(formatR); tryCatch(tidy_source(\\\"$r_file\\\", file = \\\"$r_file\\\", indent = 2, args.newline = TRUE, arrow = TRUE), error = function(e) {message(\\\"Error formatting R code:\\\"); print(e)})\" | R --slave --no-save 2>&1)\n# Format the R code using styler and capture the output\noutput=$(echo \"tryCatch(styler::style_file(\\\"$r_file\\\"), error = function(e) {message(\\\"Error formatting R code:\\\"); print(e)})\" | R --slave --no-save 2>&1)\n\n# Check if the formatting was successful\nif echo \"$output\" | grep -q \"Error formatting R code:\"; then\n echo \"Formatting failed. Please check the R code for syntax errors.\"\n echo -e \"\\033[0;31m$(echo \"$output\" | head -n -3)\\033[0m\"\n echo -e \"\\033[1;31m$(echo \"$output\" | tail -n 3)\\033[0m\"\n exit 1\nelse\n echo \"R code formatting completed successfully.\"\nfi" }, { "path": "inst/misc/post-commit.sh", "content": "#!/bin/bash\n#\n# This script will be executed every time you run \"git commit\". It\n# will commit changes made to package DESCRIPTION by the pre-commit hook\n#\n# To use this script, copy it to the .git/hooks directory of your\n# local repository to filename `post-commit`, and make it executable.\n#\nROOT_DIR=`git rev-parse --show-toplevel`\n# Only commit DESCRIPTION file when it is not staged (due to changes by pre-commit hook)\nif [[ -z `git diff HEAD` ]] || [[ ! -f $ROOT_DIR/DESCRIPTION ]] || [[ -z `git diff $ROOT_DIR/DESCRIPTION` ]]; then\n exit 0\nelse\n git add $ROOT_DIR/DESCRIPTION\n git commit --amend -C HEAD --no-verify\n echo \"Amend current commit to incorporate version bump\"\n exit 0\nfi\n" }, { "path": "inst/misc/pre-commit.sh", "content": "#!/bin/bash\n#\n# This script will be executed every time you run \"git commit\". It\n# will update the 4th digit of package version by revision number.\n#\n# To use this script, copy it to the .git/hooks directory of your\n# local repository to filename `pre-commit`, and make it executable.\n#\nROOT_DIR=`git rev-parse --show-toplevel`\nMSG=\"[WARNING] Auto-versioning disabled because string 'Version: x.y.z.r' cannot be found in DESCRIPTION file.\"\nGREP_REGEX='^Version: [0-9]*\\.[0-9]*\\.[0-9]*\\.[0-9]*'\nSED_REGEX='^Version: \\([0-9]*\\.[0-9]*\\.[0-9]*\\)\\.[0-9]*'\n# `git diff HEAD` shows both staged and unstaged changes\nif [[ -z `git diff HEAD` ]] || [[ ! -f $ROOT_DIR/DESCRIPTION ]]; then\n exit 0\nelif [[ -z `grep \"$GREP_REGEX\" $ROOT_DIR/DESCRIPTION` ]]; then\n echo -e \"\\e[1;31m$MSG\\e[0m\"\n exit 0\nelse\n REV_ID=`git log --oneline | wc -l`\n REV_ID=`printf \"%04d\\n\" $((REV_ID+1))`\n DATE=`date +%Y-%m-%d`\n echo \"Version string bumped to revision $REV_ID on $DATE\"\n sed -i \"s/$SED_REGEX/Version: \\1.$REV_ID/\" $ROOT_DIR/DESCRIPTION\n sed -i \"s/^Date: .*/Date: $DATE/\" $ROOT_DIR/DESCRIPTION\n if [[ `git rev-parse --abbrev-ref HEAD` -eq \"master\" ]]; then\n cd $ROOT_DIR\n echo \"Updating documentation ...\"\n R --slave -e 'devtools::document()' &> /dev/null && git add man/*.Rd\n echo \"Documentation updated!\"\n echo \"Running unit tests ...\"\n R --slave -e 'devtools::test()'\n echo \"Unit test completed!\"\n fi\n exit 0\nfi\n" }, { "path": "inst/misc/uncrustify_default.cfg", "content": "# Downloaded from https://raw.githubusercontent.com/uncrustify/uncrustify/refs/heads/master/documentation/htdocs/default.cfg\n# By Gao Wang on Jan 17, 2025\n# with modifications to `align_func_params_span`\n# usage: uncrustify -c /path/to/mashr/inst/misc/uncrustify_default.cfg --replace --no-backup -l CPP $f\n\n# Uncrustify-0.80.1\n\n#\n# General options\n#\n\n# The type of line endings.\n#\n# Default: auto\nnewlines = auto # lf/crlf/cr/auto\n\n# The original size of tabs in the input.\n#\n# Default: 8\ninput_tab_size = 8 # unsigned number\n\n# The size of tabs in the output (only used if align_with_tabs=true).\n#\n# Default: 8\noutput_tab_size = 8 # unsigned number\n\n# The ASCII value of the string escape char, usually 92 (\\) or (Pawn) 94 (^).\n#\n# Default: 92\nstring_escape_char = 92 # unsigned number\n\n# Alternate string escape char (usually only used for Pawn).\n# Only works right before the quote char.\nstring_escape_char2 = 0 # unsigned number\n\n# Replace tab characters found in string literals with the escape sequence \\t\n# instead.\nstring_replace_tab_chars = false # true/false\n\n# Allow interpreting '>=' and '>>=' as part of a template in code like\n# 'void f(list>=val);'. If true, 'assert(x<0 && y>=3)' will be broken.\n# Improvements to template detection may make this option obsolete.\ntok_split_gte = false # true/false\n\n# Disable formatting of NL_CONT ('\\\\n') ended lines (e.g. multi-line macros).\ndisable_processing_nl_cont = false # true/false\n\n# Specify the marker used in comments to disable processing of part of the\n# file.\n#\n# Default: *INDENT-OFF*\ndisable_processing_cmt = \" *INDENT-OFF*\" # string\n\n# Specify the marker used in comments to (re)enable processing in a file.\n#\n# Default: *INDENT-ON*\nenable_processing_cmt = \" *INDENT-ON*\" # string\n\n# Enable parsing of digraphs.\nenable_digraphs = false # true/false\n\n# Option to allow both disable_processing_cmt and enable_processing_cmt\n# strings, if specified, to be interpreted as ECMAScript regular expressions.\n# If true, a regex search will be performed within comments according to the\n# specified patterns in order to disable/enable processing.\nprocessing_cmt_as_regex = false # true/false\n\n# Add or remove the UTF-8 BOM (recommend 'remove').\nutf8_bom = ignore # ignore/add/remove/force\n\n# If the file contains bytes with values between 128 and 255, but is not\n# UTF-8, then output as UTF-8.\nutf8_byte = false # true/false\n\n# Force the output encoding to UTF-8.\nutf8_force = false # true/false\n\n#\n# Spacing options\n#\n\n# Add or remove space around non-assignment symbolic operators ('+', '/', '%',\n# '<<', and so forth).\nsp_arith = ignore # ignore/add/remove/force\n\n# Add or remove space around arithmetic operators '+' and '-'.\n#\n# Overrides sp_arith.\nsp_arith_additive = ignore # ignore/add/remove/force\n\n# Add or remove space around assignment operator '=', '+=', etc.\nsp_assign = ignore # ignore/add/remove/force\n\n# Add or remove space around '=' in C++11 lambda capture specifications.\n#\n# Overrides sp_assign.\nsp_cpp_lambda_assign = ignore # ignore/add/remove/force\n\n# Add or remove space after the capture specification of a C++11 lambda when\n# an argument list is present, as in '[] (int x){ ... }'.\nsp_cpp_lambda_square_paren = ignore # ignore/add/remove/force\n\n# Add or remove space after the capture specification of a C++11 lambda with\n# no argument list is present, as in '[] { ... }'.\nsp_cpp_lambda_square_brace = ignore # ignore/add/remove/force\n\n# Add or remove space after the opening parenthesis and before the closing\n# parenthesis of a argument list of a C++11 lambda, as in\n# '[]( ){ ... }'\n# with an empty list.\nsp_cpp_lambda_argument_list_empty = ignore # ignore/add/remove/force\n\n# Add or remove space after the opening parenthesis and before the closing\n# parenthesis of a argument list of a C++11 lambda, as in\n# '[]( int x ){ ... }'.\nsp_cpp_lambda_argument_list = ignore # ignore/add/remove/force\n\n# Add or remove space after the argument list of a C++11 lambda, as in\n# '[](int x) { ... }'.\nsp_cpp_lambda_paren_brace = ignore # ignore/add/remove/force\n\n# Add or remove space between a lambda body and its call operator of an\n# immediately invoked lambda, as in '[]( ... ){ ... } ( ... )'.\nsp_cpp_lambda_fparen = ignore # ignore/add/remove/force\n\n# Add or remove space around assignment operator '=' in a prototype.\n#\n# If set to ignore, use sp_assign.\nsp_assign_default = ignore # ignore/add/remove/force\n\n# Add or remove space before assignment operator '=', '+=', etc.\n#\n# Overrides sp_assign.\nsp_before_assign = ignore # ignore/add/remove/force\n\n# Add or remove space after assignment operator '=', '+=', etc.\n#\n# Overrides sp_assign.\nsp_after_assign = ignore # ignore/add/remove/force\n\n# Add or remove space in 'enum {'.\n#\n# Default: add\nsp_enum_brace = add # ignore/add/remove/force\n\n# Add or remove space in 'NS_ENUM ('.\nsp_enum_paren = ignore # ignore/add/remove/force\n\n# Add or remove space around assignment '=' in enum.\nsp_enum_assign = ignore # ignore/add/remove/force\n\n# Add or remove space before assignment '=' in enum.\n#\n# Overrides sp_enum_assign.\nsp_enum_before_assign = ignore # ignore/add/remove/force\n\n# Add or remove space after assignment '=' in enum.\n#\n# Overrides sp_enum_assign.\nsp_enum_after_assign = ignore # ignore/add/remove/force\n\n# Add or remove space around assignment ':' in enum.\nsp_enum_colon = ignore # ignore/add/remove/force\n\n# Add or remove space around preprocessor '##' concatenation operator.\n#\n# Default: add\nsp_pp_concat = add # ignore/add/remove/force\n\n# Add or remove space after preprocessor '#' stringify operator.\n# Also affects the '#@' charizing operator.\nsp_pp_stringify = ignore # ignore/add/remove/force\n\n# Add or remove space before preprocessor '#' stringify operator\n# as in '#define x(y) L#y'.\nsp_before_pp_stringify = ignore # ignore/add/remove/force\n\n# Add or remove space around boolean operators '&&' and '||'.\nsp_bool = ignore # ignore/add/remove/force\n\n# Add or remove space around compare operator '<', '>', '==', etc.\nsp_compare = ignore # ignore/add/remove/force\n\n# Add or remove space inside '(' and ')'.\nsp_inside_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between nested parentheses, i.e. '((' vs. ') )'.\nsp_paren_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between back-to-back parentheses, i.e. ')(' vs. ') ('.\nsp_cparen_oparen = ignore # ignore/add/remove/force\n\n# Add or remove space between ')' and '{'.\nsp_paren_brace = ignore # ignore/add/remove/force\n\n# Add or remove space between nested braces, i.e. '{{' vs. '{ {'.\nsp_brace_brace = ignore # ignore/add/remove/force\n\n# Add or remove space before pointer star '*'.\nsp_before_ptr_star = ignore # ignore/add/remove/force\n\n# Add or remove space before pointer star '*' that isn't followed by a\n# variable name. If set to ignore, sp_before_ptr_star is used instead.\nsp_before_unnamed_ptr_star = ignore # ignore/add/remove/force\n\n# Add or remove space before pointer star '*' that is followed by a qualifier.\n# If set to ignore, sp_before_unnamed_ptr_star is used instead.\nsp_before_qualifier_ptr_star = ignore # ignore/add/remove/force\n\n# Add or remove space before pointer star '*' that is followed by 'operator' keyword.\n# If set to ignore, sp_before_unnamed_ptr_star is used instead.\nsp_before_operator_ptr_star = ignore # ignore/add/remove/force\n\n# Add or remove space before pointer star '*' that is followed by\n# a class scope (as in 'int *MyClass::method()') or namespace scope\n# (as in 'int *my_ns::func()').\n# If set to ignore, sp_before_unnamed_ptr_star is used instead.\nsp_before_scope_ptr_star = ignore # ignore/add/remove/force\n\n# Add or remove space before pointer star '*' that is followed by '::',\n# as in 'int *::func()'.\n# If set to ignore, sp_before_unnamed_ptr_star is used instead.\nsp_before_global_scope_ptr_star = ignore # ignore/add/remove/force\n\n# Add or remove space between a qualifier and a pointer star '*' that isn't\n# followed by a variable name, as in '(char const *)'. If set to ignore,\n# sp_before_ptr_star is used instead.\nsp_qualifier_unnamed_ptr_star = ignore # ignore/add/remove/force\n\n# Add or remove space between pointer stars '*', as in 'int ***a;'.\nsp_between_ptr_star = ignore # ignore/add/remove/force\n\n# Add or remove space between pointer star '*' and reference '&', as in 'int *& a;'.\nsp_between_ptr_ref = ignore # ignore/add/remove/force\n\n# Add or remove space after pointer star '*', if followed by a word.\n#\n# Overrides sp_type_func.\nsp_after_ptr_star = ignore # ignore/add/remove/force\n\n# Add or remove space after pointer caret '^', if followed by a word.\nsp_after_ptr_block_caret = ignore # ignore/add/remove/force\n\n# Add or remove space after pointer star '*', if followed by a qualifier.\nsp_after_ptr_star_qualifier = ignore # ignore/add/remove/force\n\n# Add or remove space after a pointer star '*', if followed by a function\n# prototype or function definition.\n#\n# Overrides sp_after_ptr_star and sp_type_func.\nsp_after_ptr_star_func = ignore # ignore/add/remove/force\n\n# Add or remove space after a pointer star '*' in the trailing return of a\n# function prototype or function definition.\nsp_after_ptr_star_trailing = ignore # ignore/add/remove/force\n\n# Add or remove space between the pointer star '*' and the name of the variable\n# in a function pointer definition.\nsp_ptr_star_func_var = ignore # ignore/add/remove/force\n\n# Add or remove space between the pointer star '*' and the name of the type\n# in a function pointer type definition.\nsp_ptr_star_func_type = ignore # ignore/add/remove/force\n\n# Add or remove space after a pointer star '*', if followed by an open\n# parenthesis, as in 'void* (*)()'.\nsp_ptr_star_paren = ignore # ignore/add/remove/force\n\n# Add or remove space before a pointer star '*', if followed by a function\n# prototype or function definition. If set to ignore, sp_before_ptr_star is\n# used instead.\nsp_before_ptr_star_func = ignore # ignore/add/remove/force\n\n# Add or remove space between a qualifier and a pointer star '*' followed by\n# the name of the function in a function prototype or definition, as in\n# 'char const *foo()`. If set to ignore, sp_before_ptr_star is used instead.\nsp_qualifier_ptr_star_func = ignore # ignore/add/remove/force\n\n# Add or remove space before a pointer star '*' in the trailing return of a\n# function prototype or function definition.\nsp_before_ptr_star_trailing = ignore # ignore/add/remove/force\n\n# Add or remove space between a qualifier and a pointer star '*' in the\n# trailing return of a function prototype or function definition, as in\n# 'auto foo() -> char const *'.\nsp_qualifier_ptr_star_trailing = ignore # ignore/add/remove/force\n\n# Add or remove space before a reference sign '&'.\nsp_before_byref = ignore # ignore/add/remove/force\n\n# Add or remove space before a reference sign '&' that isn't followed by a\n# variable name. If set to ignore, sp_before_byref is used instead.\nsp_before_unnamed_byref = ignore # ignore/add/remove/force\n\n# Add or remove space after reference sign '&', if followed by a word.\n#\n# Overrides sp_type_func.\nsp_after_byref = ignore # ignore/add/remove/force\n\n# Add or remove space after a reference sign '&', if followed by a function\n# prototype or function definition.\n#\n# Overrides sp_after_byref and sp_type_func.\nsp_after_byref_func = ignore # ignore/add/remove/force\n\n# Add or remove space before a reference sign '&', if followed by a function\n# prototype or function definition.\nsp_before_byref_func = ignore # ignore/add/remove/force\n\n# Add or remove space after a reference sign '&', if followed by an open\n# parenthesis, as in 'char& (*)()'.\nsp_byref_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between type and word. In cases where total removal of\n# whitespace would be a syntax error, a value of 'remove' is treated the same\n# as 'force'.\n#\n# This also affects some other instances of space following a type that are\n# not covered by other options; for example, between the return type and\n# parenthesis of a function type template argument, between the type and\n# parenthesis of an array parameter, or between 'decltype(...)' and the\n# following word.\n#\n# Default: force\nsp_after_type = force # ignore/add/remove/force\n\n# Add or remove space between 'decltype(...)' and word,\n# brace or function call.\nsp_after_decltype = ignore # ignore/add/remove/force\n\n# (D) Add or remove space before the parenthesis in the D constructs\n# 'template Foo(' and 'class Foo('.\nsp_before_template_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between 'template' and '<'.\n# If set to ignore, sp_before_angle is used.\nsp_template_angle = ignore # ignore/add/remove/force\n\n# Add or remove space before '<'.\nsp_before_angle = ignore # ignore/add/remove/force\n\n# Add or remove space inside '<' and '>'.\nsp_inside_angle = ignore # ignore/add/remove/force\n\n# Add or remove space inside '<>'.\n# if empty.\nsp_inside_angle_empty = ignore # ignore/add/remove/force\n\n# Add or remove space between '>' and ':'.\nsp_angle_colon = ignore # ignore/add/remove/force\n\n# Add or remove space after '>'.\nsp_after_angle = ignore # ignore/add/remove/force\n\n# Add or remove space between '>' and '(' as found in 'new List(foo);'.\nsp_angle_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between '>' and '()' as found in 'new List();'.\nsp_angle_paren_empty = ignore # ignore/add/remove/force\n\n# Add or remove space between '>' and a word as in 'List m;' or\n# 'template static ...'.\nsp_angle_word = ignore # ignore/add/remove/force\n\n# Add or remove space between '>' and '>' in '>>' (template stuff).\n#\n# Default: add\nsp_angle_shift = add # ignore/add/remove/force\n\n# (C++11) Permit removal of the space between '>>' in 'foo >'. Note\n# that sp_angle_shift cannot remove the space without this option.\nsp_permit_cpp11_shift = false # true/false\n\n# Add or remove space before '(' of control statements ('if', 'for', 'switch',\n# 'while', etc.).\nsp_before_sparen = ignore # ignore/add/remove/force\n\n# Add or remove space inside '(' and ')' of control statements other than\n# 'for'.\nsp_inside_sparen = ignore # ignore/add/remove/force\n\n# Add or remove space after '(' of control statements other than 'for'.\n#\n# Overrides sp_inside_sparen.\nsp_inside_sparen_open = ignore # ignore/add/remove/force\n\n# Add or remove space before ')' of control statements other than 'for'.\n#\n# Overrides sp_inside_sparen.\nsp_inside_sparen_close = ignore # ignore/add/remove/force\n\n# Add or remove space inside '(' and ')' of 'for' statements.\nsp_inside_for = ignore # ignore/add/remove/force\n\n# Add or remove space after '(' of 'for' statements.\n#\n# Overrides sp_inside_for.\nsp_inside_for_open = ignore # ignore/add/remove/force\n\n# Add or remove space before ')' of 'for' statements.\n#\n# Overrides sp_inside_for.\nsp_inside_for_close = ignore # ignore/add/remove/force\n\n# Add or remove space between '((' or '))' of control statements.\nsp_sparen_paren = ignore # ignore/add/remove/force\n\n# Add or remove space after ')' of control statements.\nsp_after_sparen = ignore # ignore/add/remove/force\n\n# Add or remove space between ')' and '{' of control statements.\nsp_sparen_brace = ignore # ignore/add/remove/force\n\n# Add or remove space between 'do' and '{'.\nsp_do_brace_open = ignore # ignore/add/remove/force\n\n# Add or remove space between '}' and 'while'.\nsp_brace_close_while = ignore # ignore/add/remove/force\n\n# Add or remove space between 'while' and '('. Overrides sp_before_sparen.\nsp_while_paren_open = ignore # ignore/add/remove/force\n\n# (D) Add or remove space between 'invariant' and '('.\nsp_invariant_paren = ignore # ignore/add/remove/force\n\n# (D) Add or remove space after the ')' in 'invariant (C) c'.\nsp_after_invariant_paren = ignore # ignore/add/remove/force\n\n# Add or remove space before empty statement ';' on 'if', 'for' and 'while'.\n# examples:\n# if (b) ;\n# for (a=1; a<10; a++) ;\n# while (*p++ = ' ') ;\nsp_special_semi = ignore # ignore/add/remove/force\n\n# Add or remove space before ';'.\n#\n# Default: remove\nsp_before_semi = remove # ignore/add/remove/force\n\n# Add or remove space before ';' in non-empty 'for' statements.\nsp_before_semi_for = ignore # ignore/add/remove/force\n\n# Add or remove space before a semicolon of an empty left part of a for\n# statement, as in 'for ( ; ; )'.\nsp_before_semi_for_empty = ignore # ignore/add/remove/force\n\n# Add or remove space between the semicolons of an empty middle part of a for\n# statement, as in 'for ( ; ; )'.\nsp_between_semi_for_empty = ignore # ignore/add/remove/force\n\n# Add or remove space after ';', except when followed by a comment.\n#\n# Default: add\nsp_after_semi = add # ignore/add/remove/force\n\n# Add or remove space after ';' in non-empty 'for' statements.\n#\n# Default: force\nsp_after_semi_for = force # ignore/add/remove/force\n\n# Add or remove space after the final semicolon of an empty part of a for\n# statement, as in 'for ( ; ; )'.\nsp_after_semi_for_empty = ignore # ignore/add/remove/force\n\n# Add or remove space before '[' (except '[]').\nsp_before_square = ignore # ignore/add/remove/force\n\n# Add or remove space before '[' for a variable definition.\n#\n# Default: remove\nsp_before_vardef_square = remove # ignore/add/remove/force\n\n# Add or remove space before '[' for asm block.\nsp_before_square_asm_block = ignore # ignore/add/remove/force\n\n# Add or remove space before '[]'.\nsp_before_squares = ignore # ignore/add/remove/force\n\n# Add or remove space before C++17 structured bindings\n# after byref.\nsp_cpp_before_struct_binding_after_byref = ignore # ignore/add/remove/force\n\n# Add or remove space before C++17 structured bindings.\nsp_cpp_before_struct_binding = ignore # ignore/add/remove/force\n\n# Add or remove space inside a non-empty '[' and ']'.\nsp_inside_square = ignore # ignore/add/remove/force\n\n# Add or remove space inside '[]'.\n# if empty.\nsp_inside_square_empty = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space inside a non-empty Objective-C boxed array '@[' and\n# ']'. If set to ignore, sp_inside_square is used.\nsp_inside_square_oc_array = ignore # ignore/add/remove/force\n\n# Add or remove space after ',', i.e. 'a,b' vs. 'a, b'.\nsp_after_comma = ignore # ignore/add/remove/force\n\n# Add or remove space before ',', i.e. 'a,b' vs. 'a ,b'.\n#\n# Default: remove\nsp_before_comma = remove # ignore/add/remove/force\n\n# (C#, Vala) Add or remove space between ',' and ']' in multidimensional array type\n# like 'int[,,]'.\nsp_after_mdatype_commas = ignore # ignore/add/remove/force\n\n# (C#, Vala) Add or remove space between '[' and ',' in multidimensional array type\n# like 'int[,,]'.\nsp_before_mdatype_commas = ignore # ignore/add/remove/force\n\n# (C#, Vala) Add or remove space between ',' in multidimensional array type\n# like 'int[,,]'.\nsp_between_mdatype_commas = ignore # ignore/add/remove/force\n\n# Add or remove space between an open parenthesis and comma,\n# i.e. '(,' vs. '( ,'.\n#\n# Default: force\nsp_paren_comma = force # ignore/add/remove/force\n\n# Add or remove space between a type and ':'.\nsp_type_colon = ignore # ignore/add/remove/force\n\n# Add or remove space after the variadic '...' when preceded by a\n# non-punctuator.\n# The value REMOVE will be overridden with FORCE\nsp_after_ellipsis = ignore # ignore/add/remove/force\n\n# Add or remove space before the variadic '...' when preceded by a\n# non-punctuator.\n# The value REMOVE will be overridden with FORCE\nsp_before_ellipsis = ignore # ignore/add/remove/force\n\n# Add or remove space between a type and '...'.\nsp_type_ellipsis = ignore # ignore/add/remove/force\n\n# Add or remove space between a '*' and '...'.\nsp_ptr_type_ellipsis = ignore # ignore/add/remove/force\n\n# Add or remove space between ')' and '...'.\nsp_paren_ellipsis = ignore # ignore/add/remove/force\n\n# Add or remove space between '&&' and '...'.\nsp_byref_ellipsis = ignore # ignore/add/remove/force\n\n# Add or remove space between ')' and a qualifier such as 'const'.\nsp_paren_qualifier = ignore # ignore/add/remove/force\n\n# Add or remove space between ')' and 'noexcept'.\nsp_paren_noexcept = ignore # ignore/add/remove/force\n\n# Add or remove space after class ':'.\nsp_after_class_colon = ignore # ignore/add/remove/force\n\n# Add or remove space before class ':'.\nsp_before_class_colon = ignore # ignore/add/remove/force\n\n# Add or remove space after class constructor ':'.\n#\n# Default: add\nsp_after_constr_colon = add # ignore/add/remove/force\n\n# Add or remove space before class constructor ':'.\n#\n# Default: add\nsp_before_constr_colon = add # ignore/add/remove/force\n\n# Add or remove space before case ':'.\n#\n# Default: remove\nsp_before_case_colon = remove # ignore/add/remove/force\n\n# Add or remove space between 'operator' and operator sign.\nsp_after_operator = ignore # ignore/add/remove/force\n\n# Add or remove space between the operator symbol and the open parenthesis, as\n# in 'operator ++('.\nsp_after_operator_sym = ignore # ignore/add/remove/force\n\n# Overrides sp_after_operator_sym when the operator has no arguments, as in\n# 'operator *()'.\nsp_after_operator_sym_empty = ignore # ignore/add/remove/force\n\n# Add or remove space after C/D cast, i.e. 'cast(int)a' vs. 'cast(int) a' or\n# '(int)a' vs. '(int) a'.\nsp_after_cast = ignore # ignore/add/remove/force\n\n# Add or remove spaces inside cast parentheses.\nsp_inside_paren_cast = ignore # ignore/add/remove/force\n\n# Add or remove space between the type and open parenthesis in a C++ cast,\n# i.e. 'int(exp)' vs. 'int (exp)'.\nsp_cpp_cast_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between 'sizeof' and '('.\nsp_sizeof_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between 'sizeof' and '...'.\nsp_sizeof_ellipsis = ignore # ignore/add/remove/force\n\n# Add or remove space between 'sizeof...' and '('.\nsp_sizeof_ellipsis_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between '...' and a parameter pack.\nsp_ellipsis_parameter_pack = ignore # ignore/add/remove/force\n\n# Add or remove space between a parameter pack and '...'.\nsp_parameter_pack_ellipsis = ignore # ignore/add/remove/force\n\n# Add or remove space between 'decltype' and '('.\nsp_decltype_paren = ignore # ignore/add/remove/force\n\n# (Pawn) Add or remove space after the tag keyword.\nsp_after_tag = ignore # ignore/add/remove/force\n\n# Add or remove space inside enum '{' and '}'.\nsp_inside_braces_enum = ignore # ignore/add/remove/force\n\n# Add or remove space inside struct/union '{' and '}'.\nsp_inside_braces_struct = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space inside Objective-C boxed dictionary '{' and '}'\nsp_inside_braces_oc_dict = ignore # ignore/add/remove/force\n\n# Add or remove space after open brace in an unnamed temporary\n# direct-list-initialization\n# if statement is a brace_init_lst\n# works only if sp_brace_brace is set to ignore.\nsp_after_type_brace_init_lst_open = ignore # ignore/add/remove/force\n\n# Add or remove space before close brace in an unnamed temporary\n# direct-list-initialization\n# if statement is a brace_init_lst\n# works only if sp_brace_brace is set to ignore.\nsp_before_type_brace_init_lst_close = ignore # ignore/add/remove/force\n\n# Add or remove space inside an unnamed temporary direct-list-initialization\n# if statement is a brace_init_lst\n# works only if sp_brace_brace is set to ignore\n# works only if sp_before_type_brace_init_lst_close is set to ignore.\nsp_inside_type_brace_init_lst = ignore # ignore/add/remove/force\n\n# Add or remove space inside '{' and '}'.\nsp_inside_braces = ignore # ignore/add/remove/force\n\n# Add or remove space inside '{}'.\n# if empty.\nsp_inside_braces_empty = ignore # ignore/add/remove/force\n\n# Add or remove space around trailing return operator '->'.\nsp_trailing_return = ignore # ignore/add/remove/force\n\n# Add or remove space between return type and function name. A minimum of 1\n# is forced except for pointer return types.\nsp_type_func = ignore # ignore/add/remove/force\n\n# Add or remove space between type and open brace of an unnamed temporary\n# direct-list-initialization.\nsp_type_brace_init_lst = ignore # ignore/add/remove/force\n\n# Add or remove space between function name and '(' on function declaration.\nsp_func_proto_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between function name and '()' on function declaration\n# if empty.\nsp_func_proto_paren_empty = ignore # ignore/add/remove/force\n\n# Add or remove space between function name and '(' with a typedef specifier.\nsp_func_type_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between alias name and '(' of a non-pointer function type typedef.\nsp_func_def_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between function name and '()' on function definition\n# if empty.\nsp_func_def_paren_empty = ignore # ignore/add/remove/force\n\n# Add or remove space inside empty function '()'.\n# Overrides sp_after_angle unless use_sp_after_angle_always is set to true.\nsp_inside_fparens = ignore # ignore/add/remove/force\n\n# Add or remove space inside function '(' and ')'.\nsp_inside_fparen = ignore # ignore/add/remove/force\n\n# Add or remove space inside user functor '(' and ')'.\nsp_func_call_user_inside_rparen = ignore # ignore/add/remove/force\n\n# Add or remove space inside empty functor '()'.\n# Overrides sp_after_angle unless use_sp_after_angle_always is set to true.\nsp_inside_rparens = ignore # ignore/add/remove/force\n\n# Add or remove space inside functor '(' and ')'.\nsp_inside_rparen = ignore # ignore/add/remove/force\n\n# Add or remove space inside the first parentheses in a function type, as in\n# 'void (*x)(...)'.\nsp_inside_tparen = ignore # ignore/add/remove/force\n\n# Add or remove space between the ')' and '(' in a function type, as in\n# 'void (*x)(...)'.\nsp_after_tparen_close = ignore # ignore/add/remove/force\n\n# Add or remove space between ']' and '(' when part of a function call.\nsp_square_fparen = ignore # ignore/add/remove/force\n\n# Add or remove space between ')' and '{' of function.\nsp_fparen_brace = ignore # ignore/add/remove/force\n\n# Add or remove space between ')' and '{' of a function call in object\n# initialization.\n#\n# Overrides sp_fparen_brace.\nsp_fparen_brace_initializer = ignore # ignore/add/remove/force\n\n# (Java) Add or remove space between ')' and '{{' of double brace initializer.\nsp_fparen_dbrace = ignore # ignore/add/remove/force\n\n# Add or remove space between function name and '(' on function calls.\nsp_func_call_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between function name and '()' on function calls without\n# parameters. If set to ignore (the default), sp_func_call_paren is used.\nsp_func_call_paren_empty = ignore # ignore/add/remove/force\n\n# Add or remove space between the user function name and '(' on function\n# calls. You need to set a keyword to be a user function in the config file,\n# like:\n# set func_call_user tr _ i18n\nsp_func_call_user_paren = ignore # ignore/add/remove/force\n\n# Add or remove space inside user function '(' and ')'.\nsp_func_call_user_inside_fparen = ignore # ignore/add/remove/force\n\n# Add or remove space between nested parentheses with user functions,\n# i.e. '((' vs. '( ('.\nsp_func_call_user_paren_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between a constructor/destructor and the open\n# parenthesis.\nsp_func_class_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between a constructor without parameters or destructor\n# and '()'.\nsp_func_class_paren_empty = ignore # ignore/add/remove/force\n\n# Add or remove space after 'return'.\n#\n# Default: force\nsp_return = force # ignore/add/remove/force\n\n# Add or remove space between 'return' and '('.\nsp_return_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between 'return' and '{'.\nsp_return_brace = ignore # ignore/add/remove/force\n\n# Add or remove space between '__attribute__' and '('.\nsp_attribute_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between 'defined' and '(' in '#if defined (FOO)'.\nsp_defined_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between 'throw' and '(' in 'throw (something)'.\nsp_throw_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between 'throw' and anything other than '(' as in\n# '@throw [...];'.\nsp_after_throw = ignore # ignore/add/remove/force\n\n# Add or remove space between 'catch' and '(' in 'catch (something) { }'.\n# If set to ignore, sp_before_sparen is used.\nsp_catch_paren = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space between '@catch' and '('\n# in '@catch (something) { }'. If set to ignore, sp_catch_paren is used.\nsp_oc_catch_paren = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space before Objective-C protocol list\n# as in '@protocol Protocol' or '@interface MyClass : NSObject'.\nsp_before_oc_proto_list = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space between class name and '('\n# in '@interface className(categoryName):BaseClass'\nsp_oc_classname_paren = ignore # ignore/add/remove/force\n\n# (D) Add or remove space between 'version' and '('\n# in 'version (something) { }'. If set to ignore, sp_before_sparen is used.\nsp_version_paren = ignore # ignore/add/remove/force\n\n# (D) Add or remove space between 'scope' and '('\n# in 'scope (something) { }'. If set to ignore, sp_before_sparen is used.\nsp_scope_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between 'super' and '(' in 'super (something)'.\n#\n# Default: remove\nsp_super_paren = remove # ignore/add/remove/force\n\n# Add or remove space between 'this' and '(' in 'this (something)'.\n#\n# Default: remove\nsp_this_paren = remove # ignore/add/remove/force\n\n# Add or remove space between a macro name and its definition.\nsp_macro = ignore # ignore/add/remove/force\n\n# Add or remove space between a macro function ')' and its definition.\nsp_macro_func = ignore # ignore/add/remove/force\n\n# Add or remove space between 'else' and '{' if on the same line.\nsp_else_brace = ignore # ignore/add/remove/force\n\n# Add or remove space between '}' and 'else' if on the same line.\nsp_brace_else = ignore # ignore/add/remove/force\n\n# Add or remove space between '}' and the name of a typedef on the same line.\nsp_brace_typedef = ignore # ignore/add/remove/force\n\n# Add or remove space before the '{' of a 'catch' statement, if the '{' and\n# 'catch' are on the same line, as in 'catch (decl) {'.\nsp_catch_brace = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space before the '{' of a '@catch' statement, if the '{'\n# and '@catch' are on the same line, as in '@catch (decl) {'.\n# If set to ignore, sp_catch_brace is used.\nsp_oc_catch_brace = ignore # ignore/add/remove/force\n\n# Add or remove space between '}' and 'catch' if on the same line.\nsp_brace_catch = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space between '}' and '@catch' if on the same line.\n# If set to ignore, sp_brace_catch is used.\nsp_oc_brace_catch = ignore # ignore/add/remove/force\n\n# Add or remove space between 'finally' and '{' if on the same line.\nsp_finally_brace = ignore # ignore/add/remove/force\n\n# Add or remove space between '}' and 'finally' if on the same line.\nsp_brace_finally = ignore # ignore/add/remove/force\n\n# Add or remove space between 'try' and '{' if on the same line.\nsp_try_brace = ignore # ignore/add/remove/force\n\n# Add or remove space between get/set and '{' if on the same line.\nsp_getset_brace = ignore # ignore/add/remove/force\n\n# Add or remove space between a variable and '{' for C++ uniform\n# initialization.\nsp_word_brace_init_lst = ignore # ignore/add/remove/force\n\n# Add or remove space between a variable and '{' for a namespace.\n#\n# Default: add\nsp_word_brace_ns = add # ignore/add/remove/force\n\n# Add or remove space before the '::' operator.\nsp_before_dc = ignore # ignore/add/remove/force\n\n# Add or remove space after the '::' operator.\nsp_after_dc = ignore # ignore/add/remove/force\n\n# (D) Add or remove around the D named array initializer ':' operator.\nsp_d_array_colon = ignore # ignore/add/remove/force\n\n# Add or remove space after the '!' (not) unary operator.\n#\n# Default: remove\nsp_not = remove # ignore/add/remove/force\n\n# Add or remove space between two '!' (not) unary operators.\n# If set to ignore, sp_not will be used.\nsp_not_not = ignore # ignore/add/remove/force\n\n# Add or remove space after the '~' (invert) unary operator.\n#\n# Default: remove\nsp_inv = remove # ignore/add/remove/force\n\n# Add or remove space after the '&' (address-of) unary operator. This does not\n# affect the spacing after a '&' that is part of a type.\n#\n# Default: remove\nsp_addr = remove # ignore/add/remove/force\n\n# Add or remove space around the '.' or '->' operators.\n#\n# Default: remove\nsp_member = remove # ignore/add/remove/force\n\n# Add or remove space after the '*' (dereference) unary operator. This does\n# not affect the spacing after a '*' that is part of a type.\n#\n# Default: remove\nsp_deref = remove # ignore/add/remove/force\n\n# Add or remove space after '+' or '-', as in 'x = -5' or 'y = +7'.\n#\n# Default: remove\nsp_sign = remove # ignore/add/remove/force\n\n# Add or remove space between '++' and '--' the word to which it is being\n# applied, as in '(--x)' or 'y++;'.\n#\n# Default: remove\nsp_incdec = remove # ignore/add/remove/force\n\n# Add or remove space before a backslash-newline at the end of a line.\n#\n# Default: add\nsp_before_nl_cont = add # ignore/add/remove/force\n\n# (OC) Add or remove space after the scope '+' or '-', as in '-(void) foo;'\n# or '+(int) bar;'.\nsp_after_oc_scope = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space after the colon in message specs,\n# i.e. '-(int) f:(int) x;' vs. '-(int) f: (int) x;'.\nsp_after_oc_colon = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space before the colon in message specs,\n# i.e. '-(int) f: (int) x;' vs. '-(int) f : (int) x;'.\nsp_before_oc_colon = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space after the colon in immutable dictionary expression\n# 'NSDictionary *test = @{@\"foo\" :@\"bar\"};'.\nsp_after_oc_dict_colon = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space before the colon in immutable dictionary expression\n# 'NSDictionary *test = @{@\"foo\" :@\"bar\"};'.\nsp_before_oc_dict_colon = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space after the colon in message specs,\n# i.e. '[object setValue:1];' vs. '[object setValue: 1];'.\nsp_after_send_oc_colon = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space before the colon in message specs,\n# i.e. '[object setValue:1];' vs. '[object setValue :1];'.\nsp_before_send_oc_colon = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space after the (type) in message specs,\n# i.e. '-(int)f: (int) x;' vs. '-(int)f: (int)x;'.\nsp_after_oc_type = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space after the first (type) in message specs,\n# i.e. '-(int) f:(int)x;' vs. '-(int)f:(int)x;'.\nsp_after_oc_return_type = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space between '@selector' and '(',\n# i.e. '@selector(msgName)' vs. '@selector (msgName)'.\n# Also applies to '@protocol()' constructs.\nsp_after_oc_at_sel = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space between '@selector(x)' and the following word,\n# i.e. '@selector(foo) a:' vs. '@selector(foo)a:'.\nsp_after_oc_at_sel_parens = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space inside '@selector' parentheses,\n# i.e. '@selector(foo)' vs. '@selector( foo )'.\n# Also applies to '@protocol()' constructs.\nsp_inside_oc_at_sel_parens = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space before a block pointer caret,\n# i.e. '^int (int arg){...}' vs. ' ^int (int arg){...}'.\nsp_before_oc_block_caret = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space after a block pointer caret,\n# i.e. '^int (int arg){...}' vs. '^ int (int arg){...}'.\nsp_after_oc_block_caret = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space between the receiver and selector in a message,\n# as in '[receiver selector ...]'.\nsp_after_oc_msg_receiver = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space after '@property'.\nsp_after_oc_property = ignore # ignore/add/remove/force\n\n# (OC) Add or remove space between '@synchronized' and the open parenthesis,\n# i.e. '@synchronized(foo)' vs. '@synchronized (foo)'.\nsp_after_oc_synchronized = ignore # ignore/add/remove/force\n\n# Add or remove space around the ':' in 'b ? t : f'.\nsp_cond_colon = ignore # ignore/add/remove/force\n\n# Add or remove space before the ':' in 'b ? t : f'.\n#\n# Overrides sp_cond_colon.\nsp_cond_colon_before = ignore # ignore/add/remove/force\n\n# Add or remove space after the ':' in 'b ? t : f'.\n#\n# Overrides sp_cond_colon.\nsp_cond_colon_after = ignore # ignore/add/remove/force\n\n# Add or remove space around the '?' in 'b ? t : f'.\nsp_cond_question = ignore # ignore/add/remove/force\n\n# Add or remove space before the '?' in 'b ? t : f'.\n#\n# Overrides sp_cond_question.\nsp_cond_question_before = ignore # ignore/add/remove/force\n\n# Add or remove space after the '?' in 'b ? t : f'.\n#\n# Overrides sp_cond_question.\nsp_cond_question_after = ignore # ignore/add/remove/force\n\n# In the abbreviated ternary form '(a ?: b)', add or remove space between '?'\n# and ':'.\n#\n# Overrides all other sp_cond_* options.\nsp_cond_ternary_short = ignore # ignore/add/remove/force\n\n# Fix the spacing between 'case' and the label. Only 'ignore' and 'force' make\n# sense here.\nsp_case_label = ignore # ignore/add/remove/force\n\n# (D) Add or remove space around the D '..' operator.\nsp_range = ignore # ignore/add/remove/force\n\n# Add or remove space after ':' in a Java/C++11 range-based 'for',\n# as in 'for (Type var : expr)'.\nsp_after_for_colon = ignore # ignore/add/remove/force\n\n# Add or remove space before ':' in a Java/C++11 range-based 'for',\n# as in 'for (Type var : expr)'.\nsp_before_for_colon = ignore # ignore/add/remove/force\n\n# (D) Add or remove space between 'extern' and '(' as in 'extern (C)'.\nsp_extern_paren = ignore # ignore/add/remove/force\n\n# Add or remove space after the opening of a C++ comment, as in '// A'.\nsp_cmt_cpp_start = ignore # ignore/add/remove/force\n\n# remove space after the '//' and the pvs command '-V1234',\n# only works with sp_cmt_cpp_start set to add or force.\nsp_cmt_cpp_pvs = false # true/false\n\n# remove space after the '//' and the command 'lint',\n# only works with sp_cmt_cpp_start set to add or force.\nsp_cmt_cpp_lint = false # true/false\n\n# Add or remove space in a C++ region marker comment, as in '// BEGIN'.\n# A region marker is defined as a comment which is not preceded by other text\n# (i.e. the comment is the first non-whitespace on the line), and which starts\n# with either 'BEGIN' or 'END'.\n#\n# Overrides sp_cmt_cpp_start.\nsp_cmt_cpp_region = ignore # ignore/add/remove/force\n\n# If true, space added with sp_cmt_cpp_start will be added after Doxygen\n# sequences like '///', '///<', '//!' and '//!<'.\nsp_cmt_cpp_doxygen = false # true/false\n\n# If true, space added with sp_cmt_cpp_start will be added after Qt translator\n# or meta-data comments like '//:', '//=', and '//~'.\nsp_cmt_cpp_qttr = false # true/false\n\n# Add or remove space between #else or #endif and a trailing comment.\nsp_endif_cmt = ignore # ignore/add/remove/force\n\n# Add or remove space after 'new', 'delete' and 'delete[]'.\nsp_after_new = ignore # ignore/add/remove/force\n\n# Add or remove space between 'new' and '(' in 'new()'.\nsp_between_new_paren = ignore # ignore/add/remove/force\n\n# Add or remove space between ')' and type in 'new(foo) BAR'.\nsp_after_newop_paren = ignore # ignore/add/remove/force\n\n# Add or remove space inside parentheses of the new operator\n# as in 'new(foo) BAR'.\nsp_inside_newop_paren = ignore # ignore/add/remove/force\n\n# Add or remove space after the open parenthesis of the new operator,\n# as in 'new(foo) BAR'.\n#\n# Overrides sp_inside_newop_paren.\nsp_inside_newop_paren_open = ignore # ignore/add/remove/force\n\n# Add or remove space before the close parenthesis of the new operator,\n# as in 'new(foo) BAR'.\n#\n# Overrides sp_inside_newop_paren.\nsp_inside_newop_paren_close = ignore # ignore/add/remove/force\n\n# Add or remove space before a trailing comment.\nsp_before_tr_cmt = ignore # ignore/add/remove/force\n\n# Number of spaces before a trailing comment.\nsp_num_before_tr_cmt = 0 # unsigned number\n\n# Add or remove space before an embedded comment.\n#\n# Default: force\nsp_before_emb_cmt = force # ignore/add/remove/force\n\n# Number of spaces before an embedded comment.\n#\n# Default: 1\nsp_num_before_emb_cmt = 1 # unsigned number\n\n# Add or remove space after an embedded comment.\n#\n# Default: force\nsp_after_emb_cmt = force # ignore/add/remove/force\n\n# Number of spaces after an embedded comment.\n#\n# Default: 1\nsp_num_after_emb_cmt = 1 # unsigned number\n\n# Embedded comment spacing options have higher priority (== override)\n# than other spacing options (comma, parenthesis, braces, ...)\nsp_emb_cmt_priority = false # true/false\n\n# (Java) Add or remove space between an annotation and the open parenthesis.\nsp_annotation_paren = ignore # ignore/add/remove/force\n\n# If true, vbrace tokens are dropped to the previous token and skipped.\nsp_skip_vbrace_tokens = false # true/false\n\n# Add or remove space after 'noexcept'.\nsp_after_noexcept = ignore # ignore/add/remove/force\n\n# Add or remove space after '_'.\nsp_vala_after_translation = ignore # ignore/add/remove/force\n\n# Add or remove space before a bit colon ':'.\nsp_before_bit_colon = ignore # ignore/add/remove/force\n\n# Add or remove space after a bit colon ':'.\nsp_after_bit_colon = ignore # ignore/add/remove/force\n\n# If true, a is inserted after #define.\nforce_tab_after_define = false # true/false\n\n# Add or remove space between two strings.\nsp_string_string = ignore # ignore/add/remove/force\n\n# Add or remove space 'struct' and a type.\nsp_struct_type = ignore # ignore/add/remove/force\n\n#\n# Indenting options\n#\n\n# The number of columns to indent per level. Usually 2, 3, 4, or 8.\n#\n# Default: 8\nindent_columns = 8 # unsigned number\n\n# Whether to ignore indent for the first continuation line. Subsequent\n# continuation lines will still be indented to match the first.\nindent_ignore_first_continue = false # true/false\n\n# The continuation indent. If non-zero, this overrides the indent of '(', '['\n# and '=' continuation indents. Negative values are OK; negative value is\n# absolute and not increased for each '(' or '[' level.\n#\n# For FreeBSD, this is set to 4.\n# Requires indent_ignore_first_continue=false.\nindent_continue = 0 # number\n\n# The continuation indent, only for class header line(s). If non-zero, this\n# overrides the indent of 'class' continuation indents.\n# Requires indent_ignore_first_continue=false.\nindent_continue_class_head = 0 # unsigned number\n\n# Whether to indent empty lines (i.e. lines which contain only spaces before\n# the newline character).\nindent_single_newlines = false # true/false\n\n# The continuation indent for func_*_param if they are true. If non-zero, this\n# overrides the indent.\nindent_param = 0 # unsigned number\n\n# How to use tabs when indenting code.\n#\n# 0: Spaces only\n# 1: Indent with tabs to brace level, align with spaces (default)\n# 2: Indent and align with tabs, using spaces when not on a tabstop\n#\n# Default: 1\nindent_with_tabs = 1 # unsigned number\n\n# Whether to indent comments that are not at a brace level with tabs on a\n# tabstop. Requires indent_with_tabs=2. If false, will use spaces.\nindent_cmt_with_tabs = false # true/false\n\n# Whether to indent strings broken by '\\' so that they line up.\nindent_align_string = false # true/false\n\n# The number of spaces to indent multi-line XML strings.\n# Requires indent_align_string=true.\nindent_xml_string = 0 # unsigned number\n\n# Spaces to indent '{' from level.\nindent_brace = 0 # unsigned number\n\n# Whether braces are indented to the body level.\nindent_braces = false # true/false\n\n# Whether to disable indenting function braces if indent_braces=true.\nindent_braces_no_func = false # true/false\n\n# Whether to disable indenting class braces if indent_braces=true.\nindent_braces_no_class = false # true/false\n\n# Whether to disable indenting struct braces if indent_braces=true.\nindent_braces_no_struct = false # true/false\n\n# Whether to indent based on the size of the brace parent,\n# i.e. 'if' => 3 spaces, 'for' => 4 spaces, etc.\nindent_brace_parent = false # true/false\n\n# Whether to indent based on the open parenthesis instead of the open brace\n# in '({\\n'.\nindent_paren_open_brace = false # true/false\n\n# (C#) Whether to indent the brace of a C# delegate by another level.\nindent_cs_delegate_brace = false # true/false\n\n# (C#) Whether to indent a C# delegate (to handle delegates with no brace) by\n# another level.\nindent_cs_delegate_body = false # true/false\n\n# Whether to indent the body of a 'namespace'.\nindent_namespace = false # true/false\n\n# Whether to indent only the first namespace, and not any nested namespaces.\n# Requires indent_namespace=true.\nindent_namespace_single_indent = false # true/false\n\n# The number of spaces to indent a namespace block.\n# If set to zero, use the value indent_columns\nindent_namespace_level = 0 # unsigned number\n\n# If the body of the namespace is longer than this number, it won't be\n# indented. Requires indent_namespace=true. 0 means no limit.\nindent_namespace_limit = 0 # unsigned number\n\n# Whether to indent only in inner namespaces (nested in other namespaces).\n# Requires indent_namespace=true.\nindent_namespace_inner_only = false # true/false\n\n# Whether the 'extern \"C\"' body is indented.\nindent_extern = false # true/false\n\n# Whether the 'class' body is indented.\nindent_class = false # true/false\n\n# Whether to ignore indent for the leading base class colon.\nindent_ignore_before_class_colon = false # true/false\n\n# Additional indent before the leading base class colon.\n# Negative values decrease indent down to the first column.\n# Requires indent_ignore_before_class_colon=false and a newline break before\n# the colon (see pos_class_colon and nl_class_colon)\nindent_before_class_colon = 0 # number\n\n# Whether to indent the stuff after a leading base class colon.\nindent_class_colon = false # true/false\n\n# Whether to indent based on a class colon instead of the stuff after the\n# colon. Requires indent_class_colon=true.\nindent_class_on_colon = false # true/false\n\n# Whether to ignore indent for a leading class initializer colon.\nindent_ignore_before_constr_colon = false # true/false\n\n# Whether to indent the stuff after a leading class initializer colon.\nindent_constr_colon = false # true/false\n\n# Virtual indent from the ':' for leading member initializers.\n#\n# Default: 2\nindent_ctor_init_leading = 2 # unsigned number\n\n# Virtual indent from the ':' for following member initializers.\n#\n# Default: 2\nindent_ctor_init_following = 2 # unsigned number\n\n# Additional indent for constructor initializer list.\n# Negative values decrease indent down to the first column.\nindent_ctor_init = 0 # number\n\n# Whether to indent 'if' following 'else' as a new block under the 'else'.\n# If false, 'else\\nif' is treated as 'else if' for indenting purposes.\nindent_else_if = false # true/false\n\n# Amount to indent variable declarations after a open brace.\n#\n# <0: Relative\n# >=0: Absolute\nindent_var_def_blk = 0 # number\n\n# Whether to indent continued variable declarations instead of aligning.\nindent_var_def_cont = false # true/false\n\n# How to indent continued shift expressions ('<<' and '>>').\n# Set align_left_shift=false when using this.\n# 0: Align shift operators instead of indenting them (default)\n# 1: Indent by one level\n# -1: Preserve original indentation\nindent_shift = 0 # number\n\n# Whether to force indentation of function definitions to start in column 1.\nindent_func_def_force_col1 = false # true/false\n\n# Whether to indent continued function call parameters one indent level,\n# rather than aligning parameters under the open parenthesis.\nindent_func_call_param = false # true/false\n\n# Whether to indent continued function definition parameters one indent level,\n# rather than aligning parameters under the open parenthesis.\nindent_func_def_param = false # true/false\n\n# for function definitions, only if indent_func_def_param is false\n# Allows to align params when appropriate and indent them when not\n# behave as if it was true if paren position is more than this value\n# if paren position is more than the option value\nindent_func_def_param_paren_pos_threshold = 0 # unsigned number\n\n# Whether to indent continued function call prototype one indent level,\n# rather than aligning parameters under the open parenthesis.\nindent_func_proto_param = false # true/false\n\n# Whether to indent continued function call declaration one indent level,\n# rather than aligning parameters under the open parenthesis.\nindent_func_class_param = false # true/false\n\n# Whether to indent continued class variable constructors one indent level,\n# rather than aligning parameters under the open parenthesis.\nindent_func_ctor_var_param = false # true/false\n\n# Whether to indent continued template parameter list one indent level,\n# rather than aligning parameters under the open parenthesis.\nindent_template_param = false # true/false\n\n# Double the indent for indent_func_xxx_param options.\n# Use both values of the options indent_columns and indent_param.\nindent_func_param_double = false # true/false\n\n# Indentation column for standalone 'const' qualifier on a function\n# prototype.\nindent_func_const = 0 # unsigned number\n\n# Indentation column for standalone 'throw' qualifier on a function\n# prototype.\nindent_func_throw = 0 # unsigned number\n\n# How to indent within a macro followed by a brace on the same line\n# This allows reducing the indent in macros that have (for example)\n# `do { ... } while (0)` blocks bracketing them.\n#\n# true: add an indent for the brace on the same line as the macro\n# false: do not add an indent for the brace on the same line as the macro\n#\n# Default: true\nindent_macro_brace = true # true/false\n\n# The number of spaces to indent a continued '->' or '.'.\n# Usually set to 0, 1, or indent_columns.\nindent_member = 0 # unsigned number\n\n# Whether lines broken at '.' or '->' should be indented by a single indent.\n# The indent_member option will not be effective if this is set to true.\nindent_member_single = false # true/false\n\n# Spaces to indent single line ('//') comments on lines before code.\nindent_single_line_comments_before = 0 # unsigned number\n\n# Spaces to indent single line ('//') comments on lines after code.\nindent_single_line_comments_after = 0 # unsigned number\n\n# When opening a paren for a control statement (if, for, while, etc), increase\n# the indent level by this value. Negative values decrease the indent level.\nindent_sparen_extra = 0 # number\n\n# Whether to indent trailing single line ('//') comments relative to the code\n# instead of trying to keep the same absolute column.\nindent_relative_single_line_comments = false # true/false\n\n# Spaces to indent 'case' from 'switch'. Usually 0 or indent_columns.\n# It might be wise to choose the same value for the option indent_case_brace.\nindent_switch_case = 0 # unsigned number\n\n# Spaces to indent the body of a 'switch' before any 'case'.\n# Usually the same as indent_columns or indent_switch_case.\nindent_switch_body = 0 # unsigned number\n\n# Whether to ignore indent for '{' following 'case'.\nindent_ignore_case_brace = false # true/false\n\n# Spaces to indent '{' from 'case'. By default, the brace will appear under\n# the 'c' in case. Usually set to 0 or indent_columns. Negative values are OK.\n# It might be wise to choose the same value for the option indent_switch_case.\nindent_case_brace = 0 # number\n\n# indent 'break' with 'case' from 'switch'.\nindent_switch_break_with_case = false # true/false\n\n# Whether to indent preprocessor statements inside of switch statements.\n#\n# Default: true\nindent_switch_pp = true # true/false\n\n# Spaces to shift the 'case' line, without affecting any other lines.\n# Usually 0.\nindent_case_shift = 0 # unsigned number\n\n# Whether to align comments before 'case' with the 'case'.\n#\n# Default: true\nindent_case_comment = true # true/false\n\n# Whether to indent comments not found in first column.\n#\n# Default: true\nindent_comment = true # true/false\n\n# Whether to indent comments found in first column.\nindent_col1_comment = false # true/false\n\n# Whether to indent multi string literal in first column.\nindent_col1_multi_string_literal = false # true/false\n\n# Align comments on adjacent lines that are this many columns apart or less.\n#\n# Default: 3\nindent_comment_align_thresh = 3 # unsigned number\n\n# Whether to ignore indent for goto labels.\nindent_ignore_label = false # true/false\n\n# How to indent goto labels. Requires indent_ignore_label=false.\n#\n# >0: Absolute column where 1 is the leftmost column\n# <=0: Subtract from brace indent\n#\n# Default: 1\nindent_label = 1 # number\n\n# How to indent access specifiers that are followed by a\n# colon.\n#\n# >0: Absolute column where 1 is the leftmost column\n# <=0: Subtract from brace indent\n#\n# Default: 1\nindent_access_spec = 1 # number\n\n# Whether to indent the code after an access specifier by one level.\n# If true, this option forces 'indent_access_spec=0'.\nindent_access_spec_body = false # true/false\n\n# If an open parenthesis is followed by a newline, whether to indent the next\n# line so that it lines up after the open parenthesis (not recommended).\nindent_paren_nl = false # true/false\n\n# How to indent a close parenthesis after a newline.\n#\n# 0: Indent to body level (default)\n# 1: Align under the open parenthesis\n# 2: Indent to the brace level\n# -1: Preserve original indentation\nindent_paren_close = 0 # number\n\n# Whether to indent the open parenthesis of a function definition,\n# if the parenthesis is on its own line.\nindent_paren_after_func_def = false # true/false\n\n# Whether to indent the open parenthesis of a function declaration,\n# if the parenthesis is on its own line.\nindent_paren_after_func_decl = false # true/false\n\n# Whether to indent the open parenthesis of a function call,\n# if the parenthesis is on its own line.\nindent_paren_after_func_call = false # true/false\n\n# How to indent a comma when inside braces.\n# 0: Indent by one level (default)\n# 1: Align under the open brace\n# -1: Preserve original indentation\nindent_comma_brace = 0 # number\n\n# How to indent a comma when inside parentheses.\n# 0: Indent by one level (default)\n# 1: Align under the open parenthesis\n# -1: Preserve original indentation\nindent_comma_paren = 0 # number\n\n# How to indent a Boolean operator when inside parentheses.\n# 0: Indent by one level (default)\n# 1: Align under the open parenthesis\n# -1: Preserve original indentation\nindent_bool_paren = 0 # number\n\n# Whether to ignore the indentation of a Boolean operator when outside\n# parentheses.\nindent_ignore_bool = false # true/false\n\n# Whether to ignore the indentation of an arithmetic operator.\nindent_ignore_arith = false # true/false\n\n# Whether to indent a semicolon when inside a for parenthesis.\n# If true, aligns under the open for parenthesis.\nindent_semicolon_for_paren = false # true/false\n\n# Whether to ignore the indentation of a semicolon outside of a 'for'\n# statement.\nindent_ignore_semicolon = false # true/false\n\n# Whether to align the first expression to following ones\n# if indent_bool_paren=1.\nindent_first_bool_expr = false # true/false\n\n# Whether to align the first expression to following ones\n# if indent_semicolon_for_paren=true.\nindent_first_for_expr = false # true/false\n\n# If an open square is followed by a newline, whether to indent the next line\n# so that it lines up after the open square (not recommended).\nindent_square_nl = false # true/false\n\n# (ESQL/C) Whether to preserve the relative indent of 'EXEC SQL' bodies.\nindent_preserve_sql = false # true/false\n\n# Whether to ignore the indentation of an assignment operator.\nindent_ignore_assign = false # true/false\n\n# Whether to align continued statements at the '='. If false or if the '=' is\n# followed by a newline, the next line is indent one tab.\n#\n# Default: true\nindent_align_assign = true # true/false\n\n# If true, the indentation of the chunks after a '=' sequence will be set at\n# LHS token indentation column before '='.\nindent_off_after_assign = false # true/false\n\n# Whether to align continued statements at the '('. If false or the '(' is\n# followed by a newline, the next line indent is one tab.\n#\n# Default: true\nindent_align_paren = true # true/false\n\n# (OC) Whether to indent Objective-C code inside message selectors.\nindent_oc_inside_msg_sel = false # true/false\n\n# (OC) Whether to indent Objective-C blocks at brace level instead of usual\n# rules.\nindent_oc_block = false # true/false\n\n# (OC) Indent for Objective-C blocks in a message relative to the parameter\n# name.\n#\n# =0: Use indent_oc_block rules\n# >0: Use specified number of spaces to indent\nindent_oc_block_msg = 0 # unsigned number\n\n# (OC) Minimum indent for subsequent parameters\nindent_oc_msg_colon = 0 # unsigned number\n\n# (OC) Whether to prioritize aligning with initial colon (and stripping spaces\n# from lines, if necessary).\n#\n# Default: true\nindent_oc_msg_prioritize_first_colon = true # true/false\n\n# (OC) Whether to indent blocks the way that Xcode does by default\n# (from the keyword if the parameter is on its own line; otherwise, from the\n# previous indentation level). Requires indent_oc_block_msg=true.\nindent_oc_block_msg_xcode_style = false # true/false\n\n# (OC) Whether to indent blocks from where the brace is, relative to a\n# message keyword. Requires indent_oc_block_msg=true.\nindent_oc_block_msg_from_keyword = false # true/false\n\n# (OC) Whether to indent blocks from where the brace is, relative to a message\n# colon. Requires indent_oc_block_msg=true.\nindent_oc_block_msg_from_colon = false # true/false\n\n# (OC) Whether to indent blocks from where the block caret is.\n# Requires indent_oc_block_msg=true.\nindent_oc_block_msg_from_caret = false # true/false\n\n# (OC) Whether to indent blocks from where the brace caret is.\n# Requires indent_oc_block_msg=true.\nindent_oc_block_msg_from_brace = false # true/false\n\n# When indenting after virtual brace open and newline add further spaces to\n# reach this minimum indent.\nindent_min_vbrace_open = 0 # unsigned number\n\n# Whether to add further spaces after regular indent to reach next tabstop\n# when indenting after virtual brace open and newline.\nindent_vbrace_open_on_tabstop = false # true/false\n\n# How to indent after a brace followed by another token (not a newline).\n# true: indent all contained lines to match the token\n# false: indent all contained lines to match the brace\n#\n# Default: true\nindent_token_after_brace = true # true/false\n\n# Whether to indent the body of a C++11 lambda.\nindent_cpp_lambda_body = false # true/false\n\n# How to indent compound literals that are being returned.\n# true: add both the indent from return & the compound literal open brace\n# (i.e. 2 indent levels)\n# false: only indent 1 level, don't add the indent for the open brace, only\n# add the indent for the return.\n#\n# Default: true\nindent_compound_literal_return = true # true/false\n\n# (C#) Whether to indent a 'using' block if no braces are used.\n#\n# Default: true\nindent_using_block = true # true/false\n\n# How to indent the continuation of ternary operator.\n#\n# 0: Off (default)\n# 1: When the `if_false` is a continuation, indent it under the `if_true` branch\n# 2: When the `:` is a continuation, indent it under `?`\nindent_ternary_operator = 0 # unsigned number\n\n# Whether to indent the statements inside ternary operator.\nindent_inside_ternary_operator = false # true/false\n\n# If true, the indentation of the chunks after a `return` sequence will be set at return indentation column.\nindent_off_after_return = false # true/false\n\n# If true, the indentation of the chunks after a `return new` sequence will be set at return indentation column.\nindent_off_after_return_new = false # true/false\n\n# If true, the tokens after return are indented with regular single indentation. By default (false) the indentation is after the return token.\nindent_single_after_return = false # true/false\n\n# Whether to ignore indent and alignment for 'asm' blocks (i.e. assume they\n# have their own indentation).\nindent_ignore_asm_block = false # true/false\n\n# Don't indent the close parenthesis of a function definition,\n# if the parenthesis is on its own line.\ndonot_indent_func_def_close_paren = false # true/false\n\n#\n# Newline adding and removing options\n#\n\n# Whether to collapse empty blocks between '{' and '}' except for functions.\n# Use nl_collapse_empty_body_functions to specify how empty function braces\n# should be formatted.\nnl_collapse_empty_body = false # true/false\n\n# Whether to collapse empty blocks between '{' and '}' for functions only.\n# If true, overrides nl_inside_empty_func.\nnl_collapse_empty_body_functions = false # true/false\n\n# Don't split one-line braced assignments, as in 'foo_t f = { 1, 2 };'.\nnl_assign_leave_one_liners = false # true/false\n\n# Don't split one-line braced statements inside a 'class xx { }' body.\nnl_class_leave_one_liners = false # true/false\n\n# Don't split one-line enums, as in 'enum foo { BAR = 15 };'\nnl_enum_leave_one_liners = false # true/false\n\n# Don't split one-line get or set functions.\nnl_getset_leave_one_liners = false # true/false\n\n# (C#) Don't split one-line property get or set functions.\nnl_cs_property_leave_one_liners = false # true/false\n\n# Don't split one-line function definitions, as in 'int foo() { return 0; }'.\n# might modify nl_func_type_name\nnl_func_leave_one_liners = false # true/false\n\n# Don't split one-line C++11 lambdas, as in '[]() { return 0; }'.\nnl_cpp_lambda_leave_one_liners = false # true/false\n\n# Don't split one-line if/else statements, as in 'if(...) b++;'.\nnl_if_leave_one_liners = false # true/false\n\n# Don't split one-line while statements, as in 'while(...) b++;'.\nnl_while_leave_one_liners = false # true/false\n\n# Don't split one-line do statements, as in 'do { b++; } while(...);'.\nnl_do_leave_one_liners = false # true/false\n\n# Don't split one-line for statements, as in 'for(...) b++;'.\nnl_for_leave_one_liners = false # true/false\n\n# (OC) Don't split one-line Objective-C messages.\nnl_oc_msg_leave_one_liner = false # true/false\n\n# (OC) Add or remove newline between method declaration and '{'.\nnl_oc_mdef_brace = ignore # ignore/add/remove/force\n\n# (OC) Add or remove newline between Objective-C block signature and '{'.\nnl_oc_block_brace = ignore # ignore/add/remove/force\n\n# (OC) Add or remove blank line before '@interface' statement.\nnl_oc_before_interface = ignore # ignore/add/remove/force\n\n# (OC) Add or remove blank line before '@implementation' statement.\nnl_oc_before_implementation = ignore # ignore/add/remove/force\n\n# (OC) Add or remove blank line before '@end' statement.\nnl_oc_before_end = ignore # ignore/add/remove/force\n\n# (OC) Add or remove newline between '@interface' and '{'.\nnl_oc_interface_brace = ignore # ignore/add/remove/force\n\n# (OC) Add or remove newline between '@implementation' and '{'.\nnl_oc_implementation_brace = ignore # ignore/add/remove/force\n\n# Add or remove newlines at the start of the file.\nnl_start_of_file = ignore # ignore/add/remove/force\n\n# The minimum number of newlines at the start of the file (only used if\n# nl_start_of_file is 'add' or 'force').\nnl_start_of_file_min = 0 # unsigned number\n\n# Add or remove newline at the end of the file.\nnl_end_of_file = ignore # ignore/add/remove/force\n\n# The minimum number of newlines at the end of the file (only used if\n# nl_end_of_file is 'add' or 'force').\nnl_end_of_file_min = 0 # unsigned number\n\n# Add or remove newline between '=' and '{'.\nnl_assign_brace = ignore # ignore/add/remove/force\n\n# (D) Add or remove newline between '=' and '['.\nnl_assign_square = ignore # ignore/add/remove/force\n\n# Add or remove newline between '[]' and '{'.\nnl_tsquare_brace = ignore # ignore/add/remove/force\n\n# (D) Add or remove newline after '= ['. Will also affect the newline before\n# the ']'.\nnl_after_square_assign = ignore # ignore/add/remove/force\n\n# Add or remove newline between a function call's ')' and '{', as in\n# 'list_for_each(item, &list) { }'.\nnl_fcall_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'enum' and '{'.\nnl_enum_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'enum' and 'class'.\nnl_enum_class = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'enum class' and the identifier.\nnl_enum_class_identifier = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'enum class' type and ':'.\nnl_enum_identifier_colon = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'enum class identifier :' and type.\nnl_enum_colon_type = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'struct and '{'.\nnl_struct_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'union' and '{'.\nnl_union_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'if' and '{'.\nnl_if_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between '}' and 'else'.\nnl_brace_else = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'else if' and '{'. If set to ignore,\n# nl_if_brace is used instead.\nnl_elseif_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'else' and '{'.\nnl_else_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'else' and 'if'.\nnl_else_if = ignore # ignore/add/remove/force\n\n# Add or remove newline before '{' opening brace\nnl_before_opening_brace_func_class_def = ignore # ignore/add/remove/force\n\n# Add or remove newline before 'if'/'else if' closing parenthesis.\nnl_before_if_closing_paren = ignore # ignore/add/remove/force\n\n# Add or remove newline between '}' and 'finally'.\nnl_brace_finally = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'finally' and '{'.\nnl_finally_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'try' and '{'.\nnl_try_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between get/set and '{'.\nnl_getset_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'for' and '{'.\nnl_for_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline before the '{' of a 'catch' statement, as in\n# 'catch (decl) {'.\nnl_catch_brace = ignore # ignore/add/remove/force\n\n# (OC) Add or remove newline before the '{' of a '@catch' statement, as in\n# '@catch (decl) {'. If set to ignore, nl_catch_brace is used.\nnl_oc_catch_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between '}' and 'catch'.\nnl_brace_catch = ignore # ignore/add/remove/force\n\n# (OC) Add or remove newline between '}' and '@catch'. If set to ignore,\n# nl_brace_catch is used.\nnl_oc_brace_catch = ignore # ignore/add/remove/force\n\n# Add or remove newline between '}' and ']'.\nnl_brace_square = ignore # ignore/add/remove/force\n\n# Add or remove newline between '}' and ')' in a function invocation.\nnl_brace_fparen = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'while' and '{'.\nnl_while_brace = ignore # ignore/add/remove/force\n\n# (D) Add or remove newline between 'scope (x)' and '{'.\nnl_scope_brace = ignore # ignore/add/remove/force\n\n# (D) Add or remove newline between 'unittest' and '{'.\nnl_unittest_brace = ignore # ignore/add/remove/force\n\n# (D) Add or remove newline between 'version (x)' and '{'.\nnl_version_brace = ignore # ignore/add/remove/force\n\n# (C#) Add or remove newline between 'using' and '{'.\nnl_using_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between two open or close braces. Due to general\n# newline/brace handling, REMOVE may not work.\nnl_brace_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'do' and '{'.\nnl_do_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between '}' and 'while' of 'do' statement.\nnl_brace_while = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'switch' and '{'.\nnl_switch_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'synchronized' and '{'.\nnl_synchronized_brace = ignore # ignore/add/remove/force\n\n# Add a newline between ')' and '{' if the ')' is on a different line than the\n# if/for/etc.\n#\n# Overrides nl_for_brace, nl_if_brace, nl_switch_brace, nl_while_switch and\n# nl_catch_brace.\nnl_multi_line_cond = false # true/false\n\n# Add a newline after '(' if an if/for/while/switch condition spans multiple\n# lines\nnl_multi_line_sparen_open = ignore # ignore/add/remove/force\n\n# Add a newline before ')' if an if/for/while/switch condition spans multiple\n# lines. Overrides nl_before_if_closing_paren if both are specified.\nnl_multi_line_sparen_close = ignore # ignore/add/remove/force\n\n# Force a newline in a define after the macro name for multi-line defines.\nnl_multi_line_define = false # true/false\n\n# Whether to add a newline before 'case', and a blank line before a 'case'\n# statement that follows a ';' or '}'.\nnl_before_case = false # true/false\n\n# Whether to add a newline after a 'case' statement.\nnl_after_case = false # true/false\n\n# Add or remove newline between a case ':' and '{'.\n#\n# Overrides nl_after_case.\nnl_case_colon_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between ')' and 'throw'.\nnl_before_throw = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'namespace' and '{'.\nnl_namespace_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline after 'template<...>' of a template class.\nnl_template_class = ignore # ignore/add/remove/force\n\n# Add or remove newline after 'template<...>' of a template class declaration.\n#\n# Overrides nl_template_class.\nnl_template_class_decl = ignore # ignore/add/remove/force\n\n# Add or remove newline after 'template<>' of a specialized class declaration.\n#\n# Overrides nl_template_class_decl.\nnl_template_class_decl_special = ignore # ignore/add/remove/force\n\n# Add or remove newline after 'template<...>' of a template class definition.\n#\n# Overrides nl_template_class.\nnl_template_class_def = ignore # ignore/add/remove/force\n\n# Add or remove newline after 'template<>' of a specialized class definition.\n#\n# Overrides nl_template_class_def.\nnl_template_class_def_special = ignore # ignore/add/remove/force\n\n# Add or remove newline after 'template<...>' of a template function.\nnl_template_func = ignore # ignore/add/remove/force\n\n# Add or remove newline after 'template<...>' of a template function\n# declaration.\n#\n# Overrides nl_template_func.\nnl_template_func_decl = ignore # ignore/add/remove/force\n\n# Add or remove newline after 'template<>' of a specialized function\n# declaration.\n#\n# Overrides nl_template_func_decl.\nnl_template_func_decl_special = ignore # ignore/add/remove/force\n\n# Add or remove newline after 'template<...>' of a template function\n# definition.\n#\n# Overrides nl_template_func.\nnl_template_func_def = ignore # ignore/add/remove/force\n\n# Add or remove newline after 'template<>' of a specialized function\n# definition.\n#\n# Overrides nl_template_func_def.\nnl_template_func_def_special = ignore # ignore/add/remove/force\n\n# Add or remove newline after 'template<...>' of a template variable.\nnl_template_var = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'template<...>' and 'using' of a templated\n# type alias.\nnl_template_using = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'class' and '{'.\nnl_class_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline before or after (depending on pos_class_comma,\n# may not be IGNORE) each',' in the base class list.\nnl_class_init_args = ignore # ignore/add/remove/force\n\n# Add or remove newline after each ',' in the constructor member\n# initialization. Related to nl_constr_colon, pos_constr_colon and\n# pos_constr_comma.\nnl_constr_init_args = ignore # ignore/add/remove/force\n\n# Add or remove newline before first element, after comma, and after last\n# element, in 'enum'.\nnl_enum_own_lines = ignore # ignore/add/remove/force\n\n# Add or remove newline between return type and function name in a function\n# definition.\n# might be modified by nl_func_leave_one_liners\nnl_func_type_name = ignore # ignore/add/remove/force\n\n# Add or remove newline between return type and function name inside a class\n# definition. If set to ignore, nl_func_type_name or nl_func_proto_type_name\n# is used instead.\nnl_func_type_name_class = ignore # ignore/add/remove/force\n\n# Add or remove newline between class specification and '::'\n# in 'void A::f() { }'. Only appears in separate member implementation (does\n# not appear with in-line implementation).\nnl_func_class_scope = ignore # ignore/add/remove/force\n\n# Add or remove newline between function scope and name, as in\n# 'void A :: f() { }'.\nnl_func_scope_name = ignore # ignore/add/remove/force\n\n# Add or remove newline between return type and function name in a prototype.\nnl_func_proto_type_name = ignore # ignore/add/remove/force\n\n# Add or remove newline between a function name and the opening '(' in the\n# declaration.\nnl_func_paren = ignore # ignore/add/remove/force\n\n# Overrides nl_func_paren for functions with no parameters.\nnl_func_paren_empty = ignore # ignore/add/remove/force\n\n# Add or remove newline between a function name and the opening '(' in the\n# definition.\nnl_func_def_paren = ignore # ignore/add/remove/force\n\n# Overrides nl_func_def_paren for functions with no parameters.\nnl_func_def_paren_empty = ignore # ignore/add/remove/force\n\n# Add or remove newline between a function name and the opening '(' in the\n# call.\nnl_func_call_paren = ignore # ignore/add/remove/force\n\n# Overrides nl_func_call_paren for functions with no parameters.\nnl_func_call_paren_empty = ignore # ignore/add/remove/force\n\n# Add or remove newline after '(' in a function declaration.\nnl_func_decl_start = ignore # ignore/add/remove/force\n\n# Add or remove newline after '(' in a function definition.\nnl_func_def_start = ignore # ignore/add/remove/force\n\n# Overrides nl_func_decl_start when there is only one parameter.\nnl_func_decl_start_single = ignore # ignore/add/remove/force\n\n# Overrides nl_func_def_start when there is only one parameter.\nnl_func_def_start_single = ignore # ignore/add/remove/force\n\n# Whether to add a newline after '(' in a function declaration if '(' and ')'\n# are in different lines. If false, nl_func_decl_start is used instead.\nnl_func_decl_start_multi_line = false # true/false\n\n# Whether to add a newline after '(' in a function definition if '(' and ')'\n# are in different lines. If false, nl_func_def_start is used instead.\nnl_func_def_start_multi_line = false # true/false\n\n# Add or remove newline after each ',' in a function declaration.\nnl_func_decl_args = ignore # ignore/add/remove/force\n\n# Add or remove newline after each ',' in a function definition.\nnl_func_def_args = ignore # ignore/add/remove/force\n\n# Add or remove newline after each ',' in a function call.\nnl_func_call_args = ignore # ignore/add/remove/force\n\n# Whether to add a newline after each ',' in a function declaration if '('\n# and ')' are in different lines. If false, nl_func_decl_args is used instead.\nnl_func_decl_args_multi_line = false # true/false\n\n# Whether to add a newline after each ',' in a function definition if '('\n# and ')' are in different lines. If false, nl_func_def_args is used instead.\nnl_func_def_args_multi_line = false # true/false\n\n# Add or remove newline before the ')' in a function declaration.\nnl_func_decl_end = ignore # ignore/add/remove/force\n\n# Add or remove newline before the ')' in a function definition.\nnl_func_def_end = ignore # ignore/add/remove/force\n\n# Overrides nl_func_decl_end when there is only one parameter.\nnl_func_decl_end_single = ignore # ignore/add/remove/force\n\n# Overrides nl_func_def_end when there is only one parameter.\nnl_func_def_end_single = ignore # ignore/add/remove/force\n\n# Whether to add a newline before ')' in a function declaration if '(' and ')'\n# are in different lines. If false, nl_func_decl_end is used instead.\nnl_func_decl_end_multi_line = false # true/false\n\n# Whether to add a newline before ')' in a function definition if '(' and ')'\n# are in different lines. If false, nl_func_def_end is used instead.\nnl_func_def_end_multi_line = false # true/false\n\n# Add or remove newline between '()' in a function declaration.\nnl_func_decl_empty = ignore # ignore/add/remove/force\n\n# Add or remove newline between '()' in a function definition.\nnl_func_def_empty = ignore # ignore/add/remove/force\n\n# Add or remove newline between '()' in a function call.\nnl_func_call_empty = ignore # ignore/add/remove/force\n\n# Whether to add a newline after '(' in a function call,\n# has preference over nl_func_call_start_multi_line.\nnl_func_call_start = ignore # ignore/add/remove/force\n\n# Whether to add a newline before ')' in a function call.\nnl_func_call_end = ignore # ignore/add/remove/force\n\n# Whether to add a newline after '(' in a function call if '(' and ')' are in\n# different lines.\nnl_func_call_start_multi_line = false # true/false\n\n# Whether to add a newline after each ',' in a function call if '(' and ')'\n# are in different lines.\nnl_func_call_args_multi_line = false # true/false\n\n# Whether to add a newline before ')' in a function call if '(' and ')' are in\n# different lines.\nnl_func_call_end_multi_line = false # true/false\n\n# Whether to respect nl_func_call_XXX option in case of closure args.\nnl_func_call_args_multi_line_ignore_closures = false # true/false\n\n# Whether to add a newline after '<' of a template parameter list.\nnl_template_start = false # true/false\n\n# Whether to add a newline after each ',' in a template parameter list.\nnl_template_args = false # true/false\n\n# Whether to add a newline before '>' of a template parameter list.\nnl_template_end = false # true/false\n\n# (OC) Whether to put each Objective-C message parameter on a separate line.\n# See nl_oc_msg_leave_one_liner.\nnl_oc_msg_args = false # true/false\n\n# (OC) Minimum number of Objective-C message parameters before applying nl_oc_msg_args.\nnl_oc_msg_args_min_params = 0 # unsigned number\n\n# (OC) Max code width of Objective-C message before applying nl_oc_msg_args.\nnl_oc_msg_args_max_code_width = 0 # unsigned number\n\n# (OC) Whether to apply nl_oc_msg_args if some of the parameters are already\n# on new lines. Overrides nl_oc_msg_args_min_params and nl_oc_msg_args_max_code_width.\nnl_oc_msg_args_finish_multi_line = false # true/false\n\n# Add or remove newline between function signature and '{'.\nnl_fdef_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between function signature and '{',\n# if signature ends with ')'. Overrides nl_fdef_brace.\nnl_fdef_brace_cond = ignore # ignore/add/remove/force\n\n# Add or remove newline between C++11 lambda signature and '{'.\nnl_cpp_ldef_brace = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'return' and the return expression.\nnl_return_expr = ignore # ignore/add/remove/force\n\n# Add or remove newline between 'throw' and the throw expression.\nnl_throw_expr = ignore # ignore/add/remove/force\n\n# Whether to add a newline after semicolons, except in 'for' statements.\nnl_after_semicolon = false # true/false\n\n# (Java) Add or remove newline between the ')' and '{{' of the double brace\n# initializer.\nnl_paren_dbrace_open = ignore # ignore/add/remove/force\n\n# Whether to add a newline after the type in an unnamed temporary\n# direct-list-initialization, better:\n# before a direct-list-initialization.\nnl_type_brace_init_lst = ignore # ignore/add/remove/force\n\n# Whether to add a newline after the open brace in an unnamed temporary\n# direct-list-initialization.\nnl_type_brace_init_lst_open = ignore # ignore/add/remove/force\n\n# Whether to add a newline before the close brace in an unnamed temporary\n# direct-list-initialization.\nnl_type_brace_init_lst_close = ignore # ignore/add/remove/force\n\n# Whether to add a newline before '{'.\nnl_before_brace_open = false # true/false\n\n# Whether to add a newline after '{'.\nnl_after_brace_open = false # true/false\n\n# Whether to add a newline between the open brace and a trailing single-line\n# comment. Requires nl_after_brace_open=true.\nnl_after_brace_open_cmt = false # true/false\n\n# Whether to add a newline after a virtual brace open with a non-empty body.\n# These occur in un-braced if/while/do/for statement bodies.\nnl_after_vbrace_open = false # true/false\n\n# Whether to add a newline after a virtual brace open with an empty body.\n# These occur in un-braced if/while/do/for statement bodies.\nnl_after_vbrace_open_empty = false # true/false\n\n# Whether to add a newline after '}'. Does not apply if followed by a\n# necessary ';'.\nnl_after_brace_close = false # true/false\n\n# Whether to add a newline after a virtual brace close,\n# as in 'if (foo) a++; return;'.\nnl_after_vbrace_close = false # true/false\n\n# Add or remove newline between the close brace and identifier,\n# as in 'struct { int a; } b;'. Affects enumerations, unions and\n# structures. If set to ignore, uses nl_after_brace_close.\nnl_brace_struct_var = ignore # ignore/add/remove/force\n\n# Whether to alter newlines in '#define' macros.\nnl_define_macro = false # true/false\n\n# Whether to alter newlines between consecutive parenthesis closes. The number\n# of closing parentheses in a line will depend on respective open parenthesis\n# lines.\nnl_squeeze_paren_close = false # true/false\n\n# Whether to remove blanks after '#ifxx' and '#elxx', or before '#elxx' and\n# '#endif'. Does not affect top-level #ifdefs.\nnl_squeeze_ifdef = false # true/false\n\n# Makes the nl_squeeze_ifdef option affect the top-level #ifdefs as well.\nnl_squeeze_ifdef_top_level = false # true/false\n\n# Add or remove blank line before 'if'.\nnl_before_if = ignore # ignore/add/remove/force\n\n# Add or remove blank line after 'if' statement. Add/Force work only if the\n# next token is not a closing brace.\nnl_after_if = ignore # ignore/add/remove/force\n\n# Add or remove blank line before 'for'.\nnl_before_for = ignore # ignore/add/remove/force\n\n# Add or remove blank line after 'for' statement.\nnl_after_for = ignore # ignore/add/remove/force\n\n# Add or remove blank line before 'while'.\nnl_before_while = ignore # ignore/add/remove/force\n\n# Add or remove blank line after 'while' statement.\nnl_after_while = ignore # ignore/add/remove/force\n\n# Add or remove blank line before 'switch'.\nnl_before_switch = ignore # ignore/add/remove/force\n\n# Add or remove blank line after 'switch' statement.\nnl_after_switch = ignore # ignore/add/remove/force\n\n# Add or remove blank line before 'synchronized'.\nnl_before_synchronized = ignore # ignore/add/remove/force\n\n# Add or remove blank line after 'synchronized' statement.\nnl_after_synchronized = ignore # ignore/add/remove/force\n\n# Add or remove blank line before 'do'.\nnl_before_do = ignore # ignore/add/remove/force\n\n# Add or remove blank line after 'do/while' statement.\nnl_after_do = ignore # ignore/add/remove/force\n\n# Ignore nl_before_{if,for,switch,do,synchronized} if the control\n# statement is immediately after a case statement.\n# if nl_before_{if,for,switch,do} is set to remove, this option\n# does nothing.\nnl_before_ignore_after_case = false # true/false\n\n# Whether to put a blank line before 'return' statements, unless after an open\n# brace.\nnl_before_return = false # true/false\n\n# Whether to put a blank line after 'return' statements, unless followed by a\n# close brace.\nnl_after_return = false # true/false\n\n# Whether to put a blank line before a member '.' or '->' operators.\nnl_before_member = ignore # ignore/add/remove/force\n\n# (Java) Whether to put a blank line after a member '.' or '->' operators.\nnl_after_member = ignore # ignore/add/remove/force\n\n# Whether to double-space commented-entries in 'struct'/'union'/'enum'.\nnl_ds_struct_enum_cmt = false # true/false\n\n# Whether to force a newline before '}' of a 'struct'/'union'/'enum'.\n# (Lower priority than eat_blanks_before_close_brace.)\nnl_ds_struct_enum_close_brace = false # true/false\n\n# Add or remove newline before or after (depending on pos_class_colon) a class\n# colon, as in 'class Foo : public Bar'.\nnl_class_colon = ignore # ignore/add/remove/force\n\n# Add or remove newline around a class constructor colon. The exact position\n# depends on nl_constr_init_args, pos_constr_colon and pos_constr_comma.\nnl_constr_colon = ignore # ignore/add/remove/force\n\n# Whether to collapse a two-line namespace, like 'namespace foo\\n{ decl; }'\n# into a single line. If true, prevents other brace newline rules from turning\n# such code into four lines. If true, it also preserves one-liner namespaces.\nnl_namespace_two_to_one_liner = false # true/false\n\n# Whether to remove a newline in simple unbraced if statements, turning them\n# into one-liners, as in 'if(b)\\n i++;' => 'if(b) i++;'.\nnl_create_if_one_liner = false # true/false\n\n# Whether to remove a newline in simple unbraced for statements, turning them\n# into one-liners, as in 'for (...)\\n stmt;' => 'for (...) stmt;'.\nnl_create_for_one_liner = false # true/false\n\n# Whether to remove a newline in simple unbraced while statements, turning\n# them into one-liners, as in 'while (expr)\\n stmt;' => 'while (expr) stmt;'.\nnl_create_while_one_liner = false # true/false\n\n# Whether to collapse a function definition whose body (not counting braces)\n# is only one line so that the entire definition (prototype, braces, body) is\n# a single line.\nnl_create_func_def_one_liner = false # true/false\n\n# Whether to split one-line simple list definitions into three lines by\n# adding newlines, as in 'int a[12] = { 0 };'.\nnl_create_list_one_liner = false # true/false\n\n# Whether to split one-line simple unbraced if statements into two lines by\n# adding a newline, as in 'if(b) i++;'.\nnl_split_if_one_liner = false # true/false\n\n# Whether to split one-line simple unbraced for statements into two lines by\n# adding a newline, as in 'for (...) stmt;'.\nnl_split_for_one_liner = false # true/false\n\n# Whether to split one-line simple unbraced while statements into two lines by\n# adding a newline, as in 'while (expr) stmt;'.\nnl_split_while_one_liner = false # true/false\n\n# Don't add a newline before a cpp-comment in a parameter list of a function\n# call.\ndonot_add_nl_before_cpp_comment = false # true/false\n\n#\n# Blank line options\n#\n\n# The maximum number of consecutive newlines (3 = 2 blank lines).\nnl_max = 0 # unsigned number\n\n# The maximum number of consecutive newlines in a function.\nnl_max_blank_in_func = 0 # unsigned number\n\n# The number of newlines inside an empty function body.\n# This option overrides eat_blanks_after_open_brace and\n# eat_blanks_before_close_brace, but is ignored when\n# nl_collapse_empty_body_functions=true\nnl_inside_empty_func = 0 # unsigned number\n\n# The number of newlines before a function prototype.\nnl_before_func_body_proto = 0 # unsigned number\n\n# The number of newlines before a multi-line function definition. Where\n# applicable, this option is overridden with eat_blanks_after_open_brace=true\nnl_before_func_body_def = 0 # unsigned number\n\n# The number of newlines before a class constructor/destructor prototype.\nnl_before_func_class_proto = 0 # unsigned number\n\n# The number of newlines before a class constructor/destructor definition.\nnl_before_func_class_def = 0 # unsigned number\n\n# The number of newlines after a function prototype.\nnl_after_func_proto = 0 # unsigned number\n\n# The number of newlines after a function prototype, if not followed by\n# another function prototype.\nnl_after_func_proto_group = 0 # unsigned number\n\n# The number of newlines after a class constructor/destructor prototype.\nnl_after_func_class_proto = 0 # unsigned number\n\n# The number of newlines after a class constructor/destructor prototype,\n# if not followed by another constructor/destructor prototype.\nnl_after_func_class_proto_group = 0 # unsigned number\n\n# Whether one-line method definitions inside a class body should be treated\n# as if they were prototypes for the purposes of adding newlines.\n#\n# Requires nl_class_leave_one_liners=true. Overrides nl_before_func_body_def\n# and nl_before_func_class_def for one-liners.\nnl_class_leave_one_liner_groups = false # true/false\n\n# The number of newlines after '}' of a multi-line function body.\n#\n# Overrides nl_min_after_func_body and nl_max_after_func_body.\nnl_after_func_body = 0 # unsigned number\n\n# The minimum number of newlines after '}' of a multi-line function body.\n#\n# Only works when nl_after_func_body is 0.\nnl_min_after_func_body = 0 # unsigned number\n\n# The maximum number of newlines after '}' of a multi-line function body.\n#\n# Only works when nl_after_func_body is 0.\n# Takes precedence over nl_min_after_func_body.\nnl_max_after_func_body = 0 # unsigned number\n\n# The number of newlines after '}' of a multi-line function body in a class\n# declaration. Also affects class constructors/destructors.\n#\n# Overrides nl_after_func_body.\nnl_after_func_body_class = 0 # unsigned number\n\n# The number of newlines after '}' of a single line function body. Also\n# affects class constructors/destructors.\n#\n# Overrides nl_after_func_body and nl_after_func_body_class.\nnl_after_func_body_one_liner = 0 # unsigned number\n\n# The number of newlines before a block of typedefs. If nl_after_access_spec\n# is non-zero, that option takes precedence.\n#\n# 0: No change (default).\nnl_typedef_blk_start = 0 # unsigned number\n\n# The number of newlines after a block of typedefs.\n#\n# 0: No change (default).\nnl_typedef_blk_end = 0 # unsigned number\n\n# The maximum number of consecutive newlines within a block of typedefs.\n#\n# 0: No change (default).\nnl_typedef_blk_in = 0 # unsigned number\n\n# The minimum number of blank lines after a block of variable definitions\n# at the top of a function body. If any preprocessor directives appear\n# between the opening brace of the function and the variable block, then\n# it is considered as not at the top of the function.Newlines are added\n# before trailing preprocessor directives, if any exist.\n#\n# 0: No change (default).\nnl_var_def_blk_end_func_top = 0 # unsigned number\n\n# The minimum number of empty newlines before a block of variable definitions\n# not at the top of a function body. If nl_after_access_spec is non-zero,\n# that option takes precedence. Newlines are not added at the top of the\n# file or just after an opening brace. Newlines are added above any\n# preprocessor directives before the block.\n#\n# 0: No change (default).\nnl_var_def_blk_start = 0 # unsigned number\n\n# The minimum number of empty newlines after a block of variable definitions\n# not at the top of a function body. Newlines are not added if the block\n# is at the bottom of the file or just before a preprocessor directive.\n#\n# 0: No change (default).\nnl_var_def_blk_end = 0 # unsigned number\n\n# The maximum number of consecutive newlines within a block of variable\n# definitions.\n#\n# 0: No change (default).\nnl_var_def_blk_in = 0 # unsigned number\n\n# The minimum number of newlines before a multi-line comment.\n# Doesn't apply if after a brace open or another multi-line comment.\nnl_before_block_comment = 0 # unsigned number\n\n# The minimum number of newlines before a single-line C comment.\n# Doesn't apply if after a brace open or other single-line C comments.\nnl_before_c_comment = 0 # unsigned number\n\n# The minimum number of newlines before a CPP comment.\n# Doesn't apply if after a brace open or other CPP comments.\nnl_before_cpp_comment = 0 # unsigned number\n\n# Whether to force a newline after a multi-line comment.\nnl_after_multiline_comment = false # true/false\n\n# Whether to force a newline after a label's colon.\nnl_after_label_colon = false # true/false\n\n# The number of newlines before a struct definition.\nnl_before_struct = 0 # unsigned number\n\n# The number of newlines after '}' or ';' of a struct/enum/union definition.\nnl_after_struct = 0 # unsigned number\n\n# The number of newlines before a class definition.\nnl_before_class = 0 # unsigned number\n\n# The number of newlines after '}' or ';' of a class definition.\nnl_after_class = 0 # unsigned number\n\n# The number of newlines before a namespace.\nnl_before_namespace = 0 # unsigned number\n\n# The number of newlines after '{' of a namespace. This also adds newlines\n# before the matching '}'.\n#\n# 0: Apply eat_blanks_after_open_brace or eat_blanks_before_close_brace if\n# applicable, otherwise no change.\n#\n# Overrides eat_blanks_after_open_brace and eat_blanks_before_close_brace.\nnl_inside_namespace = 0 # unsigned number\n\n# The number of newlines after '}' of a namespace.\nnl_after_namespace = 0 # unsigned number\n\n# The number of newlines before an access specifier label. This also includes\n# the Qt-specific 'signals:' and 'slots:'. Will not change the newline count\n# if after a brace open.\n#\n# 0: No change (default).\nnl_before_access_spec = 0 # unsigned number\n\n# The number of newlines after an access specifier label. This also includes\n# the Qt-specific 'signals:' and 'slots:'. Will not change the newline count\n# if after a brace open.\n#\n# 0: No change (default).\n#\n# Overrides nl_typedef_blk_start and nl_var_def_blk_start.\nnl_after_access_spec = 0 # unsigned number\n\n# The number of newlines between a function definition and the function\n# comment, as in '// comment\\n void foo() {...}'.\n#\n# 0: No change (default).\nnl_comment_func_def = 0 # unsigned number\n\n# The number of newlines after a try-catch-finally block that isn't followed\n# by a brace close.\n#\n# 0: No change (default).\nnl_after_try_catch_finally = 0 # unsigned number\n\n# (C#) The number of newlines before and after a property, indexer or event\n# declaration.\n#\n# 0: No change (default).\nnl_around_cs_property = 0 # unsigned number\n\n# (C#) The number of newlines between the get/set/add/remove handlers.\n#\n# 0: No change (default).\nnl_between_get_set = 0 # unsigned number\n\n# (C#) Add or remove newline between property and the '{'.\nnl_property_brace = ignore # ignore/add/remove/force\n\n# Whether to remove blank lines after '{'.\neat_blanks_after_open_brace = false # true/false\n\n# Whether to remove blank lines before '}'.\neat_blanks_before_close_brace = false # true/false\n\n# How aggressively to remove extra newlines not in preprocessor.\n#\n# 0: No change (default)\n# 1: Remove most newlines not handled by other config\n# 2: Remove all newlines and reformat completely by config\nnl_remove_extra_newlines = 0 # unsigned number\n\n# (Java) Add or remove newline after an annotation statement. Only affects\n# annotations that are after a newline.\nnl_after_annotation = ignore # ignore/add/remove/force\n\n# (Java) Add or remove newline between two annotations.\nnl_between_annotation = ignore # ignore/add/remove/force\n\n# The number of newlines before a whole-file #ifdef.\n#\n# 0: No change (default).\nnl_before_whole_file_ifdef = 0 # unsigned number\n\n# The number of newlines after a whole-file #ifdef.\n#\n# 0: No change (default).\nnl_after_whole_file_ifdef = 0 # unsigned number\n\n# The number of newlines before a whole-file #endif.\n#\n# 0: No change (default).\nnl_before_whole_file_endif = 0 # unsigned number\n\n# The number of newlines after a whole-file #endif.\n#\n# 0: No change (default).\nnl_after_whole_file_endif = 0 # unsigned number\n\n#\n# Positioning options\n#\n\n# The position of arithmetic operators in wrapped expressions.\npos_arith = ignore # ignore/break/force/lead/trail/join/lead_break/lead_force/trail_break/trail_force\n\n# The position of assignment in wrapped expressions. Do not affect '='\n# followed by '{'.\npos_assign = ignore # ignore/break/force/lead/trail/join/lead_break/lead_force/trail_break/trail_force\n\n# The position of Boolean operators in wrapped expressions.\npos_bool = ignore # ignore/break/force/lead/trail/join/lead_break/lead_force/trail_break/trail_force\n\n# The position of comparison operators in wrapped expressions.\npos_compare = ignore # ignore/break/force/lead/trail/join/lead_break/lead_force/trail_break/trail_force\n\n# The position of conditional operators, as in the '?' and ':' of\n# 'expr ? stmt : stmt', in wrapped expressions.\npos_conditional = ignore # ignore/break/force/lead/trail/join/lead_break/lead_force/trail_break/trail_force\n\n# The position of the comma in wrapped expressions.\npos_comma = ignore # ignore/break/force/lead/trail/join/lead_break/lead_force/trail_break/trail_force\n\n# The position of the comma in enum entries.\npos_enum_comma = ignore # ignore/break/force/lead/trail/join/lead_break/lead_force/trail_break/trail_force\n\n# The position of the comma in the base class list if there is more than one\n# line. Affects nl_class_init_args.\npos_class_comma = ignore # ignore/break/force/lead/trail/join/lead_break/lead_force/trail_break/trail_force\n\n# The position of the comma in the constructor initialization list.\n# Related to nl_constr_colon, nl_constr_init_args and pos_constr_colon.\npos_constr_comma = ignore # ignore/break/force/lead/trail/join/lead_break/lead_force/trail_break/trail_force\n\n# The position of trailing/leading class colon, between class and base class\n# list. Affects nl_class_colon.\npos_class_colon = ignore # ignore/break/force/lead/trail/join/lead_break/lead_force/trail_break/trail_force\n\n# The position of colons between constructor and member initialization.\n# Related to nl_constr_colon, nl_constr_init_args and pos_constr_comma.\npos_constr_colon = ignore # ignore/break/force/lead/trail/join/lead_break/lead_force/trail_break/trail_force\n\n# The position of shift operators in wrapped expressions.\npos_shift = ignore # ignore/break/force/lead/trail/join/lead_break/lead_force/trail_break/trail_force\n\n#\n# Line splitting options\n#\n\n# Try to limit code width to N columns.\ncode_width = 0 # unsigned number\n\n# Whether to fully split long 'for' statements at semi-colons.\nls_for_split_full = false # true/false\n\n# Whether to fully split long function prototypes/calls at commas.\n# The option ls_code_width has priority over the option ls_func_split_full.\nls_func_split_full = false # true/false\n\n# Whether to split lines as close to code_width as possible and ignore some\n# groupings.\n# The option ls_code_width has priority over the option ls_func_split_full.\nls_code_width = false # true/false\n\n#\n# Code alignment options (not left column spaces/tabs)\n#\n\n# Whether to keep non-indenting tabs.\nalign_keep_tabs = false # true/false\n\n# Whether to use tabs for aligning.\nalign_with_tabs = false # true/false\n\n# Whether to bump out to the next tab when aligning.\nalign_on_tabstop = false # true/false\n\n# Whether to right-align numbers.\nalign_number_right = false # true/false\n\n# Whether to keep whitespace not required for alignment.\nalign_keep_extra_space = false # true/false\n\n# Whether to align variable definitions in prototypes and functions.\nalign_func_params = false # true/false\n\n# The span for aligning parameter definitions in function on parameter name.\n#\n# 0: Don't align (default).\nalign_func_params_span = 1 # unsigned number\n\n# The threshold for aligning function parameter definitions.\n# Use a negative number for absolute thresholds.\n#\n# 0: No limit (default).\nalign_func_params_thresh = 0 # number\n\n# The gap for aligning function parameter definitions.\nalign_func_params_gap = 0 # unsigned number\n\n# The span for aligning constructor value.\n#\n# 0: Don't align (default).\nalign_constr_value_span = 0 # unsigned number\n\n# The threshold for aligning constructor value.\n# Use a negative number for absolute thresholds.\n#\n# 0: No limit (default).\nalign_constr_value_thresh = 0 # number\n\n# The gap for aligning constructor value.\nalign_constr_value_gap = 0 # unsigned number\n\n# Whether to align parameters in single-line functions that have the same\n# name. The function names must already be aligned with each other.\nalign_same_func_call_params = false # true/false\n\n# The span for aligning function-call parameters for single line functions.\n#\n# 0: Don't align (default).\nalign_same_func_call_params_span = 0 # unsigned number\n\n# The threshold for aligning function-call parameters for single line\n# functions.\n# Use a negative number for absolute thresholds.\n#\n# 0: No limit (default).\nalign_same_func_call_params_thresh = 0 # number\n\n# The span for aligning variable definitions.\n#\n# 0: Don't align (default).\nalign_var_def_span = 0 # unsigned number\n\n# How to consider (or treat) the '*' in the alignment of variable definitions.\n#\n# 0: Part of the type 'void * foo;' (default)\n# 1: Part of the variable 'void *foo;'\n# 2: Dangling 'void *foo;'\n# Dangling: the '*' will not be taken into account when aligning.\nalign_var_def_star_style = 0 # unsigned number\n\n# How to consider (or treat) the '&' in the alignment of variable definitions.\n#\n# 0: Part of the type 'long & foo;' (default)\n# 1: Part of the variable 'long &foo;'\n# 2: Dangling 'long &foo;'\n# Dangling: the '&' will not be taken into account when aligning.\nalign_var_def_amp_style = 0 # unsigned number\n\n# The threshold for aligning variable definitions.\n# Use a negative number for absolute thresholds.\n#\n# 0: No limit (default).\nalign_var_def_thresh = 0 # number\n\n# The gap for aligning variable definitions.\nalign_var_def_gap = 0 # unsigned number\n\n# Whether to align the colon in struct bit fields.\nalign_var_def_colon = false # true/false\n\n# The gap for aligning the colon in struct bit fields.\nalign_var_def_colon_gap = 0 # unsigned number\n\n# Whether to align any attribute after the variable name.\nalign_var_def_attribute = false # true/false\n\n# Whether to align inline struct/enum/union variable definitions.\nalign_var_def_inline = false # true/false\n\n# The span for aligning on '=' in assignments.\n#\n# 0: Don't align (default).\nalign_assign_span = 0 # unsigned number\n\n# The span for aligning on '=' in function prototype modifier.\n#\n# 0: Don't align (default).\nalign_assign_func_proto_span = 0 # unsigned number\n\n# The threshold for aligning on '=' in assignments.\n# Use a negative number for absolute thresholds.\n#\n# 0: No limit (default).\nalign_assign_thresh = 0 # number\n\n# Whether to align on the left most assignment when multiple\n# definitions are found on the same line.\n# Depends on 'align_assign_span' and 'align_assign_thresh' settings.\nalign_assign_on_multi_var_defs = false # true/false\n\n# The span for aligning on '{' in braced init list.\n#\n# 0: Don't align (default).\nalign_braced_init_list_span = 0 # unsigned number\n\n# The threshold for aligning on '{' in braced init list.\n# Use a negative number for absolute thresholds.\n#\n# 0: No limit (default).\nalign_braced_init_list_thresh = 0 # number\n\n# How to apply align_assign_span to function declaration \"assignments\", i.e.\n# 'virtual void foo() = 0' or '~foo() = {default|delete}'.\n#\n# 0: Align with other assignments (default)\n# 1: Align with each other, ignoring regular assignments\n# 2: Don't align\nalign_assign_decl_func = 0 # unsigned number\n\n# The span for aligning on '=' in enums.\n#\n# 0: Don't align (default).\nalign_enum_equ_span = 0 # unsigned number\n\n# The threshold for aligning on '=' in enums.\n# Use a negative number for absolute thresholds.\n#\n# 0: no limit (default).\nalign_enum_equ_thresh = 0 # number\n\n# The span for aligning class member definitions.\n#\n# 0: Don't align (default).\nalign_var_class_span = 0 # unsigned number\n\n# The threshold for aligning class member definitions.\n# Use a negative number for absolute thresholds.\n#\n# 0: No limit (default).\nalign_var_class_thresh = 0 # number\n\n# The gap for aligning class member definitions.\nalign_var_class_gap = 0 # unsigned number\n\n# The span for aligning struct/union member definitions.\n#\n# 0: Don't align (default).\nalign_var_struct_span = 0 # unsigned number\n\n# The threshold for aligning struct/union member definitions.\n# Use a negative number for absolute thresholds.\n#\n# 0: No limit (default).\nalign_var_struct_thresh = 0 # number\n\n# The gap for aligning struct/union member definitions.\nalign_var_struct_gap = 0 # unsigned number\n\n# The span for aligning struct initializer values.\n#\n# 0: Don't align (default).\nalign_struct_init_span = 0 # unsigned number\n\n# The span for aligning single-line typedefs.\n#\n# 0: Don't align (default).\nalign_typedef_span = 0 # unsigned number\n\n# The minimum space between the type and the synonym of a typedef.\nalign_typedef_gap = 0 # unsigned number\n\n# How to align typedef'd functions with other typedefs.\n#\n# 0: Don't mix them at all (default)\n# 1: Align the open parenthesis with the types\n# 2: Align the function type name with the other type names\nalign_typedef_func = 0 # unsigned number\n\n# How to consider (or treat) the '*' in the alignment of typedefs.\n#\n# 0: Part of the typedef type, 'typedef int * pint;' (default)\n# 1: Part of type name: 'typedef int *pint;'\n# 2: Dangling: 'typedef int *pint;'\n# Dangling: the '*' will not be taken into account when aligning.\nalign_typedef_star_style = 0 # unsigned number\n\n# How to consider (or treat) the '&' in the alignment of typedefs.\n#\n# 0: Part of the typedef type, 'typedef int & intref;' (default)\n# 1: Part of type name: 'typedef int &intref;'\n# 2: Dangling: 'typedef int &intref;'\n# Dangling: the '&' will not be taken into account when aligning.\nalign_typedef_amp_style = 0 # unsigned number\n\n# The span for aligning comments that end lines.\n#\n# 0: Don't align (default).\nalign_right_cmt_span = 0 # unsigned number\n\n# Minimum number of columns between preceding text and a trailing comment in\n# order for the comment to qualify for being aligned. Must be non-zero to have\n# an effect.\nalign_right_cmt_gap = 0 # unsigned number\n\n# If aligning comments, whether to mix with comments after '}' and #endif with\n# less than three spaces before the comment.\nalign_right_cmt_mix = false # true/false\n\n# Whether to only align trailing comments that are at the same brace level.\nalign_right_cmt_same_level = false # true/false\n\n# Minimum column at which to align trailing comments. Comments which are\n# aligned beyond this column, but which can be aligned in a lesser column,\n# may be \"pulled in\".\n#\n# 0: Ignore (default).\nalign_right_cmt_at_col = 0 # unsigned number\n\n# The span for aligning function prototypes.\n#\n# 0: Don't align (default).\nalign_func_proto_span = 0 # unsigned number\n\n# Whether to ignore continuation lines when evaluating the number of\n# new lines for the function prototype alignment's span.\n#\n# false: continuation lines are part of the newlines count\n# true: continuation lines are not counted\nalign_func_proto_span_ignore_cont_lines = false # true/false\n\n# How to consider (or treat) the '*' in the alignment of function prototypes.\n#\n# 0: Part of the type 'void * foo();' (default)\n# 1: Part of the function 'void *foo();'\n# 2: Dangling 'void *foo();'\n# Dangling: the '*' will not be taken into account when aligning.\nalign_func_proto_star_style = 0 # unsigned number\n\n# How to consider (or treat) the '&' in the alignment of function prototypes.\n#\n# 0: Part of the type 'long & foo();' (default)\n# 1: Part of the function 'long &foo();'\n# 2: Dangling 'long &foo();'\n# Dangling: the '&' will not be taken into account when aligning.\nalign_func_proto_amp_style = 0 # unsigned number\n\n# The threshold for aligning function prototypes.\n# Use a negative number for absolute thresholds.\n#\n# 0: No limit (default).\nalign_func_proto_thresh = 0 # number\n\n# Minimum gap between the return type and the function name.\nalign_func_proto_gap = 0 # unsigned number\n\n# Whether to align function prototypes on the 'operator' keyword instead of\n# what follows.\nalign_on_operator = false # true/false\n\n# Whether to mix aligning prototype and variable declarations. If true,\n# align_var_def_XXX options are used instead of align_func_proto_XXX options.\nalign_mix_var_proto = false # true/false\n\n# Whether to align single-line functions with function prototypes.\n# Uses align_func_proto_span.\nalign_single_line_func = false # true/false\n\n# Whether to align the open brace of single-line functions.\n# Requires align_single_line_func=true. Uses align_func_proto_span.\nalign_single_line_brace = false # true/false\n\n# Gap for align_single_line_brace.\nalign_single_line_brace_gap = 0 # unsigned number\n\n# (OC) The span for aligning Objective-C message specifications.\n#\n# 0: Don't align (default).\nalign_oc_msg_spec_span = 0 # unsigned number\n\n# Whether and how to align backslashes that split a macro onto multiple lines.\n# This will not work right if the macro contains a multi-line comment.\n#\n# 0: Do nothing (default)\n# 1: Align the backslashes in the column at the end of the longest line\n# 2: Align with the backslash that is farthest to the left, or, if that\n# backslash is farther left than the end of the longest line, at the end of\n# the longest line\n# 3: Align with the backslash that is farthest to the right\nalign_nl_cont = 0 # unsigned number\n\n# The minimum number of spaces between the end of a line and its continuation\n# backslash. Requires align_nl_cont.\n#\n# Default: 1\nalign_nl_cont_spaces = 1 # unsigned number\n\n# Whether to align macro functions and variables together.\nalign_pp_define_together = false # true/false\n\n# The span for aligning on '#define' bodies.\n#\n# =0: Don't align (default)\n# >0: Number of lines (including comments) between blocks\nalign_pp_define_span = 0 # unsigned number\n\n# The minimum space between label and value of a preprocessor define.\nalign_pp_define_gap = 0 # unsigned number\n\n# Whether to align lines that start with '<<' with previous '<<'.\n#\n# Default: true\nalign_left_shift = true # true/false\n\n# Whether to align comma-separated statements following '<<' (as used to\n# initialize Eigen matrices).\nalign_eigen_comma_init = false # true/false\n\n# Whether to align text after 'asm volatile ()' colons.\nalign_asm_colon = false # true/false\n\n# (OC) Span for aligning parameters in an Objective-C message call\n# on the ':'.\n#\n# 0: Don't align.\nalign_oc_msg_colon_span = 0 # unsigned number\n\n# (OC) Whether to always align with the first parameter, even if it is too\n# short.\nalign_oc_msg_colon_first = false # true/false\n\n# (OC) Whether to align parameters in an Objective-C '+' or '-' declaration\n# on the ':'.\nalign_oc_decl_colon = false # true/false\n\n# (OC) Whether to not align parameters in an Objectve-C message call if first\n# colon is not on next line of the message call (the same way Xcode does\n# alignment)\nalign_oc_msg_colon_xcode_like = false # true/false\n\n#\n# Comment modification options\n#\n\n# Try to wrap comments at N columns.\ncmt_width = 0 # unsigned number\n\n# How to reflow comments.\n#\n# 0: No reflowing (apart from the line wrapping due to cmt_width) (default)\n# 1: No touching at all\n# 2: Full reflow (enable cmt_indent_multi for indent with line wrapping due to cmt_width)\ncmt_reflow_mode = 0 # unsigned number\n\n# Path to a file that contains regular expressions describing patterns for\n# which the end of one line and the beginning of the next will be folded into\n# the same sentence or paragraph during full comment reflow. The regular\n# expressions are described using ECMAScript syntax. The syntax for this\n# specification is as follows, where \"...\" indicates the custom regular\n# expression and \"n\" indicates the nth end_of_prev_line_regex and\n# beg_of_next_line_regex regular expression pair:\n#\n# end_of_prev_line_regex[1] = \"...$\"\n# beg_of_next_line_regex[1] = \"^...\"\n# end_of_prev_line_regex[2] = \"...$\"\n# beg_of_next_line_regex[2] = \"^...\"\n# .\n# .\n# .\n# end_of_prev_line_regex[n] = \"...$\"\n# beg_of_next_line_regex[n] = \"^...\"\n#\n# Note that use of this option overrides the default reflow fold regular\n# expressions, which are internally defined as follows:\n#\n# end_of_prev_line_regex[1] = \"[\\w,\\]\\)]$\"\n# beg_of_next_line_regex[1] = \"^[\\w,\\[\\(]\"\n# end_of_prev_line_regex[2] = \"\\.$\"\n# beg_of_next_line_regex[2] = \"^[A-Z]\"\ncmt_reflow_fold_regex_file = \"\" # string\n\n# Whether to indent wrapped lines to the start of the encompassing paragraph\n# during full comment reflow (cmt_reflow_mode = 2). Overrides the value\n# specified by cmt_sp_after_star_cont.\n#\n# Note that cmt_align_doxygen_javadoc_tags overrides this option for\n# paragraphs associated with javadoc tags\ncmt_reflow_indent_to_paragraph_start = false # true/false\n\n# Whether to convert all tabs to spaces in comments. If false, tabs in\n# comments are left alone, unless used for indenting.\ncmt_convert_tab_to_spaces = false # true/false\n\n# Whether to apply changes to multi-line comments, including cmt_width,\n# keyword substitution and leading chars.\n#\n# Default: true\ncmt_indent_multi = true # true/false\n\n# Whether to align doxygen javadoc-style tags ('@param', '@return', etc.)\n# and corresponding fields such that groups of consecutive block tags,\n# parameter names, and descriptions align with one another. Overrides that\n# which is specified by the cmt_sp_after_star_cont. If cmt_width > 0, it may\n# be necessary to enable cmt_indent_multi and set cmt_reflow_mode = 2\n# in order to achieve the desired alignment for line-wrapping.\ncmt_align_doxygen_javadoc_tags = false # true/false\n\n# The number of spaces to insert after the star and before doxygen\n# javadoc-style tags (@param, @return, etc). Requires enabling\n# cmt_align_doxygen_javadoc_tags. Overrides that which is specified by the\n# cmt_sp_after_star_cont.\n#\n# Default: 1\ncmt_sp_before_doxygen_javadoc_tags = 1 # unsigned number\n\n# Whether to change trailing, single-line c-comments into cpp-comments.\ncmt_trailing_single_line_c_to_cpp = false # true/false\n\n# Whether to group c-comments that look like they are in a block.\ncmt_c_group = false # true/false\n\n# Whether to put an empty '/*' on the first line of the combined c-comment.\ncmt_c_nl_start = false # true/false\n\n# Whether to add a newline before the closing '*/' of the combined c-comment.\ncmt_c_nl_end = false # true/false\n\n# Whether to change cpp-comments into c-comments.\ncmt_cpp_to_c = false # true/false\n\n# Whether to group cpp-comments that look like they are in a block. Only\n# meaningful if cmt_cpp_to_c=true.\ncmt_cpp_group = false # true/false\n\n# Whether to put an empty '/*' on the first line of the combined cpp-comment\n# when converting to a c-comment.\n#\n# Requires cmt_cpp_to_c=true and cmt_cpp_group=true.\ncmt_cpp_nl_start = false # true/false\n\n# Whether to add a newline before the closing '*/' of the combined cpp-comment\n# when converting to a c-comment.\n#\n# Requires cmt_cpp_to_c=true and cmt_cpp_group=true.\ncmt_cpp_nl_end = false # true/false\n\n# Whether to put a star on subsequent comment lines.\ncmt_star_cont = false # true/false\n\n# The number of spaces to insert at the start of subsequent comment lines.\ncmt_sp_before_star_cont = 0 # unsigned number\n\n# The number of spaces to insert after the star on subsequent comment lines.\ncmt_sp_after_star_cont = 0 # unsigned number\n\n# For multi-line comments with a '*' lead, remove leading spaces if the first\n# and last lines of the comment are the same length.\n#\n# Default: true\ncmt_multi_check_last = true # true/false\n\n# For multi-line comments with a '*' lead, remove leading spaces if the first\n# and last lines of the comment are the same length AND if the length is\n# bigger as the first_len minimum.\n#\n# Default: 4\ncmt_multi_first_len_minimum = 4 # unsigned number\n\n# Path to a file that contains text to insert at the beginning of a file if\n# the file doesn't start with a C/C++ comment. If the inserted text contains\n# '$(filename)', that will be replaced with the current file's name.\ncmt_insert_file_header = \"\" # string\n\n# Path to a file that contains text to insert at the end of a file if the\n# file doesn't end with a C/C++ comment. If the inserted text contains\n# '$(filename)', that will be replaced with the current file's name.\ncmt_insert_file_footer = \"\" # string\n\n# Path to a file that contains text to insert before a function definition if\n# the function isn't preceded by a C/C++ comment. If the inserted text\n# contains '$(function)', '$(javaparam)' or '$(fclass)', these will be\n# replaced with, respectively, the name of the function, the javadoc '@param'\n# and '@return' stuff, or the name of the class to which the member function\n# belongs.\ncmt_insert_func_header = \"\" # string\n\n# Path to a file that contains text to insert before a class if the class\n# isn't preceded by a C/C++ comment. If the inserted text contains '$(class)',\n# that will be replaced with the class name.\ncmt_insert_class_header = \"\" # string\n\n# Path to a file that contains text to insert before an Objective-C message\n# specification, if the method isn't preceded by a C/C++ comment. If the\n# inserted text contains '$(message)' or '$(javaparam)', these will be\n# replaced with, respectively, the name of the function, or the javadoc\n# '@param' and '@return' stuff.\ncmt_insert_oc_msg_header = \"\" # string\n\n# Whether a comment should be inserted if a preprocessor is encountered when\n# stepping backwards from a function name.\n#\n# Applies to cmt_insert_oc_msg_header, cmt_insert_func_header and\n# cmt_insert_class_header.\ncmt_insert_before_preproc = false # true/false\n\n# Whether a comment should be inserted if a function is declared inline to a\n# class definition.\n#\n# Applies to cmt_insert_func_header.\n#\n# Default: true\ncmt_insert_before_inlines = true # true/false\n\n# Whether a comment should be inserted if the function is a class constructor\n# or destructor.\n#\n# Applies to cmt_insert_func_header.\ncmt_insert_before_ctor_dtor = false # true/false\n\n#\n# Code modifying options (non-whitespace)\n#\n\n# Add or remove braces on a single-line 'do' statement.\nmod_full_brace_do = ignore # ignore/add/remove/force\n\n# Add or remove braces on a single-line 'for' statement.\nmod_full_brace_for = ignore # ignore/add/remove/force\n\n# (Pawn) Add or remove braces on a single-line function definition.\nmod_full_brace_function = ignore # ignore/add/remove/force\n\n# Add or remove braces on a single-line 'if' statement. Braces will not be\n# removed if the braced statement contains an 'else'.\nmod_full_brace_if = ignore # ignore/add/remove/force\n\n# Whether to enforce that all blocks of an 'if'/'else if'/'else' chain either\n# have, or do not have, braces. Overrides mod_full_brace_if.\n#\n# 0: Don't override mod_full_brace_if\n# 1: Add braces to all blocks if any block needs braces and remove braces if\n# they can be removed from all blocks\n# 2: Add braces to all blocks if any block already has braces, regardless of\n# whether it needs them\n# 3: Add braces to all blocks if any block needs braces and remove braces if\n# they can be removed from all blocks, except if all blocks have braces\n# despite none needing them\nmod_full_brace_if_chain = 0 # unsigned number\n\n# Whether to add braces to all blocks of an 'if'/'else if'/'else' chain.\n# If true, mod_full_brace_if_chain will only remove braces from an 'if' that\n# does not have an 'else if' or 'else'.\nmod_full_brace_if_chain_only = false # true/false\n\n# Add or remove braces on single-line 'while' statement.\nmod_full_brace_while = ignore # ignore/add/remove/force\n\n# Add or remove braces on single-line 'using ()' statement.\nmod_full_brace_using = ignore # ignore/add/remove/force\n\n# Don't remove braces around statements that span N newlines\nmod_full_brace_nl = 0 # unsigned number\n\n# Whether to prevent removal of braces from 'if'/'for'/'while'/etc. blocks\n# which span multiple lines.\n#\n# Affects:\n# mod_full_brace_for\n# mod_full_brace_if\n# mod_full_brace_if_chain\n# mod_full_brace_if_chain_only\n# mod_full_brace_while\n# mod_full_brace_using\n#\n# Does not affect:\n# mod_full_brace_do\n# mod_full_brace_function\nmod_full_brace_nl_block_rem_mlcond = false # true/false\n\n# Add or remove unnecessary parentheses on 'return' statement.\nmod_paren_on_return = ignore # ignore/add/remove/force\n\n# Add or remove unnecessary parentheses on 'throw' statement.\nmod_paren_on_throw = ignore # ignore/add/remove/force\n\n# (Pawn) Whether to change optional semicolons to real semicolons.\nmod_pawn_semicolon = false # true/false\n\n# Whether to fully parenthesize Boolean expressions in 'while' and 'if'\n# statement, as in 'if (a && b > c)' => 'if (a && (b > c))'.\nmod_full_paren_if_bool = false # true/false\n\n# Whether to fully parenthesize Boolean expressions after '='\n# statement, as in 'x = a && b > c;' => 'x = (a && (b > c));'.\nmod_full_paren_assign_bool = false # true/false\n\n# Whether to fully parenthesize Boolean expressions after '='\n# statement, as in 'return a && b > c;' => 'return (a && (b > c));'.\nmod_full_paren_return_bool = false # true/false\n\n# Whether to remove superfluous semicolons.\nmod_remove_extra_semicolon = false # true/false\n\n# Whether to remove duplicate include.\nmod_remove_duplicate_include = false # true/false\n\n# the following options (mod_XX_closebrace_comment) use different comment,\n# depending of the setting of the next option.\n# false: Use the c comment (default)\n# true : Use the cpp comment\nmod_add_force_c_closebrace_comment = false # true/false\n\n# If a function body exceeds the specified number of newlines and doesn't have\n# a comment after the close brace, a comment will be added.\nmod_add_long_function_closebrace_comment = 0 # unsigned number\n\n# If a namespace body exceeds the specified number of newlines and doesn't\n# have a comment after the close brace, a comment will be added.\nmod_add_long_namespace_closebrace_comment = 0 # unsigned number\n\n# If a class body exceeds the specified number of newlines and doesn't have a\n# comment after the close brace, a comment will be added.\nmod_add_long_class_closebrace_comment = 0 # unsigned number\n\n# If a switch body exceeds the specified number of newlines and doesn't have a\n# comment after the close brace, a comment will be added.\nmod_add_long_switch_closebrace_comment = 0 # unsigned number\n\n# If an #ifdef body exceeds the specified number of newlines and doesn't have\n# a comment after the #endif, a comment will be added.\nmod_add_long_ifdef_endif_comment = 0 # unsigned number\n\n# If an #ifdef or #else body exceeds the specified number of newlines and\n# doesn't have a comment after the #else, a comment will be added.\nmod_add_long_ifdef_else_comment = 0 # unsigned number\n\n# Whether to take care of the case by the mod_sort_xx options.\nmod_sort_case_sensitive = false # true/false\n\n# Whether to sort consecutive single-line 'import' statements.\nmod_sort_import = false # true/false\n\n# (C#) Whether to sort consecutive single-line 'using' statements.\nmod_sort_using = false # true/false\n\n# Whether to sort consecutive single-line '#include' statements (C/C++) and\n# '#import' statements (Objective-C). Be aware that this has the potential to\n# break your code if your includes/imports have ordering dependencies.\nmod_sort_include = false # true/false\n\n# Whether to prioritize '#include' and '#import' statements that contain\n# filename without extension when sorting is enabled.\nmod_sort_incl_import_prioritize_filename = false # true/false\n\n# Whether to prioritize '#include' and '#import' statements that does not\n# contain extensions when sorting is enabled.\nmod_sort_incl_import_prioritize_extensionless = false # true/false\n\n# Whether to prioritize '#include' and '#import' statements that contain\n# angle over quotes when sorting is enabled.\nmod_sort_incl_import_prioritize_angle_over_quotes = false # true/false\n\n# Whether to ignore file extension in '#include' and '#import' statements\n# for sorting comparison.\nmod_sort_incl_import_ignore_extension = false # true/false\n\n# Whether to group '#include' and '#import' statements when sorting is enabled.\nmod_sort_incl_import_grouping_enabled = false # true/false\n\n# Whether to move a 'break' that appears after a fully braced 'case' before\n# the close brace, as in 'case X: { ... } break;' => 'case X: { ... break; }'.\nmod_move_case_break = false # true/false\n\n# Whether to move a 'return' that appears after a fully braced 'case' before\n# the close brace, as in 'case X: { ... } return;' => 'case X: { ... return; }'.\nmod_move_case_return = false # true/false\n\n# Add or remove braces around a fully braced case statement. Will only remove\n# braces if there are no variable declarations in the block.\nmod_case_brace = ignore # ignore/add/remove/force\n\n# Whether to remove a void 'return;' that appears as the last statement in a\n# function.\nmod_remove_empty_return = false # true/false\n\n# Add or remove the comma after the last value of an enumeration.\nmod_enum_last_comma = ignore # ignore/add/remove/force\n\n# Syntax to use for infinite loops.\n#\n# 0: Leave syntax alone (default)\n# 1: Rewrite as `for(;;)`\n# 2: Rewrite as `while(true)`\n# 3: Rewrite as `do`...`while(true);`\n# 4: Rewrite as `while(1)`\n# 5: Rewrite as `do`...`while(1);`\n#\n# Infinite loops that do not already match one of these syntaxes are ignored.\n# Other options that affect loop formatting will be applied after transforming\n# the syntax.\nmod_infinite_loop = 0 # unsigned number\n\n# Add or remove the 'int' keyword in 'int short'.\nmod_int_short = ignore # ignore/add/remove/force\n\n# Add or remove the 'int' keyword in 'short int'.\nmod_short_int = ignore # ignore/add/remove/force\n\n# Add or remove the 'int' keyword in 'int long'.\nmod_int_long = ignore # ignore/add/remove/force\n\n# Add or remove the 'int' keyword in 'long int'.\nmod_long_int = ignore # ignore/add/remove/force\n\n# Add or remove the 'int' keyword in 'int signed'.\nmod_int_signed = ignore # ignore/add/remove/force\n\n# Add or remove the 'int' keyword in 'signed int'.\nmod_signed_int = ignore # ignore/add/remove/force\n\n# Add or remove the 'int' keyword in 'int unsigned'.\nmod_int_unsigned = ignore # ignore/add/remove/force\n\n# Add or remove the 'int' keyword in 'unsigned int'.\nmod_unsigned_int = ignore # ignore/add/remove/force\n\n# If there is a situation where mod_int_* and mod_*_int would result in\n# multiple int keywords, whether to keep the rightmost int (the default) or the\n# leftmost int.\nmod_int_prefer_int_on_left = false # true/false\n\n# (OC) Whether to organize the properties. If true, properties will be\n# rearranged according to the mod_sort_oc_property_*_weight factors.\nmod_sort_oc_properties = false # true/false\n\n# (OC) Weight of a class property modifier.\nmod_sort_oc_property_class_weight = 0 # number\n\n# (OC) Weight of 'atomic' and 'nonatomic'.\nmod_sort_oc_property_thread_safe_weight = 0 # number\n\n# (OC) Weight of 'readwrite' when organizing properties.\nmod_sort_oc_property_readwrite_weight = 0 # number\n\n# (OC) Weight of a reference type specifier ('retain', 'copy', 'assign',\n# 'weak', 'strong') when organizing properties.\nmod_sort_oc_property_reference_weight = 0 # number\n\n# (OC) Weight of getter type ('getter=') when organizing properties.\nmod_sort_oc_property_getter_weight = 0 # number\n\n# (OC) Weight of setter type ('setter=') when organizing properties.\nmod_sort_oc_property_setter_weight = 0 # number\n\n# (OC) Weight of nullability type ('nullable', 'nonnull', 'null_unspecified',\n# 'null_resettable') when organizing properties.\nmod_sort_oc_property_nullability_weight = 0 # number\n\n#\n# Preprocessor options\n#\n\n# How to use tabs when indenting preprocessor code.\n#\n# -1: Use 'indent_with_tabs' setting (default)\n# 0: Spaces only\n# 1: Indent with tabs to brace level, align with spaces\n# 2: Indent and align with tabs, using spaces when not on a tabstop\n#\n# Default: -1\npp_indent_with_tabs = -1 # number\n\n# Add or remove indentation of preprocessor directives inside #if blocks\n# at brace level 0 (file-level).\npp_indent = ignore # ignore/add/remove/force\n\n# Whether to indent #if/#else/#endif at the brace level. If false, these are\n# indented from column 1.\npp_indent_at_level = false # true/false\n\n# Whether to indent #if/#else/#endif at the parenthesis level if the brace\n# level is 0. If false, these are indented from column 1.\npp_indent_at_level0 = false # true/false\n\n# Specifies the number of columns to indent preprocessors per level\n# at brace level 0 (file-level). If pp_indent_at_level=false, also specifies\n# the number of columns to indent preprocessors per level\n# at brace level > 0 (function-level).\n#\n# Default: 1\npp_indent_count = 1 # unsigned number\n\n# Add or remove space after # based on pp level of #if blocks.\npp_space_after = ignore # ignore/add/remove/force\n\n# Sets the number of spaces per level added with pp_space_after.\npp_space_count = 0 # unsigned number\n\n# The indent for '#region' and '#endregion' in C# and '#pragma region' in\n# C/C++. Negative values decrease indent down to the first column.\npp_indent_region = 0 # number\n\n# Whether to indent the code between #region and #endregion.\npp_region_indent_code = false # true/false\n\n# If pp_indent_at_level=true, sets the indent for #if, #else and #endif when\n# not at file-level. Negative values decrease indent down to the first column.\n#\n# =0: Indent preprocessors using output_tab_size\n# >0: Column at which all preprocessors will be indented\npp_indent_if = 0 # number\n\n# Whether to indent the code between #if, #else and #endif.\npp_if_indent_code = false # true/false\n\n# Whether to indent the body of an #if that encompasses all the code in the file.\npp_indent_in_guard = false # true/false\n\n# Whether to indent '#define' at the brace level. If false, these are\n# indented from column 1.\npp_define_at_level = false # true/false\n\n# Whether to indent '#include' at the brace level.\npp_include_at_level = false # true/false\n\n# Whether to ignore the '#define' body while formatting.\npp_ignore_define_body = false # true/false\n\n# An offset value that controls the indentation of the body of a multiline #define.\n# 'body' refers to all the lines of a multiline #define except the first line.\n# Requires 'pp_ignore_define_body = false'.\n#\n# <0: Absolute column: the body indentation starts off at the specified column\n# (ex. -3 ==> the body is indented starting from column 3)\n# >=0: Relative to the column of the '#' of '#define'\n# (ex. 3 ==> the body is indented starting 3 columns at the right of '#')\n#\n# Default: 8\npp_multiline_define_body_indent = 8 # number\n\n# Whether to indent case statements between #if, #else, and #endif.\n# Only applies to the indent of the preprocessor that the case statements\n# directly inside of.\n#\n# Default: true\npp_indent_case = true # true/false\n\n# Whether to indent whole function definitions between #if, #else, and #endif.\n# Only applies to the indent of the preprocessor that the function definition\n# is directly inside of.\n#\n# Default: true\npp_indent_func_def = true # true/false\n\n# Whether to indent extern C blocks between #if, #else, and #endif.\n# Only applies to the indent of the preprocessor that the extern block is\n# directly inside of.\n#\n# Default: true\npp_indent_extern = true # true/false\n\n# How to indent braces directly inside #if, #else, and #endif.\n# Requires pp_if_indent_code=true and only applies to the indent of the\n# preprocessor that the braces are directly inside of.\n# 0: No extra indent\n# 1: Indent by one level\n# -1: Preserve original indentation\n#\n# Default: 1\npp_indent_brace = 1 # number\n\n# Action to perform when unbalanced #if and #else blocks are found.\n# 0: do nothing\n# 1: print a warning message\n# 2: terminate the program with an error (EX_SOFTWARE)\n#\n# The action will be triggered in the following cases:\n# - if an #ifdef block ends on a different indent level than\n# where it started from. Example:\n#\n# #ifdef TEST\n# int i;\n# {\n# int j;\n# #endif\n#\n# - an #elif/#else block ends on a different indent level than\n# the corresponding #ifdef block. Example:\n#\n# #ifdef TEST\n# int i;\n# #else\n# }\n# int j;\n# #endif\npp_unbalanced_if_action = 0 # unsigned number\n\n#\n# Sort includes options\n#\n\n# The regex for include category with priority 0.\ninclude_category_0 = \"\" # string\n\n# The regex for include category with priority 1.\ninclude_category_1 = \"\" # string\n\n# The regex for include category with priority 2.\ninclude_category_2 = \"\" # string\n\n#\n# Use or Do not Use options\n#\n\n# true: indent_func_call_param will be used (default)\n# false: indent_func_call_param will NOT be used\n#\n# Default: true\nuse_indent_func_call_param = true # true/false\n\n# The value of the indentation for a continuation line is calculated\n# differently if the statement is:\n# - a declaration: your case with QString fileName ...\n# - an assignment: your case with pSettings = new QSettings( ...\n#\n# At the second case the indentation value might be used twice:\n# - at the assignment\n# - at the function call (if present)\n#\n# To prevent the double use of the indentation value, use this option with the\n# value 'true'.\n#\n# true: indent_continue will be used only once\n# false: indent_continue will be used every time (default)\n#\n# Requires indent_ignore_first_continue=false.\nuse_indent_continue_only_once = false # true/false\n\n# The indentation can be:\n# - after the assignment, at the '[' character\n# - at the beginning of the lambda body\n#\n# true: indentation will be at the beginning of the lambda body\n# false: indentation will be after the assignment (default)\nindent_cpp_lambda_only_once = false # true/false\n\n# Whether sp_after_angle takes precedence over sp_inside_fparen. This was the\n# historic behavior, but is probably not the desired behavior, so this is off\n# by default.\nuse_sp_after_angle_always = false # true/false\n\n# Whether to apply special formatting for Qt SIGNAL/SLOT macros. Essentially,\n# this tries to format these so that they match Qt's normalized form (i.e. the\n# result of QMetaObject::normalizedSignature), which can slightly improve the\n# performance of the QObject::connect call, rather than how they would\n# otherwise be formatted.\n#\n# See options_for_QT.cpp for details.\n#\n# Default: true\nuse_options_overriding_for_qt_macros = true # true/false\n\n# If true: the form feed character is removed from the list of whitespace\n# characters. See https://en.cppreference.com/w/cpp/string/byte/isspace.\nuse_form_feed_no_more_as_whitespace_character = false # true/false\n\n#\n# Warn levels - 1: error, 2: warning (default), 3: note\n#\n\n# (C#) Warning is given if doing tab-to-\\t replacement and we have found one\n# in a C# verbatim string literal.\n#\n# Default: 2\nwarn_level_tabs_found_in_verbatim_string_literals = 2 # unsigned number\n\n# Limit the number of loops.\n# Used by uncrustify.cpp to exit from infinite loop.\n# 0: no limit.\ndebug_max_number_of_loops = 0 # number\n\n# Set the number of the line to protocol;\n# Used in the function prot_the_line if the 2. parameter is zero.\n# 0: nothing protocol.\ndebug_line_number_to_protocol = 0 # number\n\n# Set the number of second(s) before terminating formatting the current file,\n# 0: no timeout.\n# only for linux\ndebug_timeout = 0 # number\n\n# Set the number of characters to be printed if the text is too long,\n# 0: do not truncate.\ndebug_truncate = 0 # unsigned number\n\n# sort (or not) the tracking info.\n#\n# Default: true\ndebug_sort_the_tracks = true # true/false\n\n# decode (or not) the flags as a new line.\n# only if the -p option is set.\ndebug_decode_the_flags = false # true/false\n\n# use (or not) the exit(EX_SOFTWARE) function.\n#\n# Default: true\ndebug_use_the_exit_function_pop = true # true/false\n\n# print (or not) the version in the file defined at the command option -o.\ndebug_print_version = false # true/false\n\n# insert the number of the line at the beginning of each line\nset_numbering_for_html_output = false # true/false\n\n# Meaning of the settings:\n# Ignore - do not do any changes\n# Add - makes sure there is 1 or more space/brace/newline/etc\n# Force - makes sure there is exactly 1 space/brace/newline/etc,\n# behaves like Add in some contexts\n# Remove - removes space/brace/newline/etc\n#\n#\n# - Token(s) can be treated as specific type(s) with the 'set' option:\n# `set tokenType tokenString [tokenString...]`\n#\n# Example:\n# `set BOOL __AND__ __OR__`\n#\n# tokenTypes are defined in src/token_enum.h, use them without the\n# 'CT_' prefix: 'CT_BOOL' => 'BOOL'\n#\n#\n# - Token(s) can be treated as type(s) with the 'type' option.\n# `type tokenString [tokenString...]`\n#\n# Example:\n# `type int c_uint_8 Rectangle`\n#\n# This can also be achieved with `set TYPE int c_uint_8 Rectangle`\n#\n#\n# To embed whitespace in tokenStrings use the '\\' escape character, or quote\n# the tokenStrings. These quotes are supported: \"'`\n#\n#\n# - Support for the auto detection of languages through the file ending can be\n# added using the 'file_ext' command.\n# `file_ext langType langString [langString..]`\n#\n# Example:\n# `file_ext CPP .ch .cxx .cpp.in`\n#\n# langTypes are defined in uncrusify_types.h in the lang_flag_e enum, use\n# them without the 'LANG_' prefix: 'LANG_CPP' => 'CPP'\n#\n#\n# - Custom macro-based indentation can be set up using 'macro-open',\n# 'macro-else' and 'macro-close'.\n# `(macro-open | macro-else | macro-close) tokenString`\n#\n# Example:\n# `macro-open BEGIN_TEMPLATE_MESSAGE_MAP`\n# `macro-open BEGIN_MESSAGE_MAP`\n# `macro-close END_MESSAGE_MAP`\n#\n#\n# option(s) with 'not default' value: 0\n#\n" }, { "path": "inst/notebooks/benchmark_mix_vs_sp.R", "content": "# Benchmark: Multi-panel mixture vs single-panel\n#\n# Metrics:\n# ELBO: mixture ELBO vs best single-panel ELBO (should be >=)\n# FDR: fraction of 95% CS NOT containing a causal variable\n# Power: fraction of causal variables covered by at least one 95% CS\n#\n# True model: z ~ N(R_mix %*% beta, sigma2 * R_mix + lambda * I)\n# where R_mix = w1 * R1 + w2 * R2 (true mixture).\n#\n# Usage: Rscript inst/notebooks/benchmark_mix_vs_sp.R\n# Or: source(\"inst/notebooks/benchmark_mix_vs_sp.R\") after devtools::load_all()\n\n# Load from the working tree to pick up uncommitted fixes.\nif (requireNamespace(\"devtools\", quietly = TRUE) &&\n file.exists(\"DESCRIPTION\")) {\n devtools::load_all(\".\", quiet = TRUE)\n} else {\n library(susieR)\n message(\"NOTE: using installed susieR; run from package root for working-tree version\")\n}\n\n# ---------------------------------------------------------------------------\n# Generate X with block-correlated LD structure\n# ---------------------------------------------------------------------------\nmake_block_correlated_X <- function(n, p, rho, block_size = 10) {\n X <- matrix(rnorm(n * p), n, p)\n n_blocks <- p %/% block_size\n for (b in seq_len(n_blocks)) {\n idx <- ((b - 1) * block_size + 1):(b * block_size)\n shared <- rnorm(n)\n X[, idx] <- sqrt(1 - rho) * X[, idx] + sqrt(rho) * shared\n }\n X\n}\n\n# ---------------------------------------------------------------------------\n# CS-based FDR/Power\n# FDR = fraction of 95% CS that do NOT contain any causal variable\n# Power = fraction of causal variables covered by at least one 95% CS\n# ---------------------------------------------------------------------------\ncs_fdr_power <- function(fit, causal_idx) {\n cs_list <- fit$sets$cs\n if (is.null(cs_list) || length(cs_list) == 0)\n return(list(fdr = 0, power = 0, n_cs = 0))\n n_cs <- length(cs_list)\n cs_hits <- sapply(cs_list, function(cs) any(cs %in% causal_idx))\n fdr <- sum(!cs_hits) / n_cs\n covered <- sapply(causal_idx, function(j)\n any(sapply(cs_list, function(cs) j %in% cs)))\n power <- mean(covered)\n list(fdr = fdr, power = power, n_cs = n_cs)\n}\n\n# ---------------------------------------------------------------------------\n# Single scenario runner\n# ---------------------------------------------------------------------------\nrun_scenario <- function(scenario, n_reps = 50) {\n cat(sprintf(\"=== %s (p=%d, tw=%.1f/%.1f, B=%d/%d, rho=%.1f/%.1f, L=%d, sig=%.1f) ===\\n\",\n scenario$name, scenario$p,\n scenario$true_w[1], scenario$true_w[2],\n scenario$B1, scenario$B2,\n scenario$rho1, scenario$rho2,\n scenario$n_signals, scenario$signal_strength))\n\n p <- scenario$p\n n_signals <- scenario$n_signals\n signal_strength <- scenario$signal_strength\n lambda <- scenario$lambda\n max_iter <- scenario$max_iter\n L <- scenario$L\n\n # Accumulators\n mix_ge_sp <- 0\n mix_better <- 0\n safeguard_ct <- 0\n elbo_diffs <- numeric(n_reps)\n omega1_est <- numeric(n_reps)\n\n # Track per-iteration ELBO decreases in mixture fits\n elbo_decrease_ct <- 0 # reps with at least one ELBO decrease\n\n # CS-based FDR/power: rows = reps, cols = methods\n methods <- c(\"sp1\", \"sp2\", \"best_sp\", \"mix\")\n fdr_mat <- matrix(NA, n_reps, 4, dimnames = list(NULL, methods))\n power_mat <- matrix(NA, n_reps, 4, dimnames = list(NULL, methods))\n ncs_mat <- matrix(NA, n_reps, 4, dimnames = list(NULL, methods))\n\n for (rep in seq_len(n_reps)) {\n set.seed(scenario$seed_base + rep)\n\n X1 <- make_block_correlated_X(scenario$B1, p, scenario$rho1)\n X2 <- make_block_correlated_X(scenario$B2, p, scenario$rho2)\n\n R1 <- crossprod(X1) / scenario$B1\n R2 <- crossprod(X2) / scenario$B2\n R_true <- scenario$true_w[1] * R1 + scenario$true_w[2] * R2\n\n beta <- rep(0, p)\n causal <- sample(p, n_signals)\n beta[causal] <- signal_strength * sample(c(-1, 1), n_signals, replace = TRUE)\n z <- as.vector(R_true %*% beta) + rnorm(p, sd = sqrt(lambda))\n\n # Single-panel fits\n fit1 <- susie_rss(z = z, X = X1, L = L,\n\t max_iter = max_iter,\n\t estimate_residual_variance = TRUE, verbose = FALSE)\n fit2 <- susie_rss(z = z, X = X2, L = L,\n\t max_iter = max_iter,\n\t estimate_residual_variance = TRUE, verbose = FALSE)\n best_sp_elbo <- max(tail(fit1$elbo, 1), tail(fit2$elbo, 1))\n best_sp_fit <- if (tail(fit1$elbo, 1) >= tail(fit2$elbo, 1)) fit1 else fit2\n\n # Mixture fit (with all fixes + safeguard)\n fit_mix <- susie_rss(z = z, X = list(X1, X2), L = L,\n\t max_iter = max_iter,\n\t estimate_residual_variance = TRUE, verbose = FALSE,\n check_prior = FALSE)\n mix_elbo <- tail(fit_mix$elbo, 1)\n\n # ELBO tracking\n elbo_diffs[rep] <- mix_elbo - best_sp_elbo\n omega1_est[rep] <- fit_mix$omega_weights[1]\n\n if (mix_elbo >= best_sp_elbo - 1e-6) mix_ge_sp <- mix_ge_sp + 1\n if (mix_elbo > best_sp_elbo + 0.1) mix_better <- mix_better + 1\n if (any(fit_mix$omega_weights > 0.999)) safeguard_ct <- safeguard_ct + 1 # omega collapsed to single panel\n\n # Check for ELBO decreases within the mixture fit\n elbo_traj <- fit_mix$elbo\n if (length(elbo_traj) > 1 && any(diff(elbo_traj) < -1e-6))\n elbo_decrease_ct <- elbo_decrease_ct + 1\n\n # CS-based FDR / Power\n r1 <- cs_fdr_power(fit1, causal)\n r2 <- cs_fdr_power(fit2, causal)\n r_best <- cs_fdr_power(best_sp_fit, causal)\n r_mix <- cs_fdr_power(fit_mix, causal)\n\n fdr_mat[rep, ] <- c(r1$fdr, r2$fdr, r_best$fdr, r_mix$fdr)\n power_mat[rep, ] <- c(r1$power, r2$power, r_best$power, r_mix$power)\n ncs_mat[rep, ] <- c(r1$n_cs, r2$n_cs, r_best$n_cs, r_mix$n_cs)\n\n # Print detail for first 2 reps\n if (rep <= 2) {\n cat(sprintf(\" Rep %d: SP1=%.1f SP2=%.1f | MIX=%.1f (w=%.2f,%.2f)\\n\",\n rep,\n tail(fit1$elbo, 1), tail(fit2$elbo, 1),\n mix_elbo, fit_mix$omega_weights[1], fit_mix$omega_weights[2]))\n cat(sprintf(\" MIX: %d CS, FDR=%.2f, Power=%.2f | bestSP: %d CS, FDR=%.2f, Power=%.2f\\n\",\n r_mix$n_cs, r_mix$fdr, r_mix$power,\n r_best$n_cs, r_best$fdr, r_best$power))\n cat(sprintf(\" ELBO trajectory: %s\\n\",\n paste(round(head(fit_mix$elbo, 8), 1), collapse = \" -> \")))\n }\n }\n\n # Per-scenario summary\n cat(sprintf(\" ELBO: Mix>=SP %d/%d | Better %d/%d | Collapsed %d/%d | ELBO-decrease %d/%d\\n\",\n mix_ge_sp, n_reps, mix_better, n_reps,\n safeguard_ct, n_reps, elbo_decrease_ct, n_reps))\n cat(sprintf(\" diff: mean=%.2f min=%.2f max=%.2f\\n\",\n mean(elbo_diffs), min(elbo_diffs), max(elbo_diffs)))\n cat(sprintf(\" CS-FDR: SP1=%.3f SP2=%.3f bestSP=%.3f MIX=%.3f\\n\",\n mean(fdr_mat[,\"sp1\"]), mean(fdr_mat[,\"sp2\"]),\n mean(fdr_mat[,\"best_sp\"]), mean(fdr_mat[,\"mix\"])))\n cat(sprintf(\" CS-Power: SP1=%.3f SP2=%.3f bestSP=%.3f MIX=%.3f\\n\",\n mean(power_mat[,\"sp1\"]), mean(power_mat[,\"sp2\"]),\n mean(power_mat[,\"best_sp\"]), mean(power_mat[,\"mix\"])))\n cat(sprintf(\" Avg #CS: SP1=%.1f SP2=%.1f bestSP=%.1f MIX=%.1f\\n\",\n mean(ncs_mat[,\"sp1\"]), mean(ncs_mat[,\"sp2\"]),\n mean(ncs_mat[,\"best_sp\"]), mean(ncs_mat[,\"mix\"])))\n if (all(scenario$true_w > 0))\n cat(sprintf(\" True w1=%.1f, est w1: mean=%.2f sd=%.2f\\n\",\n scenario$true_w[1], mean(omega1_est), sd(omega1_est)))\n cat(\"\\n\")\n\n invisible(list(\n name = scenario$name,\n mix_ge_sp = mix_ge_sp, mix_better = mix_better,\n safeguard_ct = safeguard_ct, elbo_decrease_ct = elbo_decrease_ct,\n elbo_diffs = elbo_diffs, omega1_est = omega1_est, n_reps = n_reps,\n fdr_mat = fdr_mat, power_mat = power_mat, ncs_mat = ncs_mat\n ))\n}\n\n# ---------------------------------------------------------------------------\n# Scenario definitions\n# ---------------------------------------------------------------------------\nscenarios <- list(\n\n # --- Stress tests (larger p, stronger signals, more LD structure) ---\n\n list(name = \"equal_mix\",\n p = 200, B1 = 500, B2 = 500, rho1 = 0.7, rho2 = 0.3,\n true_w = c(0.5, 0.5), n_signals = 5, signal_strength = 3.0,\n lambda = 0.1, max_iter = 100, L = 10, seed_base = 10000),\n\n list(name = \"asym_weight\",\n p = 200, B1 = 500, B2 = 500, rho1 = 0.7, rho2 = 0.3,\n true_w = c(0.3, 0.7), n_signals = 5, signal_strength = 3.0,\n lambda = 0.1, max_iter = 100, L = 10, seed_base = 20000),\n\n list(name = \"asym_B\",\n p = 200, B1 = 200, B2 = 800, rho1 = 0.7, rho2 = 0.3,\n true_w = c(0.5, 0.5), n_signals = 5, signal_strength = 3.0,\n lambda = 0.1, max_iter = 100, L = 10, seed_base = 30000),\n\n list(name = \"strong_dense\",\n p = 200, B1 = 500, B2 = 500, rho1 = 0.7, rho2 = 0.3,\n true_w = c(0.5, 0.5), n_signals = 8, signal_strength = 5.0,\n lambda = 0.1, max_iter = 100, L = 10, seed_base = 40000),\n\n list(name = \"one_correct\",\n p = 200, B1 = 500, B2 = 500, rho1 = 0.7, rho2 = 0.3,\n true_w = c(1.0, 0.0), n_signals = 5, signal_strength = 3.0,\n lambda = 0.1, max_iter = 100, L = 10, seed_base = 50000),\n\n list(name = \"extreme_LD\",\n p = 200, B1 = 500, B2 = 500, rho1 = 0.9, rho2 = 0.1,\n true_w = c(0.5, 0.5), n_signals = 5, signal_strength = 3.0,\n lambda = 0.1, max_iter = 100, L = 10, seed_base = 60000),\n\n list(name = \"small_B\",\n p = 200, B1 = 150, B2 = 150, rho1 = 0.7, rho2 = 0.3,\n true_w = c(0.5, 0.5), n_signals = 5, signal_strength = 3.0,\n lambda = 0.1, max_iter = 100, L = 10, seed_base = 70000),\n\n list(name = \"weak_signals\",\n p = 200, B1 = 500, B2 = 500, rho1 = 0.7, rho2 = 0.3,\n true_w = c(0.5, 0.5), n_signals = 5, signal_strength = 1.5,\n lambda = 0.1, max_iter = 100, L = 10, seed_base = 80000),\n\n # --- Smaller-scale sanity checks (from earlier benchmark) ---\n\n list(name = \"small_equal\",\n p = 50, B1 = 200, B2 = 200, rho1 = 0.5, rho2 = 0.3,\n true_w = c(0.5, 0.5), n_signals = 3, signal_strength = 2.0,\n lambda = 0.1, max_iter = 100, L = 10, seed_base = 90000),\n\n list(name = \"small_asym_w\",\n p = 50, B1 = 200, B2 = 200, rho1 = 0.5, rho2 = 0.3,\n true_w = c(0.3, 0.7), n_signals = 3, signal_strength = 2.0,\n lambda = 0.1, max_iter = 100, L = 10, seed_base = 100000),\n\n list(name = \"small_asym_B\",\n p = 50, B1 = 100, B2 = 400, rho1 = 0.5, rho2 = 0.3,\n true_w = c(0.5, 0.5), n_signals = 3, signal_strength = 2.0,\n lambda = 0.1, max_iter = 100, L = 10, seed_base = 110000),\n\n list(name = \"small_one_true\",\n p = 50, B1 = 200, B2 = 200, rho1 = 0.5, rho2 = 0.3,\n true_w = c(1.0, 0.0), n_signals = 3, signal_strength = 2.0,\n lambda = 0.1, max_iter = 100, L = 10, seed_base = 120000)\n)\n\n# ---------------------------------------------------------------------------\n# Run all scenarios\n# ---------------------------------------------------------------------------\nn_reps <- 50\n\ncat(\"================================================================\\n\")\ncat(\"Benchmark: Multi-Panel Mixture vs Single Panel\\n\")\ncat(sprintf(\" %d scenarios x %d reps = %d total runs\\n\",\n length(scenarios), n_reps, length(scenarios) * n_reps))\ncat(\" FDR/Power based on 95%% credible sets\\n\")\ncat(\"================================================================\\n\\n\")\n\nresults <- lapply(scenarios, run_scenario, n_reps = n_reps)\n\n# ---------------------------------------------------------------------------\n# ELBO summary table\n# ---------------------------------------------------------------------------\ncat(\"================================================================\\n\")\ncat(\"ELBO TABLE\\n\")\ncat(\"================================================================\\n\\n\")\ncat(sprintf(\"%-18s %4s %8s %8s %9s %9s %10s %10s\\n\",\n \"Scenario\", \"N\", \"Mix>=SP\", \"Better\", \"Safegrd\", \"ELBOdecr\",\n \"diff_mean\", \"diff_min\"))\ncat(paste(rep(\"-\", 90), collapse = \"\"), \"\\n\")\nfor (r in results) {\n cat(sprintf(\"%-18s %4d %5d/%-2d %5d/%-2d %5d/%-2d %6d/%-2d %10.2f %10.2f\\n\",\n r$name, r$n_reps,\n r$mix_ge_sp, r$n_reps,\n r$mix_better, r$n_reps,\n r$safeguard_ct, r$n_reps,\n r$elbo_decrease_ct, r$n_reps,\n mean(r$elbo_diffs),\n min(r$elbo_diffs)))\n}\ntotal_reps <- sum(sapply(results, \"[[\", \"n_reps\"))\ntotal_pass <- sum(sapply(results, \"[[\", \"mix_ge_sp\"))\ntotal_decr <- sum(sapply(results, \"[[\", \"elbo_decrease_ct\"))\ncat(sprintf(\"\\nOVERALL: %d/%d mixture >= SP | %d/%d had ELBO decrease\\n\",\n total_pass, total_reps, total_decr, total_reps))\n\n# ---------------------------------------------------------------------------\n# FDR table (95% CS)\n# ---------------------------------------------------------------------------\ncat(\"\\n\\n================================================================\\n\")\ncat(\"FDR TABLE (95% Credible Sets)\\n\")\ncat(\" FDR = fraction of CS not containing any causal variable\\n\")\ncat(\"================================================================\\n\\n\")\ncat(sprintf(\"%-18s %8s %8s %8s %8s\\n\",\n \"Scenario\", \"SP1\", \"SP2\", \"bestSP\", \"MIX\"))\ncat(paste(rep(\"-\", 52), collapse = \"\"), \"\\n\")\nfor (r in results) {\n cat(sprintf(\"%-18s %8.3f %8.3f %8.3f %8.3f\\n\",\n r$name,\n mean(r$fdr_mat[,\"sp1\"]),\n mean(r$fdr_mat[,\"sp2\"]),\n mean(r$fdr_mat[,\"best_sp\"]),\n mean(r$fdr_mat[,\"mix\"])))\n}\n\n# ---------------------------------------------------------------------------\n# Power table (95% CS)\n# ---------------------------------------------------------------------------\ncat(\"\\n\\n================================================================\\n\")\ncat(\"POWER TABLE (95% Credible Sets)\\n\")\ncat(\" Power = fraction of causal vars covered by >= 1 CS\\n\")\ncat(\"================================================================\\n\\n\")\ncat(sprintf(\"%-18s %8s %8s %8s %8s\\n\",\n \"Scenario\", \"SP1\", \"SP2\", \"bestSP\", \"MIX\"))\ncat(paste(rep(\"-\", 52), collapse = \"\"), \"\\n\")\nfor (r in results) {\n cat(sprintf(\"%-18s %8.3f %8.3f %8.3f %8.3f\\n\",\n r$name,\n mean(r$power_mat[,\"sp1\"]),\n mean(r$power_mat[,\"sp2\"]),\n mean(r$power_mat[,\"best_sp\"]),\n mean(r$power_mat[,\"mix\"])))\n}\n\n# ---------------------------------------------------------------------------\n# Average number of CS\n# ---------------------------------------------------------------------------\ncat(\"\\n\\n================================================================\\n\")\ncat(\"AVG NUMBER OF CS\\n\")\ncat(\"================================================================\\n\\n\")\ncat(sprintf(\"%-18s %8s %8s %8s %8s\\n\",\n \"Scenario\", \"SP1\", \"SP2\", \"bestSP\", \"MIX\"))\ncat(paste(rep(\"-\", 52), collapse = \"\"), \"\\n\")\nfor (r in results) {\n cat(sprintf(\"%-18s %8.1f %8.1f %8.1f %8.1f\\n\",\n r$name,\n mean(r$ncs_mat[,\"sp1\"]),\n mean(r$ncs_mat[,\"sp2\"]),\n mean(r$ncs_mat[,\"best_sp\"]),\n mean(r$ncs_mat[,\"mix\"])))\n}\n" }, { "path": "inst/notebooks/small_sample_benchmark.ipynb", "content": "{\n \"cells\": [\n {\n \"cell_type\": \"markdown\",\n \"id\": \"1a065c06\",\n \"metadata\": {},\n \"source\": [\n \"# Small-Sample Benchmark SuSiE vs SuSiE-SS\\n\",\n \"\\n\",\n \"We observe in our data analysis that when sample sizes are small\\n\",\n \"relative to the number of variants ($n \\\\ll p$),\\n\",\n \"standard SuSiE can **overfit** by underestimating the residual variance $\\\\sigma^2$.\\n\",\n \"This leads to inflated Bayes factors and spurious credible sets (CS).\\n\",\n \"The Servin-Stephens prior integrates out $\\\\sigma^2$ analytically using a\\n\",\n \"Normal-Inverse-Gamma (NIG) conjugate prior, producing $t$-distributed marginals\\n\",\n \"that are naturally more conservative but calibrated in scenarios including and beyond small samples.\\n\",\n \"\\n\",\n \"In this notebook we show a benchmark focused on the small sample situation, using realistic simulations from\\n\",\n \"eQTL data we analyze.\\n\",\n \"\\n\",\n \"### Data\\n\",\n \"\\n\",\n \"This particular example use real genotype and expression data from the Thyroid FMO2 locus,\\n\",\n \"part of the GTEx project. The dataset contains $n = 574$ samples,\\n\",\n \"$p = 7{,}651$ variants in a 1 Mb window, and 68 covariates\\n\",\n \"(5 genotype PCs, 60 inferred covariates, PCR method, platform, and sex).\\n\",\n \"We first regress covariates out of both $X$ and $y$ on the full cohort,\\n\",\n \"then subsample $N \\\\in \\\\{30, 50, 70, 100\\\\}$ individuals per replicate.\\n\",\n \"\\n\",\n \"### Simulation design\\n\",\n \"\\n\",\n \"To create realistic noise that reproduces the overfitting\\n\",\n \"pattern seen on real data, we:\\n\",\n \"\\n\",\n \"1. Fit **LASSO** (with `lambda.1se` from cross-validation) on the subsampled $(X, y)$\\n\",\n \" to obtain an empirical residual $r = y - X\\\\hat{\\\\beta}_{\\\\text{lasso}}$.\\n\",\n \" LASSO is agnostic of SuSiE vs SuSiE-SS and is a sparse regression method,\\n\",\n \" so it may best approximate the residual variances left that might be similar\\n\",\n \" to what SuSiE and SuSiE-SS will encounter.\\n\",\n \"2. Compute $w = U^{\\\\top} r$, where $U$ contains the left singular vectors\\n\",\n \" of the centered genotype matrix, so each component $w_k$ captures an\\n\",\n \" independent direction of variance along the $k$-th principal axis of $X$.\\n\",\n \" This tells us how the residual is distributed across the directions that the\\n\",\n \" genotype matrix can explain. We expect this projection to be meaningful\\n\",\n \" because the overfitting problem arises precisely because real residual noise\\n\",\n \" concentrates its variance along these same principal axes, making it look\\n\",\n \" like genetic signal to the model.\\n\",\n \"3. Using a wild bootstrap approach, we draw $s_k \\\\in \\\\lbrace -1, +1 \\\\rbrace$\\n\",\n \" independently for each component and form new noise\\n\",\n \" $\\\\tilde{r} = U(w \\\\odot s)$. This random sign flip will break any\\n\",\n \" association between the noise term and any columns in $X$ but will retain\\n\",\n \" the same per-eigencomponent variance profile because\\n\",\n \" $w_k^2 = (\\\\pm w_k)^2$ is unchanged due to sign flip, thus retaining\\n\",\n \" the realistic residual variance structure in the original data.\\n\",\n \"4. The sign-flip noise is rescaled to a target standard deviation calibrated\\n\",\n \" from the full Z-adjusted cohort. We regress $y$ on the top 20 PCs of $X$\\n\",\n \" (on all 574 samples after covariate adjustment) and set\\n\",\n \" `noise_scale = sqrt(1 - R2)`. This captures the fraction of phenotypic\\n\",\n \" variance not explained by genotype and avoids overfitting that would occur\\n\",\n \" if calibration were done on the small subsample.\\n\",\n \"5. Simulate causal signals by randomly drawing columns of $X$ with effect\\n\",\n \" sizes calibrated to a target signal-to-noise ratio `h2_sparse`.\\n\",\n \"\\n\",\n \"### Metrics\\n\",\n \"\\n\",\n \"| Metric | Definition |\\n\",\n \"|--------|------------|\\n\",\n \"| **Power** | (distinct causal variants found in any filtered CS) / (total causal) |\\n\",\n \"| **Coverage** | (filtered CS containing $\\\\geq 1$ causal) / (total filtered CS) |\\n\",\n \"| **CS size** | mean number of variants per filtered CS |\\n\",\n \"| **CS / rep** | total filtered CS / number of replicates |\\n\",\n \"| $\\\\hat{\\\\sigma}^2$ | estimated residual variance (overfitting diagnostic) |\\n\",\n \"| $\\\\sum V$ | sum of estimated prior variances across $L$ effects |\\n\",\n \"\\n\",\n \"### References\\n\",\n \"\\n\",\n \"- Servin, B. & Stephens, M. (2007). *PLoS Genetics*, 3(7): e114.\\n\",\n \"- Denault et al (2025). *bioRxiv* doi:10.1101/2025.05.16.654543.\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": null,\n \"id\": \"59f64421\",\n \"metadata\": {\n \"execution\": {\n \"iopub.execute_input\": \"2026-02-26T01:50:34.101933Z\",\n \"iopub.status.busy\": \"2026-02-26T01:50:34.100590Z\",\n \"iopub.status.idle\": \"2026-02-26T01:50:35.365493Z\",\n \"shell.execute_reply\": \"2026-02-26T01:50:35.364895Z\"\n }\n },\n \"outputs\": [],\n \"source\": [\n \"library(susieR)\\n\",\n \"library(glmnet)\\n\",\n \"library(digest)\\n\",\n \"library(future)\\n\",\n \"library(future.apply)\\n\",\n \"\\n\",\n \"# --- Configuration ---\\n\",\n \"ncores <- max(1, parallelly::availableCores() - 2)\\n\",\n \"n_rep <- 200 # replicates per setting\\n\",\n \"L <- 10\\n\",\n \"N_vals <- c(30, 50, 70, 100)\\n\",\n \"h2_sparse <- c(0.25, 0.50, 0.75)\\n\",\n \"L_causal <- c(1, 2, 3, 4, 5)\\n\",\n \"\\n\",\n \"# Use multisession (PSOCK) to avoid fork + BLAS crashes\\n\",\n \"plan(multisession, workers = ncores)\\n\",\n \"\\n\",\n \"cat(sprintf(\\\"susieR version : %s\\\\n\\\", packageVersion(\\\"susieR\\\")))\\n\",\n \"cat(sprintf(\\\"Workers : %d (multisession / PSOCK)\\\\n\\\", ncores))\\n\",\n \"cat(sprintf(\\\"N values : %s\\\\n\\\", paste(N_vals, collapse = \\\", \\\")))\\n\",\n \"cat(sprintf(\\\"h2_sparse : %s\\\\n\\\", paste(h2_sparse, collapse = \\\", \\\")))\\n\",\n \"cat(sprintf(\\\"n_causal : %s\\\\n\\\", paste(L_causal, collapse = \\\", \\\")))\\n\",\n \"cat(sprintf(\\\"Settings : %d\\\\n\\\", length(N_vals) * length(h2_sparse) * length(L_causal)))\\n\",\n \"cat(sprintf(\\\"Total reps : %d\\\\n\\\",\\n\",\n \" length(N_vals) * length(h2_sparse) * length(L_causal) * n_rep))\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": 2,\n \"id\": \"f545a794\",\n \"metadata\": {\n \"execution\": {\n \"iopub.execute_input\": \"2026-02-26T01:50:35.376293Z\",\n \"iopub.status.busy\": \"2026-02-26T01:50:35.366673Z\",\n \"iopub.status.idle\": \"2026-02-26T01:50:35.688546Z\",\n \"shell.execute_reply\": \"2026-02-26T01:50:35.687791Z\"\n }\n },\n \"outputs\": [\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \"Raw data: n = 574, p = 7651, ncov = 68\\n\"\n ]\n },\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \"var(y_raw) = 0.9827\\n\"\n ]\n },\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \"\\n\",\n \"After Z adjustment (full cohort, n = 574):\\n\"\n ]\n },\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \" var(y_raw) = 0.9827\\n\"\n ]\n },\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \" var(y_adj) = 0.3317\\n\"\n ]\n },\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \" R2(y ~ Z) = 0.6625\\n\"\n ]\n },\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \" n = 574, p = 7651\\n\"\n ]\n }\n ],\n \"source\": [\n \"# --- Load Thyroid FMO2 data ---\\n\",\n \"dat <- readRDS(\\\"Thyroid.FMO2.1Mb.RDS\\\")\\n\",\n \"X_raw <- dat$X # 574 x 7651 integer genotype (0/1/2)\\n\",\n \"y_raw <- dat$y # 574 normalized expression\\n\",\n \"Z <- dat$Z # 574 x 68 covariates\\n\",\n \"\\n\",\n \"cat(sprintf(\\\"Raw data: n = %d, p = %d, ncov = %d\\\\n\\\",\\n\",\n \" nrow(X_raw), ncol(X_raw), ncol(Z)))\\n\",\n \"cat(sprintf(\\\"var(y_raw) = %.4f\\\\n\\\", var(y_raw)))\\n\",\n \"\\n\",\n \"# --- Full-cohort covariate adjustment ---\\n\",\n \"# Regress Z out of both y and X via hat matrix H = Z1 (Z1'Z1)^{-1} Z1'\\n\",\n \"# where Z1 = [1, Z] includes an intercept\\n\",\n \"Z1 <- cbind(1, Z)\\n\",\n \"H <- Z1 %*% solve(crossprod(Z1), t(Z1))\\n\",\n \"\\n\",\n \"y_full <- as.vector(y_raw - H %*% y_raw)\\n\",\n \"X_full <- X_raw - H %*% X_raw\\n\",\n \"\\n\",\n \"# Summary\\n\",\n \"R2_Z <- 1 - var(y_full) / var(y_raw)\\n\",\n \"cat(sprintf(\\\"\\\\nAfter Z adjustment (full cohort, n = %d):\\\\n\\\", length(y_full)))\\n\",\n \"cat(sprintf(\\\" var(y_raw) = %.4f\\\\n\\\", var(y_raw)))\\n\",\n \"cat(sprintf(\\\" var(y_adj) = %.4f\\\\n\\\", var(y_full)))\\n\",\n \"cat(sprintf(\\\" R2(y ~ Z) = %.4f\\\\n\\\", R2_Z))\\n\",\n \"cat(sprintf(\\\" n = %d, p = %d\\\\n\\\", nrow(X_full), ncol(X_full)))\"\n ]\n },\n {\n \"cell_type\": \"markdown\",\n \"id\": \"d812bf07\",\n \"metadata\": {},\n \"source\": [\n \"## Sign-flip noise model\\n\",\n \"\\n\",\n \"The sign-flip (wild bootstrap) procedure generates realistic null noise that preserves the variance structure of LASSO residuals projected onto the principal axes of $X$, while breaking any true genotype-phenotype association. The noise level is calibrated once on the full Z-adjusted cohort using a top-20 PC regression, then applied consistently across all subsample sizes.\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": null,\n \"id\": \"184807a2\",\n \"metadata\": {\n \"execution\": {\n \"iopub.execute_input\": \"2026-02-26T01:50:35.691099Z\",\n \"iopub.status.busy\": \"2026-02-26T01:50:35.690502Z\",\n \"iopub.status.idle\": \"2026-02-26T01:50:36.356752Z\",\n \"shell.execute_reply\": \"2026-02-26T01:50:36.355984Z\"\n }\n },\n \"outputs\": [],\n \"source\": [\n \"# --- Noise calibration on full Z-adjusted data ---\\n\",\n \"Xs_cal <- scale(X_full, center = TRUE, scale = FALSE)\\n\",\n \"svd_cal <- svd(Xs_cal, nu = min(20, nrow(X_full)), nv = 0)\\n\",\n \"PC20 <- svd_cal$u[, 1:min(20, nrow(X_full))]\\n\",\n \"R2_20 <- summary(lm(y_full ~ PC20))$r.squared\\n\",\n \"noise_scale_factor <- sqrt(1 - R2_20)\\n\",\n \"\\n\",\n \"cat(sprintf(\\\"Noise calibration (top-20 PC regression on full Z-adjusted data):\\\\n\\\"))\\n\",\n \"cat(sprintf(\\\" n = %d (full cohort after Z adjustment)\\\\n\\\", nrow(X_full)))\\n\",\n \"cat(sprintf(\\\" R2(20 PCs) = %.4f -> noise_scale = sqrt(1 - R2) = %.4f\\\\n\\\",\\n\",\n \" R2_20, noise_scale_factor))\\n\",\n \"cat(sprintf(\\\" For a subsample with sd(y) = s, noise_sd = s * %.4f\\\\n\\\",\\n\",\n \" noise_scale_factor))\\n\",\n \"\\n\",\n \"# ============================================================\\n\",\n \"# Seed management\\n\",\n \"# ============================================================\\n\",\n \"# Each random operation uses a deterministic seed derived from the\\n\",\n \"# simulation coordinates (rep_id, N, h2, n_causal). This ensures:\\n\",\n \"#\\n\",\n \"# 1. Reproducibility \\u2014 rerunning the same rep_id always yields\\n\",\n \"# identical results.\\n\",\n \"# 2. No collisions \\u2014 different (rep, setting) pairs get different\\n\",\n \"# seeds because each \\\"purpose\\\" uses a different set of prime\\n\",\n \"# multipliers.\\n\",\n \"# 3. Safe extension \\u2014 adding reps 11-200 to an existing 1-10 run\\n\",\n \"# produces genuinely new draws (different rep_ids -> different seeds).\\n\",\n \"# The checkpoint system (below) tracks completed rep_ids and never\\n\",\n \"# reruns them, preventing accidental duplication.\\n\",\n \"\\n\",\n \"make_seed <- function(rep_i, N,\\n\",\n \" purpose = c(\\\"subsample\\\", \\\"flip\\\", \\\"causal\\\"),\\n\",\n \" h2 = 0, nc = 0) {\\n\",\n \" purpose <- match.arg(purpose)\\n\",\n \" base <- switch(purpose,\\n\",\n \" subsample = rep_i * 7919L + N,\\n\",\n \" flip = rep_i * 1009L + N * 17L + nc * 101L + round(h2 * 1000),\\n\",\n \" causal = rep_i * 3331L + N * 23L + nc * 107L + round(h2 * 1000)\\n\",\n \" )\\n\",\n \" as.integer(abs(base) %% (.Machine$integer.max - 1L) + 1L)\\n\",\n \"}\\n\",\n \"\\n\",\n \"# ============================================================\\n\",\n \"# Checkpoint utilities\\n\",\n \"# ============================================================\\n\",\n \"# The checkpoint system uses an MD5 hash of all simulation parameters\\n\",\n \"# (data fingerprint + design settings) to detect configuration changes.\\n\",\n \"# Results are stored per-setting as individual .rds files in outdir.\\n\",\n \"#\\n\",\n \"# Workflow:\\n\",\n \"# 1. compute_config_md5() \\u2014 hash all parameters\\n\",\n \"# 2. checkpoint_init() \\u2014 verify existing results or clear\\n\",\n \"# 3. checkpoint_completed_reps() \\u2014 which rep_ids are done?\\n\",\n \"# 4. checkpoint_save() \\u2014 merge new results, deduplicate\\n\",\n \"# 5. checkpoint_save_meta() \\u2014 write _meta.rds after completion\\n\",\n \"\\n\",\n \"#' Compute MD5 signature of all simulation parameters.\\n\",\n \"#' Any change in data, design, or noise calibration produces a\\n\",\n \"#' different hash, triggering automatic invalidation.\\n\",\n \"compute_config_md5 <- function(X, y, N_vals, h2_sparse, L_causal,\\n\",\n \" L, noise_scale) {\\n\",\n \" nr <- min(50, nrow(X)); nc_dim <- min(50, ncol(X))\\n\",\n \" config <- list(\\n\",\n \" data_nrow = nrow(X),\\n\",\n \" data_ncol = ncol(X),\\n\",\n \" data_corner = sum(X[1:nr, 1:nc_dim]),\\n\",\n \" var_y = round(var(as.vector(y)), 8),\\n\",\n \" noise_scale = round(noise_scale, 8),\\n\",\n \" L = as.integer(L),\\n\",\n \" N_vals = sort(as.integer(N_vals)),\\n\",\n \" h2_sparse = sort(round(h2_sparse, 6)),\\n\",\n \" L_causal = sort(as.integer(L_causal))\\n\",\n \" )\\n\",\n \" md5 <- digest(config, algo = \\\"md5\\\")\\n\",\n \" list(config = config, md5 = md5)\\n\",\n \"}\\n\",\n \"\\n\",\n \"#' Initialize checkpoint directory.\\n\",\n \"#' Returns list(status, meta) where status is \\\"match\\\" or \\\"fresh\\\".\\n\",\n \"#' On mismatch, all existing .rds files are deleted.\\n\",\n \"checkpoint_init <- function(outdir, config_sig) {\\n\",\n \" dir.create(outdir, showWarnings = FALSE, recursive = TRUE)\\n\",\n \" meta_path <- file.path(outdir, \\\"_meta.rds\\\")\\n\",\n \"\\n\",\n \" if (file.exists(meta_path)) {\\n\",\n \" old_meta <- tryCatch(readRDS(meta_path), error = function(e) NULL)\\n\",\n \" if (!is.null(old_meta) && !is.null(old_meta$md5) &&\\n\",\n \" identical(old_meta$md5, config_sig$md5)) {\\n\",\n \" cat(sprintf(\\\"Config MD5 verified: %s\\\\n\\\", config_sig$md5))\\n\",\n \" cat(sprintf(\\\" Previous run: n_rep=%d, timestamp=%s\\\\n\\\",\\n\",\n \" old_meta$n_rep, old_meta$timestamp))\\n\",\n \" return(list(status = \\\"match\\\", meta = old_meta))\\n\",\n \" }\\n\",\n \" old_md5 <- if (!is.null(old_meta$md5)) old_meta$md5 else \\\"(missing/corrupt)\\\"\\n\",\n \" cat(sprintf(\\\"Config MD5 MISMATCH \\u2014 clearing old results.\\\\n\\\"))\\n\",\n \" cat(sprintf(\\\" Old: %s\\\\n New: %s\\\\n\\\", old_md5, config_sig$md5))\\n\",\n \" old_files <- list.files(outdir, pattern = \\\"[.]rds$\\\", full.names = TRUE)\\n\",\n \" if (length(old_files) > 0) {\\n\",\n \" file.remove(old_files)\\n\",\n \" cat(sprintf(\\\" Removed %d old file(s).\\\\n\\\", length(old_files)))\\n\",\n \" }\\n\",\n \" return(list(status = \\\"fresh\\\", meta = NULL))\\n\",\n \" }\\n\",\n \"\\n\",\n \" cat(sprintf(\\\"No existing checkpoint. Config MD5: %s\\\\n\\\", config_sig$md5))\\n\",\n \" list(status = \\\"fresh\\\", meta = NULL)\\n\",\n \"}\\n\",\n \"\\n\",\n \"#' Get sorted vector of completed rep_ids for one setting tag.\\n\",\n \"checkpoint_completed_reps <- function(outdir, tag) {\\n\",\n \" path <- file.path(outdir, paste0(tag, \\\".rds\\\"))\\n\",\n \" if (!file.exists(path)) return(integer(0))\\n\",\n \" tryCatch({\\n\",\n \" x <- readRDS(path)\\n\",\n \" if (is.data.frame(x) && \\\"rep\\\" %in% names(x) && nrow(x) > 0)\\n\",\n \" sort(unique(as.integer(x$rep)))\\n\",\n \" else\\n\",\n \" integer(0)\\n\",\n \" }, error = function(e) integer(0))\\n\",\n \"}\\n\",\n \"\\n\",\n \"#' Load checkpoint data for one setting (NULL if absent/corrupt).\\n\",\n \"checkpoint_load <- function(outdir, tag) {\\n\",\n \" path <- file.path(outdir, paste0(tag, \\\".rds\\\"))\\n\",\n \" if (!file.exists(path)) return(NULL)\\n\",\n \" tryCatch({\\n\",\n \" x <- readRDS(path)\\n\",\n \" if (is.data.frame(x) && nrow(x) > 0 && \\\"rep\\\" %in% names(x)) x\\n\",\n \" else NULL\\n\",\n \" }, error = function(e) NULL)\\n\",\n \"}\\n\",\n \"\\n\",\n \"#' Save new results, merging with existing and deduplicating by rep_id.\\n\",\n \"#' Returns the combined data.frame (invisibly).\\n\",\n \"checkpoint_save <- function(outdir, tag, new_data) {\\n\",\n \" path <- file.path(outdir, paste0(tag, \\\".rds\\\"))\\n\",\n \" existing <- checkpoint_load(outdir, tag)\\n\",\n \" if (!is.null(existing)) {\\n\",\n \" # Safety: remove any pre-existing rows for rep_ids we're about to add\\n\",\n \" overlap <- existing$rep %in% new_data$rep\\n\",\n \" if (any(overlap)) {\\n\",\n \" n_dup <- length(unique(existing$rep[overlap]))\\n\",\n \" warning(sprintf(\\\"%s: deduplicating %d overlapping rep_id(s)\\\", tag, n_dup))\\n\",\n \" existing <- existing[!overlap, ]\\n\",\n \" }\\n\",\n \" combined <- rbind(existing, new_data)\\n\",\n \" } else {\\n\",\n \" combined <- new_data\\n\",\n \" }\\n\",\n \" saveRDS(combined, path)\\n\",\n \" invisible(combined)\\n\",\n \"}\\n\",\n \"\\n\",\n \"#' Write checkpoint metadata after successful completion.\\n\",\n \"checkpoint_save_meta <- function(outdir, config_sig, n_rep) {\\n\",\n \" saveRDS(list(\\n\",\n \" config = config_sig$config,\\n\",\n \" md5 = config_sig$md5,\\n\",\n \" n_rep = n_rep,\\n\",\n \" timestamp = Sys.time()\\n\",\n \" ), file.path(outdir, \\\"_meta.rds\\\"))\\n\",\n \"}\\n\",\n \"\\n\",\n \"# ============================================================\\n\",\n \"# Simulation functions\\n\",\n \"# ============================================================\\n\",\n \"\\n\",\n \"get_lasso_residual <- function(X, y, seed = 42) {\\n\",\n \" set.seed(seed)\\n\",\n \" n <- nrow(X)\\n\",\n \" cv_fit <- cv.glmnet(X, y, alpha = 1, nfolds = min(10, n))\\n\",\n \" lasso_fit <- glmnet(X, y, alpha = 1, lambda = cv_fit$lambda.1se)\\n\",\n \" as.vector(y - predict(lasso_fit, X))\\n\",\n \"}\\n\",\n \"\\n\",\n \"gen_signflip_noise <- function(U, resid, target_sd, seed = 1) {\\n\",\n \" set.seed(seed)\\n\",\n \" r_centered <- resid - mean(resid)\\n\",\n \" proj <- as.vector(crossprod(U, r_centered))\\n\",\n \" k <- length(proj)\\n\",\n \" signs <- sample(c(-1, 1), k, replace = TRUE)\\n\",\n \" noise <- as.vector(U[, 1:k] %*% (proj * signs))\\n\",\n \" noise * target_sd / sd(noise)\\n\",\n \"}\\n\",\n \"\\n\",\n \"run_one_rep <- function(rep_i, n_causal, h2_sp, X, y_real,\\n\",\n \" U_pre = NULL, resid_pre = NULL, L = 10,\\n\",\n \" noise_scale = noise_scale_factor) {\\n\",\n \" suppressWarnings({\\n\",\n \" n <- nrow(X); p <- ncol(X)\\n\",\n \"\\n\",\n \" if (!is.null(U_pre) && !is.null(resid_pre)) {\\n\",\n \" U <- U_pre\\n\",\n \" resid <- resid_pre\\n\",\n \" } else {\\n\",\n \" seed_sub <- make_seed(rep_i, n, \\\"subsample\\\")\\n\",\n \" resid <- get_lasso_residual(X, y_real, seed = seed_sub)\\n\",\n \" Xs <- scale(X, center = TRUE, scale = FALSE)\\n\",\n \" svd_X <- svd(Xs, nu = n, nv = 0)\\n\",\n \" U <- svd_X$u\\n\",\n \" }\\n\",\n \"\\n\",\n \" # Sign-flip noise, scaled to match real data's noise level\\n\",\n \" target_noise_sd <- sd(y_real) * noise_scale\\n\",\n \" seed_flip <- make_seed(rep_i, n, \\\"flip\\\", h2 = h2_sp, nc = n_causal)\\n\",\n \" noise <- gen_signflip_noise(U, resid, target_noise_sd, seed = seed_flip)\\n\",\n \"\\n\",\n \" # Causal signal: h2 = var(signal) / var(y)\\n\",\n \" seed_causal <- make_seed(rep_i, n, \\\"causal\\\", h2 = h2_sp, nc = n_causal)\\n\",\n \" set.seed(seed_causal)\\n\",\n \" causal_idx <- sample(p, n_causal)\\n\",\n \" y <- noise\\n\",\n \" for (j in causal_idx) {\\n\",\n \" bj <- sqrt(h2_sp * var(noise) / ((1 - h2_sp) * n_causal * var(X[, j])))\\n\",\n \" y <- y + X[, j] * bj\\n\",\n \" }\\n\",\n \"\\n\",\n \" # Fit both methods\\n\",\n \" fit_gaus <- tryCatch(\\n\",\n \" susie(X, y, L = L, verbose = FALSE),\\n\",\n \" error = function(e) NULL)\\n\",\n \" fit_ss <- tryCatch(\\n\",\n \" susie(X, y, L = L, estimate_residual_method = \\\"NIG\\\",\\n\",\n \" verbose = FALSE),\\n\",\n \" error = function(e) NULL)\\n\",\n \"\\n\",\n \" extract <- function(fit, tag) {\\n\",\n \" na_row <- data.frame(\\n\",\n \" method = tag, rep = rep_i,\\n\",\n \" discovered = NA_real_, n_true_cs = NA_real_, n_cs = NA_real_,\\n\",\n \" mean_size = NA_real_, sigma2 = NA_real_,\\n\",\n \" mean_V = NA_real_, max_V = NA_real_, sum_V = NA_real_,\\n\",\n \" stringsAsFactors = FALSE)\\n\",\n \" if (is.null(fit)) return(na_row)\\n\",\n \"\\n\",\n \" cs_obj <- susie_get_cs(fit, X = X, min_abs_corr = 0.5)\\n\",\n \" cs <- cs_obj$cs\\n\",\n \" ncs <- length(cs)\\n\",\n \"\\n\",\n \" discovered <- 0; n_true_cs <- 0; avg_size <- NA_real_\\n\",\n \" if (ncs > 0) {\\n\",\n \" discovered <- length(intersect(unique(unlist(cs)), causal_idx))\\n\",\n \" n_true_cs <- sum(sapply(cs, function(s) any(causal_idx %in% s)))\\n\",\n \" avg_size <- mean(sapply(cs, length))\\n\",\n \" }\\n\",\n \"\\n\",\n \" V_vec <- fit$V\\n\",\n \" if (is.null(V_vec)) V_vec <- rep(NA_real_, L)\\n\",\n \" if (length(V_vec) == 1) V_vec <- rep(V_vec, L)\\n\",\n \"\\n\",\n \" data.frame(\\n\",\n \" method = tag,\\n\",\n \" rep = rep_i,\\n\",\n \" discovered = discovered,\\n\",\n \" n_true_cs = n_true_cs,\\n\",\n \" n_cs = ncs,\\n\",\n \" mean_size = avg_size,\\n\",\n \" sigma2 = fit$sigma2,\\n\",\n \" mean_V = mean(V_vec, na.rm = TRUE),\\n\",\n \" max_V = max(V_vec, na.rm = TRUE),\\n\",\n \" sum_V = sum(V_vec, na.rm = TRUE),\\n\",\n \" stringsAsFactors = FALSE)\\n\",\n \" }\\n\",\n \"\\n\",\n \" rbind(extract(fit_gaus, \\\"Gaussian\\\"), extract(fit_ss, \\\"SS\\\"))\\n\",\n \" })\\n\",\n \"}\\n\",\n \"\\n\",\n \"cat(\\\"Functions defined:\\\\n\\\")\\n\",\n \"cat(\\\" Seeds: make_seed(rep_i, N, purpose, h2, nc)\\\\n\\\")\\n\",\n \"cat(\\\" Checkpoint: compute_config_md5, checkpoint_init, checkpoint_completed_reps,\\\\n\\\")\\n\",\n \"cat(\\\" checkpoint_load, checkpoint_save, checkpoint_save_meta\\\\n\\\")\\n\",\n \"cat(\\\" Simulation: get_lasso_residual, gen_signflip_noise, run_one_rep\\\\n\\\")\"\n ]\n },\n {\n \"cell_type\": \"markdown\",\n \"id\": \"e3cabf45\",\n \"metadata\": {},\n \"source\": [\n \"## Run simulation\\n\",\n \"\\n\",\n \"Per-setting results are checkpointed as individual `.rds` files.\\n\",\n \"An MD5 hash of the full configuration (data fingerprint, noise calibration,\\n\",\n \"all design parameters) is stored in `_meta.rds` and verified before every run.\\n\",\n \"\\n\",\n \"**Checkpoint behavior:**\\n\",\n \"- **MD5 matches** \\u2192 existing results are loaded; only new `rep_id`s are computed.\\n\",\n \" Changing `n_rep` from 10 to 200 runs only reps 11\\u2013200.\\n\",\n \"- **MD5 mismatch** \\u2192 all old results are automatically deleted and the\\n\",\n \" simulation starts fresh. This triggers whenever the data, noise calibration,\\n\",\n \" sample sizes, heritabilities, or causal counts change.\\n\",\n \"- `checkpoint_save()` deduplicates by `rep_id` as a safety net against\\n\",\n \" accidental re-runs.\\n\",\n \"\\n\",\n \"**Seed management:**\\n\",\n \"- Each random operation (subsampling, sign-flip, causal placement) uses a\\n\",\n \" deterministic seed derived from `(rep_id, N, h2, n_causal)` via `make_seed()`.\\n\",\n \"- Same `rep_id` always produces the same result (reproducibility).\\n\",\n \"- Different `rep_id`s always produce different draws (no collisions).\\n\",\n \"- The checkpoint tracks which `rep_id`s are complete and never re-runs them.\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": null,\n \"id\": \"3f6af90a\",\n \"metadata\": {\n \"execution\": {\n \"iopub.execute_input\": \"2026-02-26T01:50:36.359175Z\",\n \"iopub.status.busy\": \"2026-02-26T01:50:36.358571Z\",\n \"iopub.status.idle\": \"2026-02-26T01:50:36.453676Z\",\n \"shell.execute_reply\": \"2026-02-26T01:50:36.452682Z\"\n }\n },\n \"outputs\": [],\n \"source\": [\n \"outdir <- \\\"benchmark_results\\\"\\n\",\n \"all_rds <- file.path(outdir, \\\"all_results.rds\\\")\\n\",\n \"\\n\",\n \"# --- Compute and verify config signature ---\\n\",\n \"config_sig <- compute_config_md5(X_full, y_full, N_vals, h2_sparse,\\n\",\n \" L_causal, L, noise_scale_factor)\\n\",\n \"init <- checkpoint_init(outdir, config_sig)\\n\",\n \"\\n\",\n \"# --- Main simulation (incremental) ---\\n\",\n \"all_results <- list()\\n\",\n \"t_total <- proc.time()\\n\",\n \"n_full <- nrow(X_full)\\n\",\n \"ns <- noise_scale_factor\\n\",\n \"any_new <- FALSE\\n\",\n \"\\n\",\n \"for (N in N_vals) {\\n\",\n \" # \\u2500\\u2500 Which rep_ids does ANY setting at this N still need? \\u2500\\u2500\\n\",\n \" # We precompute LASSO+SVD only for these, saving time when extending.\\n\",\n \" needed_reps <- integer(0)\\n\",\n \" for (h2 in h2_sparse) {\\n\",\n \" for (nc in L_causal) {\\n\",\n \" tag <- sprintf(\\\"N%d_h2%03d_nc%d\\\", N, round(h2 * 100), nc)\\n\",\n \" done <- checkpoint_completed_reps(outdir, tag)\\n\",\n \" todo <- setdiff(seq_len(n_rep), done)\\n\",\n \" needed_reps <- union(needed_reps, todo)\\n\",\n \" }\\n\",\n \" }\\n\",\n \" needed_reps <- sort(needed_reps)\\n\",\n \"\\n\",\n \" if (length(needed_reps) == 0) {\\n\",\n \" # Everything cached \\u2014 just load\\n\",\n \" cat(sprintf(\\\"\\\\n=== N = %d: all settings complete, loading ===\\\\n\\\", N))\\n\",\n \" for (h2 in h2_sparse) {\\n\",\n \" for (nc in L_causal) {\\n\",\n \" tag <- sprintf(\\\"N%d_h2%03d_nc%d\\\", N, round(h2 * 100), nc)\\n\",\n \" res <- checkpoint_load(outdir, tag)\\n\",\n \" # Trim to exactly n_rep reps\\n\",\n \" done_ids <- sort(unique(res$rep))\\n\",\n \" if (length(done_ids) > n_rep)\\n\",\n \" res <- res[res$rep %in% done_ids[1:n_rep], ]\\n\",\n \" all_results[[length(all_results) + 1]] <- res\\n\",\n \" }\\n\",\n \" }\\n\",\n \" next\\n\",\n \" }\\n\",\n \"\\n\",\n \" # \\u2500\\u2500 Precompute LASSO + SVD only for needed reps \\u2500\\u2500\\n\",\n \" cat(sprintf(\\\"\\\\n=== N = %d: precomputing %d / %d subsamples ===\\\\n\\\",\\n\",\n \" N, length(needed_reps), n_rep))\\n\",\n \" t_pre <- proc.time()\\n\",\n \"\\n\",\n \" keep_list <- vector(\\\"list\\\", n_rep)\\n\",\n \" U_list <- vector(\\\"list\\\", n_rep)\\n\",\n \" resid_list <- vector(\\\"list\\\", n_rep)\\n\",\n \"\\n\",\n \" for (i in needed_reps) {\\n\",\n \" seed_i <- make_seed(i, N, \\\"subsample\\\")\\n\",\n \" set.seed(seed_i)\\n\",\n \" keep <- sample(n_full, N)\\n\",\n \" keep_list[[i]] <- keep\\n\",\n \" Xi <- X_full[keep, ]\\n\",\n \" yi <- y_full[keep]\\n\",\n \" resid_list[[i]] <- get_lasso_residual(Xi, yi, seed = seed_i)\\n\",\n \" Xs <- scale(Xi, center = TRUE, scale = FALSE)\\n\",\n \" svd_i <- svd(Xs, nu = N, nv = 0)\\n\",\n \" U_list[[i]] <- svd_i$u\\n\",\n \" }\\n\",\n \" cat(sprintf(\\\" Precompute: %.0f sec\\\\n\\\", (proc.time() - t_pre)[3]))\\n\",\n \"\\n\",\n \" # \\u2500\\u2500 Run or extend each setting \\u2500\\u2500\\n\",\n \" for (h2 in h2_sparse) {\\n\",\n \" for (nc in L_causal) {\\n\",\n \" tag <- sprintf(\\\"N%d_h2%03d_nc%d\\\", N, round(h2 * 100), nc)\\n\",\n \" done_reps <- checkpoint_completed_reps(outdir, tag)\\n\",\n \" todo_reps <- sort(setdiff(seq_len(n_rep), done_reps))\\n\",\n \"\\n\",\n \" if (length(todo_reps) == 0) {\\n\",\n \" # Already complete \\u2014 load\\n\",\n \" cat(sprintf(\\\"[DONE] %s (%d reps)\\\\n\\\", tag, length(done_reps)))\\n\",\n \" res <- checkpoint_load(outdir, tag)\\n\",\n \" done_ids <- sort(unique(res$rep))\\n\",\n \" if (length(done_ids) > n_rep)\\n\",\n \" res <- res[res$rep %in% done_ids[1:n_rep], ]\\n\",\n \" all_results[[length(all_results) + 1]] <- res\\n\",\n \" next\\n\",\n \" }\\n\",\n \"\\n\",\n \" if (length(done_reps) > 0) {\\n\",\n \" cat(sprintf(\\\"[EXT] %s: %d -> %d reps ... \\\",\\n\",\n \" tag, length(done_reps), length(done_reps) + length(todo_reps)))\\n\",\n \" } else {\\n\",\n \" cat(sprintf(\\\"[RUN] %s (%d reps) ... \\\", tag, length(todo_reps)))\\n\",\n \" }\\n\",\n \" t0 <- proc.time()\\n\",\n \" any_new <- TRUE\\n\",\n \"\\n\",\n \" new_res <- do.call(rbind, future_lapply(todo_reps, function(i) {\\n\",\n \" run_one_rep(i, nc, h2,\\n\",\n \" X_full[keep_list[[i]], ], y_full[keep_list[[i]]],\\n\",\n \" U_pre = U_list[[i]], resid_pre = resid_list[[i]],\\n\",\n \" L = L, noise_scale = ns)\\n\",\n \" }, future.seed = TRUE))\\n\",\n \" new_res$N <- N\\n\",\n \" new_res$h2_sparse <- h2\\n\",\n \" new_res$n_causal <- nc\\n\",\n \"\\n\",\n \" # Save with dedup, then collect\\n\",\n \" res <- checkpoint_save(outdir, tag, new_res)\\n\",\n \" all_results[[length(all_results) + 1]] <- res\\n\",\n \" cat(sprintf(\\\"done (%.0f sec)\\\\n\\\", (proc.time() - t0)[3]))\\n\",\n \" }\\n\",\n \" }\\n\",\n \"}\\n\",\n \"\\n\",\n \"# --- Finalize ---\\n\",\n \"results <- do.call(rbind, all_results)\\n\",\n \"saveRDS(results, all_rds)\\n\",\n \"checkpoint_save_meta(outdir, config_sig, n_rep)\\n\",\n \"\\n\",\n \"total_settings <- length(N_vals) * length(h2_sparse) * length(L_causal)\\n\",\n \"if (any_new) {\\n\",\n \" cat(sprintf(\\\"\\\\nCompleted: %d rows across %d settings, %.1f min\\\\n\\\",\\n\",\n \" nrow(results), total_settings, (proc.time() - t_total)[3] / 60))\\n\",\n \"} else {\\n\",\n \" cat(sprintf(\\\"\\\\nAll %d settings x %d reps loaded from cache (%d rows)\\\\n\\\",\\n\",\n \" total_settings, n_rep, nrow(results)))\\n\",\n \"}\\n\",\n \"cat(sprintf(\\\"Config MD5: %s\\\\nSaved: %s\\\\n\\\", config_sig$md5, all_rds))\"\n ]\n },\n {\n \"cell_type\": \"markdown\",\n \"id\": \"0711cbfc\",\n \"metadata\": {},\n \"source\": [\n \"## Aggregate results\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": 5,\n \"id\": \"b9dcf67e\",\n \"metadata\": {\n \"execution\": {\n \"iopub.execute_input\": \"2026-02-26T01:50:36.456160Z\",\n \"iopub.status.busy\": \"2026-02-26T01:50:36.455343Z\",\n \"iopub.status.idle\": \"2026-02-26T01:50:36.596256Z\",\n \"shell.execute_reply\": \"2026-02-26T01:50:36.595603Z\"\n }\n },\n \"outputs\": [\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \"Aggregated: 150 rows\\n\",\n \"\\n\"\n ]\n },\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \"method N h2 nc power cover cs/rep size sigma2 sum_V\\n\"\n ]\n },\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \"---------------------------------------------------------------------------------- \\n\"\n ]\n },\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \"Gaussian 30 0.25 1 0.000 0.000 0.00 0.0 0.3548 0.0492\\n\",\n \"SS 30 0.25 1 0.000 0.000 0.00 0.0 0.9885 0.0144\\n\",\n \"Gaussian 30 0.25 2 0.000 0.000 0.00 0.0 0.3524 0.0804\\n\",\n \"SS 30 0.25 2 0.000 0.000 0.00 0.0 0.9383 0.0618\\n\",\n \"Gaussian 30 0.25 3 0.000 0.000 0.10 114.0 0.3595 0.0652\\n\",\n \"SS 30 0.25 3 0.000 0.000 0.10 1.0 0.9507 0.0629\\n\",\n \"Gaussian 30 0.25 4 0.025 1.000 0.10 38.0 0.3594 0.0737\\n\",\n \"SS 30 0.25 4 0.050 1.000 0.10 51.0 0.9465 0.0588\\n\",\n \"Gaussian 30 0.25 5 0.000 0.000 0.00 0.0 0.3946 0.0461\\n\",\n \"SS 30 0.25 5 0.000 0.000 0.00 0.0 0.9937 0.0209\\n\",\n \"Gaussian 30 0.50 1 0.500 1.000 0.50 16.4 0.3096 0.3436\\n\",\n \"SS 30 0.50 1 0.400 1.000 0.40 17.0 0.9013 0.3583\\n\",\n \"Gaussian 30 0.50 2 0.050 0.500 0.20 18.5 0.4310 0.1511\\n\",\n \"SS 30 0.50 2 0.050 1.000 0.10 44.0 0.9558 0.1640\\n\",\n \"Gaussian 30 0.50 3 0.033 0.500 0.20 57.0 0.4689 0.2099\\n\",\n \"SS 30 0.50 3 0.033 1.000 0.10 98.0 0.9008 0.2110\\n\",\n \"Gaussian 30 0.50 4 0.000 0.000 0.00 0.0 0.5539 0.1411\\n\",\n \"SS 30 0.50 4 0.000 0.000 0.00 0.0 0.9414 0.1234\\n\",\n \"Gaussian 30 0.50 5 0.040 0.667 0.30 50.0 0.4545 0.2121\\n\",\n \"SS 30 0.50 5 0.040 0.667 0.30 55.2 0.9480 0.1966\\n\",\n \"Gaussian 30 0.75 1 0.900 0.818 1.10 23.5 0.2857 0.9284\\n\",\n \"SS 30 0.75 1 0.900 0.818 1.10 26.4 0.9149 0.9965\\n\",\n \"Gaussian 30 0.75 2 0.200 1.000 0.40 55.0 0.7479 0.4598\\n\",\n \"SS 30 0.75 2 0.500 0.833 1.20 36.3 0.8881 0.7568\\n\",\n \"Gaussian 30 0.75 3 0.000 0.000 0.10 9.0 0.7925 0.5512\\n\",\n \"SS 30 0.75 3 0.333 0.909 1.10 35.1 0.8612 0.9012\\n\",\n \"Gaussian 30 0.75 4 0.075 0.667 0.30 35.0 0.7472 0.3571\\n\",\n \"SS 30 0.75 4 0.050 0.250 0.40 30.5 0.9647 0.4515\\n\",\n \"Gaussian 30 0.75 5 0.000 0.000 0.00 0.0 0.9627 0.2646\\n\",\n \"SS 30 0.75 5 0.000 0.000 0.10 23.0 0.9031 0.3866\\n\",\n \"Gaussian 50 0.25 1 0.400 0.800 0.50 42.4 0.2792 0.0959\\n\",\n \"SS 50 0.25 1 0.100 0.500 0.20 36.5 0.9503 0.0923\\n\",\n \"Gaussian 50 0.25 2 0.050 1.000 0.10 29.0 0.2984 0.0357\\n\",\n \"SS 50 0.25 2 0.000 0.000 0.00 0.0 0.9930 0.0162\\n\",\n \"Gaussian 50 0.25 3 0.000 0.000 0.00 0.0 0.3112 0.0282\\n\",\n \"SS 50 0.25 3 0.000 0.000 0.00 0.0 0.9744 0.0176\\n\",\n \"Gaussian 50 0.25 4 0.000 0.000 0.00 0.0 0.3148 0.0428\\n\",\n \"SS 50 0.25 4 0.000 0.000 0.00 0.0 0.9804 0.0313\\n\",\n \"Gaussian 50 0.25 5 0.000 0.000 0.00 0.0 0.3183 0.0248\\n\",\n \"SS 50 0.25 5 0.000 0.000 0.00 0.0 0.9564 0.0139\\n\",\n \"Gaussian 50 0.50 1 0.900 0.900 1.00 15.1 0.2538 0.2636\\n\",\n \"SS 50 0.50 1 1.000 1.000 1.00 16.7 0.9277 0.2673\\n\",\n \"Gaussian 50 0.50 2 0.300 1.000 0.60 43.3 0.3392 0.1998\\n\",\n \"SS 50 0.50 2 0.200 1.000 0.40 28.0 0.8777 0.1949\\n\",\n \"Gaussian 50 0.50 3 0.033 0.500 0.20 26.5 0.4075 0.1107\\n\",\n \"SS 50 0.50 3 0.067 1.000 0.20 34.0 0.9443 0.1132\\n\",\n \"Gaussian 50 0.50 4 0.025 1.000 0.10 22.0 0.4229 0.1048\\n\",\n \"SS 50 0.50 4 0.000 0.000 0.00 0.0 0.9089 0.1230\\n\",\n \"Gaussian 50 0.50 5 0.000 0.000 0.10 30.0 0.4312 0.1046\\n\",\n \"SS 50 0.50 5 0.000 0.000 0.10 27.0 0.9386 0.0893\\n\",\n \"Gaussian 50 0.75 1 1.000 0.909 1.10 6.6 0.2515 0.8487\\n\",\n \"SS 50 0.75 1 1.000 0.909 1.10 6.7 0.9099 0.8861\\n\",\n \"Gaussian 50 0.75 2 0.700 1.000 1.40 24.8 0.4038 0.7157\\n\",\n \"SS 50 0.75 2 0.950 0.950 2.00 19.6 0.8456 0.8858\\n\",\n \"Gaussian 50 0.75 3 0.167 0.714 0.70 31.9 0.5996 0.3930\\n\",\n \"SS 50 0.75 3 0.333 0.833 1.20 20.5 0.8834 0.5194\\n\",\n \"Gaussian 50 0.75 4 0.225 0.889 0.90 35.9 0.6118 0.5291\\n\",\n \"SS 50 0.75 4 0.400 0.833 1.80 20.6 0.7905 0.7236\\n\",\n \"Gaussian 50 0.75 5 0.100 0.833 0.60 36.8 0.6291 0.4547\\n\",\n \"SS 50 0.75 5 0.100 0.714 0.70 37.7 0.9247 0.4804\\n\",\n \"Gaussian 80 0.25 1 0.600 1.000 0.60 28.2 0.2611 0.1065\\n\",\n \"SS 80 0.25 1 0.600 1.000 0.60 30.2 0.9336 0.0973\\n\",\n \"Gaussian 80 0.25 2 0.250 1.000 0.50 56.6 0.2843 0.0845\\n\",\n \"SS 80 0.25 2 0.150 0.750 0.40 36.5 0.9195 0.0892\\n\",\n \"Gaussian 80 0.25 3 0.067 1.000 0.20 89.0 0.3009 0.0632\\n\",\n \"SS 80 0.25 3 0.067 1.000 0.20 90.0 0.8980 0.0669\\n\",\n \"Gaussian 80 0.25 4 0.000 0.000 0.10 30.0 0.2949 0.0544\\n\",\n \"SS 80 0.25 4 0.000 0.000 0.10 34.0 0.9421 0.0381\\n\",\n \"Gaussian 80 0.25 5 0.000 0.000 0.00 0.0 0.3067 0.0277\\n\",\n \"SS 80 0.25 5 0.000 0.000 0.00 0.0 0.9648 0.0162\\n\",\n \"Gaussian 80 0.50 1 1.000 1.000 1.00 17.0 0.2579 0.2698\\n\",\n \"SS 80 0.50 1 1.000 1.000 1.00 17.7 0.9116 0.2729\\n\",\n \"Gaussian 80 0.50 2 0.600 1.000 1.20 21.5 0.2772 0.2060\\n\",\n \"SS 80 0.50 2 0.600 0.923 1.30 28.3 0.8533 0.2110\\n\",\n \"Gaussian 80 0.50 3 0.433 0.929 1.40 32.7 0.3041 0.2599\\n\",\n \"SS 80 0.50 3 0.467 0.933 1.50 30.8 0.8257 0.2854\\n\",\n \"Gaussian 80 0.50 4 0.150 0.833 0.60 26.9 0.3662 0.1682\\n\",\n \"SS 80 0.50 4 0.125 0.571 0.70 34.1 0.8593 0.1838\\n\",\n \"Gaussian 80 0.50 5 0.080 0.667 0.60 22.9 0.3730 0.1622\\n\",\n \"SS 80 0.50 5 0.060 0.600 0.50 21.6 0.8765 0.1570\\n\",\n \"Gaussian 80 0.75 1 1.000 1.000 1.00 4.7 0.2544 0.7452\\n\",\n \"SS 80 0.75 1 1.000 1.000 1.00 5.0 0.8956 0.7553\\n\",\n \"Gaussian 80 0.75 2 1.000 1.000 2.00 17.8 0.2589 0.7821\\n\",\n \"SS 80 0.75 2 1.000 1.000 2.00 17.5 0.8198 0.8006\\n\",\n \"Gaussian 80 0.75 3 0.800 0.889 2.70 31.6 0.2832 0.8133\\n\",\n \"SS 80 0.75 3 0.900 0.931 2.90 24.8 0.7295 0.8457\\n\",\n \"Gaussian 80 0.75 4 0.625 0.926 2.70 25.2 0.3933 0.6343\\n\",\n \"SS 80 0.75 4 0.650 0.839 3.10 22.2 0.7387 0.7104\\n\",\n \"Gaussian 80 0.75 5 0.420 0.875 2.40 33.4 0.4467 0.5773\\n\",\n \"SS 80 0.75 5 0.520 0.867 3.00 21.3 0.7128 0.7192\\n\",\n \"Gaussian 120 0.25 1 0.900 1.000 0.90 15.4 0.2832 0.1210\\n\",\n \"SS 120 0.25 1 0.900 1.000 0.90 16.0 0.8931 0.1145\\n\",\n \"Gaussian 120 0.25 2 0.200 0.667 0.60 33.6 0.3196 0.0771\\n\",\n \"SS 120 0.25 2 0.150 0.600 0.50 41.7 0.8975 0.0719\\n\",\n \"Gaussian 120 0.25 3 0.067 0.667 0.30 18.3 0.3153 0.0803\\n\",\n \"SS 120 0.25 3 0.067 0.667 0.30 18.3 0.8969 0.0719\\n\",\n \"Gaussian 120 0.25 4 0.100 1.000 0.30 65.0 0.3403 0.0916\\n\",\n \"SS 120 0.25 4 0.100 1.000 0.30 67.7 0.8850 0.0897\\n\",\n \"Gaussian 120 0.25 5 0.060 0.750 0.40 28.2 0.3080 0.0747\\n\",\n \"SS 120 0.25 5 0.040 0.667 0.30 23.3 0.9096 0.0619\\n\",\n \"Gaussian 120 0.50 1 0.900 0.900 1.00 11.3 0.2829 0.3406\\n\",\n \"SS 120 0.50 1 0.900 0.900 1.00 11.6 0.9004 0.3385\\n\",\n \"Gaussian 120 0.50 2 0.900 0.947 1.90 11.0 0.2910 0.3074\\n\",\n \"SS 120 0.50 2 0.900 0.947 1.90 11.4 0.8295 0.3099\\n\",\n \"Gaussian 120 0.50 3 0.767 0.920 2.50 16.0 0.3004 0.2663\\n\",\n \"SS 120 0.50 3 0.800 0.923 2.60 16.0 0.7698 0.2687\\n\",\n \"Gaussian 120 0.50 4 0.500 0.833 2.40 28.6 0.3304 0.2843\\n\",\n \"SS 120 0.50 4 0.550 0.846 2.60 29.4 0.7332 0.2988\\n\",\n \"Gaussian 120 0.50 5 0.240 0.800 1.50 32.5 0.3810 0.2403\\n\",\n \"SS 120 0.50 5 0.280 0.778 1.80 39.0 0.7369 0.2632\\n\",\n \"Gaussian 120 0.75 1 1.000 1.000 1.00 2.6 0.2822 0.9560\\n\",\n \"SS 120 0.75 1 1.000 1.000 1.00 2.6 0.9080 0.9646\\n\",\n \"Gaussian 120 0.75 2 0.950 0.950 2.00 10.1 0.2855 0.9066\\n\",\n \"SS 120 0.75 2 0.950 0.950 2.00 10.1 0.8121 0.9149\\n\",\n \"Gaussian 120 0.75 3 0.967 0.967 3.00 11.8 0.2873 0.8667\\n\",\n \"SS 120 0.75 3 0.967 0.967 3.00 11.8 0.7551 0.8784\\n\",\n \"Gaussian 120 0.75 4 0.900 0.900 4.00 10.9 0.2893 0.9612\\n\",\n \"SS 120 0.75 4 0.875 0.897 3.90 8.8 0.6696 0.9916\\n\",\n \"Gaussian 120 0.75 5 0.840 0.913 4.60 12.3 0.3234 0.8059\\n\",\n \"SS 120 0.75 5 0.880 0.936 4.70 12.8 0.6356 0.8142\\n\",\n \"Gaussian 200 0.25 1 0.900 1.000 0.90 4.7 0.2628 0.1010\\n\",\n \"SS 200 0.25 1 0.900 1.000 0.90 4.7 0.8614 0.0943\\n\",\n \"Gaussian 200 0.25 2 0.900 0.947 1.90 32.5 0.2629 0.1123\\n\",\n \"SS 200 0.25 2 0.900 1.000 1.80 37.8 0.8019 0.1058\\n\",\n \"Gaussian 200 0.25 3 0.433 0.867 1.50 24.4 0.2801 0.0901\\n\",\n \"SS 200 0.25 3 0.467 0.778 1.80 16.9 0.7260 0.1001\\n\",\n \"Gaussian 200 0.25 4 0.150 0.600 1.00 23.2 0.2853 0.0935\\n\",\n \"SS 200 0.25 4 0.200 0.667 1.20 30.9 0.7289 0.1040\\n\",\n \"Gaussian 200 0.25 5 0.180 0.800 1.00 61.7 0.3001 0.0900\\n\",\n \"SS 200 0.25 5 0.180 0.615 1.30 54.8 0.7085 0.0930\\n\",\n \"Gaussian 200 0.50 1 1.000 1.000 1.00 8.1 0.2602 0.2946\\n\",\n \"SS 200 0.50 1 1.000 1.000 1.00 7.9 0.8746 0.2890\\n\",\n \"Gaussian 200 0.50 2 0.900 0.857 2.10 15.1 0.2601 0.2799\\n\",\n \"SS 200 0.50 2 0.950 0.950 2.00 15.4 0.7852 0.2852\\n\",\n \"Gaussian 200 0.50 3 0.867 0.897 2.90 12.7 0.2691 0.3097\\n\",\n \"SS 200 0.50 3 0.933 0.933 3.00 12.9 0.7355 0.3154\\n\",\n \"Gaussian 200 0.50 4 0.800 0.842 3.80 17.6 0.2630 0.2855\\n\",\n \"SS 200 0.50 4 0.850 0.895 3.80 13.5 0.6648 0.2901\\n\",\n \"Gaussian 200 0.50 5 0.600 0.833 3.60 20.8 0.2824 0.2796\\n\",\n \"SS 200 0.50 5 0.700 0.833 4.20 18.7 0.5515 0.2996\\n\",\n \"Gaussian 200 0.75 1 0.900 0.900 1.00 6.3 0.2625 0.8121\\n\",\n \"SS 200 0.75 1 0.900 0.900 1.00 6.5 0.9204 0.8088\\n\",\n \"Gaussian 200 0.75 2 0.950 0.864 2.20 8.1 0.2581 0.8527\\n\",\n \"SS 200 0.75 2 0.950 0.864 2.20 8.1 0.7703 0.8553\\n\",\n \"Gaussian 200 0.75 3 0.967 1.000 2.90 8.1 0.2702 0.9140\\n\",\n \"SS 200 0.75 3 0.967 1.000 2.90 8.3 0.7229 0.9178\\n\",\n \"Gaussian 200 0.75 4 1.000 1.000 4.00 12.5 0.2693 0.7982\\n\",\n \"SS 200 0.75 4 1.000 0.976 4.10 12.2 0.6519 0.8058\\n\",\n \"Gaussian 200 0.75 5 0.960 0.941 5.10 12.0 0.2643 0.8823\\n\",\n \"SS 200 0.75 5 0.960 0.941 5.10 11.4 0.5335 0.8937\\n\"\n ]\n }\n ],\n \"source\": [\n \"# Ensure numeric types\\n\",\n \"for (col in c(\\\"discovered\\\", \\\"n_true_cs\\\", \\\"n_cs\\\", \\\"mean_size\\\",\\n\",\n \" \\\"sigma2\\\", \\\"mean_V\\\", \\\"max_V\\\", \\\"sum_V\\\",\\n\",\n \" \\\"N\\\", \\\"h2_sparse\\\", \\\"n_causal\\\")) {\\n\",\n \" if (col %in% names(results))\\n\",\n \" results[[col]] <- as.numeric(results[[col]])\\n\",\n \"}\\n\",\n \"\\n\",\n \"# Aggregate across replicates\\n\",\n \"groups <- unique(results[, c(\\\"method\\\", \\\"N\\\", \\\"h2_sparse\\\", \\\"n_causal\\\")])\\n\",\n \"agg_list <- vector(\\\"list\\\", nrow(groups))\\n\",\n \"\\n\",\n \"for (gi in seq_len(nrow(groups))) {\\n\",\n \" m <- groups$method[gi]\\n\",\n \" nn <- groups$N[gi]\\n\",\n \" h2 <- groups$h2_sparse[gi]\\n\",\n \" nc <- groups$n_causal[gi]\\n\",\n \" df <- results[results$method == m & results$N == nn &\\n\",\n \" results$h2_sparse == h2 & results$n_causal == nc, ]\\n\",\n \" if (nrow(df) == 0) next\\n\",\n \"\\n\",\n \" nr <- nrow(df)\\n\",\n \" total_causal <- nc * nr\\n\",\n \" s <- function(x) sum(x, na.rm = TRUE)\\n\",\n \" mn <- function(x) mean(x, na.rm = TRUE)\\n\",\n \"\\n\",\n \" agg_list[[gi]] <- data.frame(\\n\",\n \" method = m,\\n\",\n \" N = nn,\\n\",\n \" h2_sparse = h2,\\n\",\n \" n_causal = nc,\\n\",\n \" power = s(df$discovered) / total_causal,\\n\",\n \" coverage = ifelse(s(df$n_cs) > 0, s(df$n_true_cs) / s(df$n_cs), NA),\\n\",\n \" total_cs = s(df$n_cs),\\n\",\n \" cs_size = mn(df$mean_size),\\n\",\n \" mean_sigma2 = mn(df$sigma2),\\n\",\n \" mean_V = mn(df$mean_V),\\n\",\n \" max_V = mn(df$max_V),\\n\",\n \" sum_V = mn(df$sum_V),\\n\",\n \" stringsAsFactors = FALSE)\\n\",\n \"}\\n\",\n \"\\n\",\n \"agg <- do.call(rbind, agg_list)\\n\",\n \"rownames(agg) <- NULL\\n\",\n \"\\n\",\n \"# Factor columns for plotting\\n\",\n \"agg$BF <- factor(agg$method, levels = c(\\\"SS\\\", \\\"Gaussian\\\"))\\n\",\n \"agg$L <- agg$n_causal\\n\",\n \"agg$n <- agg$N\\n\",\n \"agg$cs_per_rep <- agg$total_cs / n_rep\\n\",\n \"\\n\",\n \"cat(sprintf(\\\"Aggregated: %d rows\\\\n\\\\n\\\", nrow(agg)))\\n\",\n \"\\n\",\n \"# Print summary table\\n\",\n \"cat(sprintf(\\\"%-10s %3s %5s %3s %6s %6s %6s %6s %8s %8s\\\\n\\\",\\n\",\n \" \\\"method\\\", \\\"N\\\", \\\"h2\\\", \\\"nc\\\", \\\"power\\\", \\\"cover\\\", \\\"cs/rep\\\", \\\"size\\\", \\\"sigma2\\\", \\\"sum_V\\\"))\\n\",\n \"cat(paste(rep(\\\"-\\\", 82), collapse = \\\"\\\"), \\\"\\\\n\\\")\\n\",\n \"for (i in seq_len(nrow(agg))) {\\n\",\n \" a <- agg[i, ]\\n\",\n \" cat(sprintf(\\\"%-10s %3d %5.2f %3d %6.3f %6.3f %6.2f %6.1f %8.4f %8.4f\\\\n\\\",\\n\",\n \" a$method, a$N, a$h2_sparse, a$n_causal,\\n\",\n \" a$power,\\n\",\n \" ifelse(is.na(a$coverage), 0, a$coverage),\\n\",\n \" a$cs_per_rep,\\n\",\n \" ifelse(is.na(a$cs_size), 0, a$cs_size),\\n\",\n \" a$mean_sigma2,\\n\",\n \" a$sum_V))\\n\",\n \"}\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": 6,\n \"id\": \"b4129cd6\",\n \"metadata\": {\n \"execution\": {\n \"iopub.execute_input\": \"2026-02-26T01:50:36.598116Z\",\n \"iopub.status.busy\": \"2026-02-26T01:50:36.597625Z\",\n \"iopub.status.idle\": \"2026-02-26T01:50:36.625088Z\",\n \"shell.execute_reply\": \"2026-02-26T01:50:36.624478Z\"\n }\n },\n \"outputs\": [\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \"Plot theme set.\\n\"\n ]\n }\n ],\n \"source\": [\n \"library(ggplot2)\\n\",\n \"library(cowplot)\\n\",\n \"library(gridExtra)\\n\",\n \"library(grid)\\n\",\n \"\\n\",\n \"figdir <- \\\"benchmark_results\\\"\\n\",\n \"\\n\",\n \"methods_colors <- c(\\\"SS\\\" = \\\"#D41159\\\", \\\"Gaussian\\\" = \\\"#1A85FF\\\")\\n\",\n \"\\n\",\n \"perf_theme <- theme_cowplot(font_size = 16) +\\n\",\n \" theme(\\n\",\n \" legend.position = \\\"none\\\",\\n\",\n \" panel.grid.major.y = element_line(color = \\\"gray80\\\"),\\n\",\n \" panel.grid.major.x = element_blank(),\\n\",\n \" panel.grid.minor = element_blank(),\\n\",\n \" axis.line = element_line(linewidth = 1, color = \\\"black\\\"),\\n\",\n \" axis.ticks = element_line(linewidth = 1, color = \\\"black\\\"),\\n\",\n \" axis.ticks.length = unit(0.25, \\\"cm\\\"),\\n\",\n \" plot.margin = margin(t = 2, r = 2, b = 2, l = 2, unit = \\\"mm\\\"),\\n\",\n \" axis.text = element_text(size = 14, face = \\\"bold\\\"),\\n\",\n \" axis.title = element_text(size = 16, face = \\\"bold\\\"),\\n\",\n \" plot.title = element_text(size = 16, face = \\\"bold\\\")\\n\",\n \" )\\n\",\n \"dot_size <- 4\\n\",\n \"cat(\\\"Plot theme set.\\\\n\\\")\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": 7,\n \"id\": \"177d7260\",\n \"metadata\": {\n \"execution\": {\n \"iopub.execute_input\": \"2026-02-26T01:50:36.627107Z\",\n \"iopub.status.busy\": \"2026-02-26T01:50:36.626651Z\",\n \"iopub.status.idle\": \"2026-02-26T01:50:42.131843Z\",\n \"shell.execute_reply\": \"2026-02-26T01:50:42.131168Z\"\n }\n },\n \"outputs\": [\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \"Saved: benchmark_h2025.{pdf,png}\\n\",\n \"Saved: benchmark_h2050.{pdf,png}\\n\",\n \"Saved: benchmark_h2075.{pdf,png}\\n\"\n ]\n }\n ],\n \"source\": [\n \"# --- Replace NA/NaN with 0 so every dot is plotted ---\\n\",\n \"agg$coverage_plot <- ifelse(is.na(agg$coverage), 0, agg$coverage)\\n\",\n \"agg$cs_size_plot <- ifelse(is.na(agg$cs_size) | is.nan(agg$cs_size), 0, agg$cs_size)\\n\",\n \"\\n\",\n \"# Dodge width: horizontally separate the two methods\\n\",\n \"dodge <- position_dodge(width = 0.4)\\n\",\n \"\\n\",\n \"for (h2 in h2_sparse) {\\n\",\n \" d <- agg[agg$h2_sparse == h2, ]\\n\",\n \"\\n\",\n \" plots <- list()\\n\",\n \" for (ni in seq_along(N_vals)) {\\n\",\n \" nn <- N_vals[ni]\\n\",\n \" dd <- d[d$N == nn, ]\\n\",\n \" ylab_fn <- function(lab) if (ni == 1) lab else \\\"\\\"\\n\",\n \"\\n\",\n \" # \\u2500\\u2500 Coverage (use coverage_plot: NA \\u2192 0) \\u2500\\u2500\\n\",\n \" p_cov <- ggplot(dd, aes(x = as.factor(L), y = coverage_plot, col = BF)) +\\n\",\n \" geom_point(size = dot_size, position = dodge) +\\n\",\n \" geom_hline(yintercept = 0.95, linetype = \\\"dashed\\\", linewidth = 1) +\\n\",\n \" scale_color_manual(values = methods_colors) +\\n\",\n \" coord_cartesian(ylim = c(-0.02, 1.02)) +\\n\",\n \" ylab(ylab_fn(\\\"Coverage\\\")) + xlab(\\\"\\\") + perf_theme\\n\",\n \" plots[[paste0(\\\"cov_\\\", nn)]] <- p_cov\\n\",\n \"\\n\",\n \" # \\u2500\\u2500 Power (linear scale, 0 shown at bottom) \\u2500\\u2500\\n\",\n \" p_pow <- ggplot(dd, aes(x = as.factor(L), y = power, col = BF)) +\\n\",\n \" geom_point(size = dot_size, position = dodge) +\\n\",\n \" scale_color_manual(values = methods_colors) +\\n\",\n \" coord_cartesian(ylim = c(-0.02, 1.02)) +\\n\",\n \" ylab(ylab_fn(\\\"Power\\\")) + xlab(\\\"\\\") + perf_theme\\n\",\n \" plots[[paste0(\\\"pow_\\\", nn)]] <- p_pow\\n\",\n \"\\n\",\n \" # \\u2500\\u2500 CS per replicate \\u2500\\u2500\\n\",\n \" p_ncs <- ggplot(dd, aes(x = as.factor(L), y = cs_per_rep, col = BF)) +\\n\",\n \" geom_point(size = dot_size, position = dodge) +\\n\",\n \" scale_color_manual(values = methods_colors) +\\n\",\n \" coord_cartesian(ylim = c(-0.05, max(agg$cs_per_rep, na.rm = TRUE) * 1.05)) +\\n\",\n \" ylab(ylab_fn(\\\"CS / replicate\\\")) + xlab(\\\"\\\") + perf_theme\\n\",\n \" plots[[paste0(\\\"ncs_\\\", nn)]] <- p_ncs\\n\",\n \"\\n\",\n \" # \\u2500\\u2500 CS size (use cs_size_plot: NaN \\u2192 0) \\u2500\\u2500\\n\",\n \" cs_max <- max(agg$cs_size_plot, na.rm = TRUE)\\n\",\n \" p_size <- ggplot(dd, aes(x = as.factor(L), y = cs_size_plot, col = BF)) +\\n\",\n \" geom_point(size = dot_size, position = dodge) +\\n\",\n \" scale_color_manual(values = methods_colors) +\\n\",\n \" coord_cartesian(ylim = c(-0.5, cs_max * 1.05)) +\\n\",\n \" ylab(ylab_fn(\\\"CS size\\\")) + xlab(\\\"\\\") + perf_theme\\n\",\n \" plots[[paste0(\\\"size_\\\", nn)]] <- p_size\\n\",\n \"\\n\",\n \" # \\u2500\\u2500 sum V (prior variance diagnostic) \\u2500\\u2500\\n\",\n \" p_sumv <- ggplot(dd, aes(x = as.factor(L), y = sum_V, col = BF)) +\\n\",\n \" geom_point(size = dot_size, position = dodge) +\\n\",\n \" scale_color_manual(values = methods_colors) +\\n\",\n \" coord_cartesian(ylim = c(-0.01, max(agg$sum_V, na.rm = TRUE) * 1.05)) +\\n\",\n \" ylab(ylab_fn(expression(Sigma~V))) + xlab(\\\"\\\") + perf_theme\\n\",\n \" plots[[paste0(\\\"sumv_\\\", nn)]] <- p_sumv\\n\",\n \"\\n\",\n \" # \\u2500\\u2500 sigma2 \\u2500\\u2500\\n\",\n \" p_sig <- ggplot(dd, aes(x = as.factor(L), y = mean_sigma2, col = BF)) +\\n\",\n \" geom_point(size = dot_size, position = dodge) +\\n\",\n \" scale_color_manual(values = methods_colors) +\\n\",\n \" coord_cartesian(ylim = c(-0.01, max(agg$mean_sigma2, na.rm = TRUE) * 1.1)) +\\n\",\n \" ylab(ylab_fn(expression(hat(sigma)^2))) +\\n\",\n \" xlab(\\\"Number of causal variants\\\") + perf_theme\\n\",\n \" plots[[paste0(\\\"sig_\\\", nn)]] <- p_sig\\n\",\n \" }\\n\",\n \"\\n\",\n \" # Column headers\\n\",\n \" titles <- lapply(N_vals, function(nn)\\n\",\n \" textGrob(label = paste0(\\\"N = \\\", nn),\\n\",\n \" gp = gpar(fontsize = 16, fontface = \\\"bold\\\")))\\n\",\n \"\\n\",\n \" metric_rows <- c(\\\"cov\\\", \\\"pow\\\", \\\"ncs\\\", \\\"size\\\", \\\"sumv\\\", \\\"sig\\\")\\n\",\n \" plot_grobs <- lapply(metric_rows, function(r)\\n\",\n \" lapply(N_vals, function(nn) plots[[paste0(r, \\\"_\\\", nn)]]))\\n\",\n \" plot_grobs <- do.call(c, plot_grobs)\\n\",\n \"\\n\",\n \" n_cols <- length(N_vals)\\n\",\n \" fig <- arrangeGrob(\\n\",\n \" arrangeGrob(grobs = titles, ncol = n_cols),\\n\",\n \" arrangeGrob(grobs = plot_grobs, ncol = n_cols, nrow = 6),\\n\",\n \" heights = c(0.04, 1),\\n\",\n \" top = textGrob(sprintf(\\\"h2_sparse = %d%%\\\", round(h2 * 100)),\\n\",\n \" gp = gpar(fontsize = 18, fontface = \\\"bold\\\")))\\n\",\n \"\\n\",\n \" fn <- sprintf(\\\"benchmark_h2%03d\\\", round(h2 * 100))\\n\",\n \" pdf(file.path(figdir, paste0(fn, \\\".pdf\\\")), width = 26, height = 20)\\n\",\n \" grid.draw(fig); dev.off()\\n\",\n \" png(file.path(figdir, paste0(fn, \\\".png\\\")), width = 26, height = 20,\\n\",\n \" units = \\\"in\\\", res = 150)\\n\",\n \" grid.draw(fig); dev.off()\\n\",\n \" cat(sprintf(\\\"Saved: %s.{pdf,png}\\\\n\\\", fn))\\n\",\n \"}\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": 8,\n \"id\": \"ebd9214a\",\n \"metadata\": {\n \"execution\": {\n \"iopub.execute_input\": \"2026-02-26T01:50:42.133533Z\",\n \"iopub.status.busy\": \"2026-02-26T01:50:42.133062Z\",\n \"iopub.status.idle\": \"2026-02-26T01:50:42.192191Z\",\n \"shell.execute_reply\": \"2026-02-26T01:50:42.191600Z\"\n }\n },\n \"outputs\": [\n {\n \"data\": {\n \"text/html\": [\n \"agg_record_497274838: 2\"\n ],\n \"text/latex\": [\n \"\\\\textbf{agg\\\\textbackslash{}\\\\_record\\\\textbackslash{}\\\\_497274838:} 2\"\n ],\n \"text/markdown\": [\n \"**agg_record_497274838:** 2\"\n ],\n \"text/plain\": [\n \"agg_record_497274838 \\n\",\n \" 2 \"\n ]\n },\n \"metadata\": {},\n \"output_type\": \"display_data\"\n },\n {\n \"data\": {\n \"text/html\": [\n \"agg_record_497274838: 2\"\n ],\n \"text/latex\": [\n \"\\\\textbf{agg\\\\textbackslash{}\\\\_record\\\\textbackslash{}\\\\_497274838:} 2\"\n ],\n \"text/markdown\": [\n \"**agg_record_497274838:** 2\"\n ],\n \"text/plain\": [\n \"agg_record_497274838 \\n\",\n \" 2 \"\n ]\n },\n \"metadata\": {},\n \"output_type\": \"display_data\"\n },\n {\n \"name\": \"stdout\",\n \"output_type\": \"stream\",\n \"text\": [\n \"Saved: benchmark_legend.{pdf,png}\\n\"\n ]\n }\n ],\n \"source\": [\n \"# --- Standalone legend ---\\n\",\n \"legend_df <- data.frame(\\n\",\n \" x = c(1, 1), y = c(1, 2),\\n\",\n \" grp = factor(c(\\\"SS (Servin-Stephens)\\\", \\\"Gaussian (standard)\\\"),\\n\",\n \" levels = c(\\\"SS (Servin-Stephens)\\\", \\\"Gaussian (standard)\\\")))\\n\",\n \"legend_colors <- c(\\\"SS (Servin-Stephens)\\\" = \\\"#D41159\\\",\\n\",\n \" \\\"Gaussian (standard)\\\" = \\\"#1A85FF\\\")\\n\",\n \"p_leg <- ggplot(legend_df, aes(x, y, col = grp)) +\\n\",\n \" geom_point(size = 5) +\\n\",\n \" scale_color_manual(values = legend_colors, name = \\\"Method\\\") +\\n\",\n \" theme_void() +\\n\",\n \" theme(legend.position = \\\"bottom\\\",\\n\",\n \" legend.text = element_text(size = 14, face = \\\"bold\\\"),\\n\",\n \" legend.title = element_text(size = 16, face = \\\"bold\\\"))\\n\",\n \"legend_grob <- cowplot::get_legend(p_leg)\\n\",\n \"\\n\",\n \"pdf(file.path(figdir, \\\"benchmark_legend.pdf\\\"), width = 8, height = 1)\\n\",\n \"grid::grid.draw(legend_grob); dev.off()\\n\",\n \"png(file.path(figdir, \\\"benchmark_legend.png\\\"), width = 8, height = 1,\\n\",\n \" units = \\\"in\\\", res = 150)\\n\",\n \"grid::grid.draw(legend_grob); dev.off()\\n\",\n \"cat(\\\"Saved: benchmark_legend.{pdf,png}\\\\n\\\")\"\n ]\n },\n {\n \"cell_type\": \"markdown\",\n \"id\": \"4328be95\",\n \"metadata\": {},\n \"source\": [\n \"## Results\\n\",\n \"\\n\",\n \"*Results will be summarized here after reviewing the simulation output.*\\n\",\n \"\\n\",\n \"## How to run\\n\",\n \"\\n\",\n \"From the `inst/notebooks/` directory:\\n\",\n \"\\n\",\n \"```bash\\n\",\n \"jupyter nbconvert --to notebook --execute \\\\\\n\",\n \" --ExecutePreprocessor.timeout=0 \\\\\\n\",\n \" --output small_sample_benchmark_executed.ipynb \\\\\\n\",\n \" small_sample_benchmark.ipynb\\n\",\n \"```\\n\",\n \"\\n\",\n \"The `--ExecutePreprocessor.timeout=0` flag disables the cell timeout so the\\n\",\n \"simulation can run as long as needed. With 60 settings x 200 replicates and\\n\",\n \"10 parallel workers, expect roughly 4-8 hours on a modern machine.\\n\",\n \"\\n\",\n \"The simulation is **incremental**: existing results in `benchmark_results/`\\n\",\n \"are preserved and only new replicates are computed. To extend from 200 to 400\\n\",\n \"replicates, change `n_rep` in the config cell and re-run. To start fresh\\n\",\n \"(e.g., after switching to a different dataset), either delete\\n\",\n \"`benchmark_results/_meta.rds` or simply change the data file; the config\\n\",\n \"signature check will detect the mismatch and clear old results automatically.\"\n ]\n }\n ],\n \"metadata\": {\n \"kernelspec\": {\n \"display_name\": \"R\",\n \"language\": \"R\",\n \"name\": \"ir\"\n },\n \"language_info\": {\n \"codemirror_mode\": \"r\",\n \"file_extension\": \".r\",\n \"mimetype\": \"text/x-r-source\",\n \"name\": \"R\",\n \"pygments_lexer\": \"r\",\n \"version\": \"4.4.3\"\n }\n },\n \"nbformat\": 4,\n \"nbformat_minor\": 5\n}" }, { "path": "inst/notebooks/stochastic_ld_benchmark.ipynb", "content": "{\n \"cells\": [\n {\n \"cell_type\": \"markdown\",\n \"metadata\": {},\n \"source\": \"# Stochastic LD Correction Benchmark\\n\\n## Does the SER variance inflation correction control FDR when using stochastic LD?\\n\\nWhen individual-level genotype data is unavailable, SuSiE-RSS can use a **stochastic LD sketch** to approximate the LD matrix. The sketch is formed by random projection:\\n\\n$$\\\\hat{R} = \\\\frac{1}{B} U U^\\\\top, \\\\quad U = X_{\\\\text{std}}^\\\\top W, \\\\quad W \\\\sim N(0, I_B / n)$$\\n\\nwhere $X_{\\\\text{std}}$ is the column-standardized genotype matrix ($n \\\\times p$) and $B$ is the sketch size.\\n\\nHowever, the noise in $\\\\hat{R}$ inflates the variance of the SER residuals under the null, leading to **elevated false discovery rate (FDR)** if uncorrected. The `stochastic_ld_sample` parameter in `susie_rss()` activates a dynamic variance inflation correction in the single-effect regression (SER) that accounts for this noise at every IBSS iteration.\\n\\nThis notebook benchmarks the correction across different sketch sizes $B \\\\in \\\\{2000, 5000, 10000\\\\}$, comparing:\\n1. **Gold standard** -- in-sample LD ($R = \\\\text{cor}(X)$)\\n2. **Subsample** -- $R$ from a subsample of $B$ individuals\\n3. **Stochastic sketch, no correction** -- sketch $U$ passed as `X`, no `stochastic_ld_sample`\\n4. **Stochastic sketch, with correction** -- sketch $U$ passed as `X`, `stochastic_ld_sample = B`\\n5. **Stochastic sketch + NIG prior, with correction** -- sketch $U$ with `estimate_residual_method = \\\"NIG\\\"` and `stochastic_ld_sample = B`\\n\\nMethod 5 uses the Normal-Inverse-Gamma (NIG) prior which integrates out the residual variance $\\\\sigma^2$ analytically, producing t-distributed marginals instead of Gaussian. This tests whether the NIG prior interacts properly with the stochastic LD variance inflation correction.\"\n },\n {\n \"cell_type\": \"markdown\",\n \"metadata\": {},\n \"source\": [\n \"## Background: Stochastic LD Sketch\\n\",\n \"\\n\",\n \"Given a standardized genotype matrix $X_{\\\\text{std}} \\\\in \\\\mathbb{R}^{n \\\\times p}$, the true LD matrix is:\\n\",\n \"\\n\",\n \"$$R = \\\\frac{1}{n-1} X_{\\\\text{std}}^\\\\top X_{\\\\text{std}}$$\\n\",\n \"\\n\",\n \"The stochastic sketch approximates $R$ using a random projection matrix $W \\\\in \\\\mathbb{R}^{n \\\\times B}$ with $W_{ij} \\\\sim N(0, 1/n)$:\\n\",\n \"\\n\",\n \"$$U = X_{\\\\text{std}}^\\\\top W \\\\in \\\\mathbb{R}^{p \\\\times B}$$\\n\",\n \"\\n\",\n \"Each column of $U$ is approximately drawn from $N(0, R)$, so $\\\\hat{R} = U U^\\\\top / B \\\\to R$ as $B \\\\to \\\\infty$.\\n\",\n \"\\n\",\n \"In `susie_rss()`, we pass `X = t(U)` (a $B \\\\times p$ matrix) and the function treats it as a \\\"genotype-like\\\" input whose cross-product approximates the LD structure.\"\n ]\n },\n {\n \"cell_type\": \"markdown\",\n \"metadata\": {},\n \"source\": \"## SER Variance Inflation Correction\\n\\nIn each IBSS iteration, the SER computes a residual for variant $j$ after removing the effect of the $l$-th single effect:\\n\\n$$\\\\hat{r}_j = z_j - \\\\hat{R}_{j,:} \\\\bar{\\\\beta}_{-l}$$\\n\\nUnder the null $H_0: \\\\beta_j = 0$, the variance of $\\\\hat{r}_j$ when using the noisy sketch $\\\\hat{R}$ is:\\n\\n$$\\\\tau_j^2 = \\\\sigma^2 + \\\\frac{\\\\eta_j^2 + v_g}{B}$$\\n\\nwhere:\\n- $\\\\sigma^2$ is the current residual variance estimate (updated each IBSS iteration),\\n- $\\\\eta_j = \\\\hat{R}_{j,:} \\\\bar{\\\\beta}_{-l}$ is the predicted effect at variant $j$ from other effects,\\n- $v_g = \\\\bar{\\\\beta}_{-l}^\\\\top \\\\hat{R} \\\\bar{\\\\beta}_{-l}$ is the total genetic variance from other effects.\\n\\nThe inflation factor $\\\\tau_j^2 / \\\\sigma^2 = 1 + (\\\\eta_j^2 + v_g) / (B \\\\sigma^2)$ is **dynamic**: it depends on the current IBSS state and is recomputed at every iteration for every single-effect regression. This means the correction is strongest near active signals (where $\\\\eta_j^2$ is large due to LD) and vanishes under the global null ($\\\\bar{\\\\beta}_{-l} = 0$).\\n\\nSetting `stochastic_ld_sample = B` in `susie_rss()` activates this correction.\"\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": null,\n \"metadata\": {},\n \"outputs\": [],\n \"source\": \"# ============================================================\\n# Setup: parameters and logging\\n# ============================================================\\nlibrary(susieR)\\n\\nif (requireNamespace(\\\"Rfast\\\", quietly = TRUE)) {\\n library(Rfast)\\n fast_cor <- Rfast::cora\\n cat(\\\"Using Rfast::cora for correlation matrices (much faster)\\\\n\\\")\\n} else {\\n fast_cor <- cor\\n cat(\\\"Rfast not available, using base cor() (consider installing Rfast)\\\\n\\\")\\n}\\n\\n# --- Simulation parameters ---\\np <- 5000\\nn <- 100000\\nn_causal <- 4\\npve_per <- 0.0012 # PVE per causal\\nB_values <- c(2000, 5000, 10000)\\nn_rep <- 50 # set to 250 for full run\\nL <- 10\\nseed <- 999\\n\\n# --- Log file for monitoring progress from the terminal ---\\n# When running via jupyter nbconvert, cat() output is captured into the\\n# notebook and NOT shown on screen. To monitor progress, open a second\\n# terminal and run: tail -f stochastic_ld_benchmark.log\\nLOG_FILE <- \\\"stochastic_ld_benchmark.log\\\"\\nlog_con <- file(LOG_FILE, open = \\\"w\\\")\\n\\nlog_msg <- function(fmt, ...) {\\n msg <- sprintf(paste0(\\\"[%s] \\\", fmt, \\\"\\\\n\\\"), format(Sys.time(), \\\"%H:%M:%S\\\"), ...)\\n cat(msg) # notebook cell output\\n cat(msg, file = log_con) # log file for tail -f\\n flush(log_con)\\n}\\n\\nset.seed(seed)\\nlog_msg(\\\"Stochastic LD Benchmark started\\\")\\nlog_msg(\\\" susieR version: %s\\\", packageVersion(\\\"susieR\\\"))\\nlog_msg(\\\" Parameters: p=%d, n=%d, n_causal=%d, pve_per=%.4f, n_rep=%d\\\",\\n p, n, n_causal, pve_per, n_rep)\\nlog_msg(\\\" B values: %s\\\", paste(B_values, collapse = \\\", \\\"))\\nlog_msg(\\\" Log file: %s (run 'tail -f %s' to monitor)\\\", LOG_FILE, LOG_FILE)\"\n },\n {\n \"cell_type\": \"markdown\",\n \"metadata\": {},\n \"source\": [\n \"## Function Definitions\\n\",\n \"\\n\",\n \"All simulation functions are defined here. The main execution cell below calls them.\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": null,\n \"metadata\": {},\n \"outputs\": [],\n \"source\": \"# ============================================================\\n# Function: build_ld_structure\\n# Build block-diagonal AR(1) LD structure\\n# Returns: list with blocks, block_membership, n_blocks\\n# ============================================================\\nbuild_ld_structure <- function(p, seed = 42) {\\n set.seed(seed)\\n blocks <- list()\\n block_membership <- integer(p)\\n pos <- 1\\n block_id <- 0\\n while (pos <= p) {\\n block_id <- block_id + 1\\n bsize <- min(sample(20:50, 1), p - pos + 1)\\n rho <- runif(1, 0.4, 0.98)\\n idx <- pos:(pos + bsize - 1)\\n block_membership[idx] <- block_id\\n R_block <- rho^abs(outer(1:bsize, 1:bsize, \\\"-\\\"))\\n blocks[[block_id]] <- list(idx = idx, R = R_block, rho = rho, size = bsize)\\n pos <- pos + bsize\\n }\\n list(blocks = blocks, block_membership = block_membership, n_blocks = block_id)\\n}\\n\\n# ============================================================\\n# Function: generate_genotypes\\n# Generate X (n x p) with block-diagonal LD, standardize columns,\\n# compute true in-sample R = cor(X).\\n# Returns: list(X, R_true)\\n# ============================================================\\ngenerate_genotypes <- function(n, ld_struct, seed = 43) {\\n set.seed(seed)\\n p <- sum(sapply(ld_struct$blocks, function(b) b$size))\\n log_msg(\\\" Allocating X (%d x %d), ~%.1f GB\\\", n, p, n * p * 8 / 1e9)\\n X <- matrix(0, nrow = n, ncol = p)\\n n_blocks <- length(ld_struct$blocks)\\n for (b in seq_along(ld_struct$blocks)) {\\n block <- ld_struct$blocks[[b]]\\n L_chol <- chol(block$R)\\n Z <- matrix(rnorm(n * block$size), nrow = n, ncol = block$size)\\n X[, block$idx] <- Z %*% L_chol\\n if (b %% 25 == 0 || b == n_blocks)\\n log_msg(\\\" Block %d/%d done (variants %d-%d)\\\",\\n b, n_blocks, min(block$idx), max(block$idx))\\n }\\n log_msg(\\\" Standardizing columns...\\\")\\n X <- scale(X)\\n attr(X, \\\"scaled:center\\\") <- NULL\\n attr(X, \\\"scaled:scale\\\") <- NULL\\n log_msg(\\\" Computing R = fast_cor(X) [%d x %d]...\\\", p, p)\\n R_true <- fast_cor(X)\\n list(X = X, R_true = R_true)\\n}\\n\\n# ============================================================\\n# Function: compute_ld_approximations\\n# For each B, compute stochastic sketch and subsample R.\\n# Returns: list(sketches, R_subs)\\n# ============================================================\\ncompute_ld_approximations <- function(X, B_values, seed = 44) {\\n set.seed(seed)\\n n <- nrow(X); p <- ncol(X)\\n sketches <- list()\\n R_subs <- list()\\n for (B in B_values) {\\n Bstr <- as.character(B)\\n log_msg(\\\" B=%d: generating sketch W(%d x %d), U = X'W (%d x %d)...\\\",\\n B, n, B, p, B)\\n t0 <- proc.time()\\n W <- matrix(rnorm(n * B, sd = 1 / sqrt(n)), nrow = n, ncol = B)\\n U <- crossprod(X, W)\\n sketches[[Bstr]] <- t(U)\\n rm(W, U)\\n log_msg(\\\" Sketch done in %.1f sec (%d x %d)\\\",\\n (proc.time() - t0)[3], nrow(sketches[[Bstr]]), ncol(sketches[[Bstr]]))\\n log_msg(\\\" B=%d: computing subsample R from %d individuals...\\\", B, B)\\n t0 <- proc.time()\\n R_subs[[Bstr]] <- fast_cor(X[sample(n, B), ])\\n log_msg(\\\" Subsample R done in %.1f sec\\\", (proc.time() - t0)[3])\\n }\\n list(sketches = sketches, R_subs = R_subs)\\n}\\n\\n# ============================================================\\n# Function: simulate_phenotype\\n# Pick causal variants from different blocks, generate y.\\n# ============================================================\\nsimulate_phenotype <- function(X, ld_struct, n_causal, pve_per) {\\n n <- nrow(X); p <- ncol(X)\\n causal_blocks <- sample(ld_struct$n_blocks, n_causal)\\n causal_idx <- sapply(causal_blocks, function(b) sample(ld_struct$blocks[[b]]$idx, 1))\\n total_pve <- pve_per * n_causal\\n sigma_e2 <- 1 - total_pve\\n beta_j <- sqrt(pve_per * sigma_e2 / (1 - total_pve))\\n beta <- rep(0, p)\\n beta[causal_idx] <- beta_j\\n y <- as.vector(X %*% beta + rnorm(n, sd = sqrt(sigma_e2)))\\n list(y = y, causal_idx = causal_idx, beta = beta)\\n}\\n\\n# ============================================================\\n# Function: compute_zscores\\n# Marginal z-scores via individual-level univariate regressions.\\n# ============================================================\\ncompute_zscores <- function(X, y) {\\n n <- nrow(X); p <- ncol(X)\\n z <- numeric(p)\\n for (j in seq_len(p)) {\\n fit <- .lm.fit(cbind(1, X[, j]), y)\\n bhat <- fit$coefficients[2]\\n rss <- sum(fit$residuals^2)\\n se <- sqrt(rss / (n - 2)) / sqrt(sum((X[, j] - mean(X[, j]))^2))\\n z[j] <- bhat / se\\n }\\n z\\n}\\n\\n# ============================================================\\n# Function: evaluate_fit\\n# Extract CS, return RAW COUNTS for proper aggregation.\\n# FDR and power are computed from accumulated counts across replicates.\\n# ============================================================\\nevaluate_fit <- function(fit, true_causal) {\\n cs <- susie_get_cs(fit)$cs\\n n_cs <- length(cs)\\n if (n_cs == 0) {\\n return(list(n_cs = 0, n_true_cs = 0, n_false_cs = 0,\\n n_found = 0, n_causal = length(true_causal), mean_size = 0))\\n }\\n n_true_cs <- sum(sapply(cs, function(s) any(true_causal %in% s)))\\n n_false_cs <- n_cs - n_true_cs\\n n_found <- sum(sapply(true_causal, function(c)\\n any(sapply(cs, function(s) c %in% s))))\\n list(n_cs = n_cs, n_true_cs = n_true_cs, n_false_cs = n_false_cs,\\n n_found = n_found, n_causal = length(true_causal),\\n mean_size = mean(sapply(cs, length)))\\n}\\n\\n# ============================================================\\n# Function: run_one_method\\n# Run susie_rss with given inputs, evaluate, return one-row df.\\n# ============================================================\\nrun_one_method <- function(method_name, z, causal_idx, n, L, ...) {\\n t0 <- proc.time()\\n fit <- tryCatch(\\n susie_rss(z = z, n = n, L = L, max_iter = 200, verbose = FALSE, ...),\\n error = function(e) { log_msg(\\\" %s ERROR: %s\\\", method_name, e$message); NULL }\\n )\\n if (is.null(fit)) return(NULL)\\n ev <- evaluate_fit(fit, causal_idx)\\n elapsed <- (proc.time() - t0)[3]\\n # Compute per-replicate rates for the log line\\n rep_power <- ev$n_found / ev$n_causal\\n rep_fdr <- if (ev$n_cs > 0) ev$n_false_cs / ev$n_cs else 0\\n log_msg(\\\" %-25s %5.1fs | power=%.2f fdr=%.2f n_cs=%d size=%.0f\\\",\\n method_name, elapsed, rep_power, rep_fdr, ev$n_cs, ev$mean_size)\\n data.frame(method = method_name,\\n n_cs = ev$n_cs, n_true_cs = ev$n_true_cs, n_false_cs = ev$n_false_cs,\\n n_found = ev$n_found, n_causal = ev$n_causal,\\n mean_size = ev$mean_size,\\n stringsAsFactors = FALSE)\\n}\\n\\n# ============================================================\\n# Function: summarize_results\\n# Aggregate raw counts across replicates, compute FDR and power.\\n# ============================================================\\nsummarize_results <- function(results) {\\n methods <- unique(results$method)\\n # Order methods logically\\n method_order <- c(\\\"insample_R\\\")\\n for (B in B_values) {\\n method_order <- c(method_order,\\n paste0(\\\"subsample_B\\\", B),\\n paste0(\\\"stoch_B\\\", B, \\\"_nocorr\\\"),\\n paste0(\\\"stoch_B\\\", B, \\\"_corr\\\"),\\n paste0(\\\"stoch_B\\\", B, \\\"_NIG_corr\\\"))\\n }\\n methods <- method_order[method_order %in% methods]\\n\\n summary_rows <- list()\\n for (m in methods) {\\n rows <- results[results$method == m, ]\\n total_cs <- sum(rows$n_cs)\\n total_false_cs <- sum(rows$n_false_cs)\\n total_found <- sum(rows$n_found)\\n total_causal <- sum(rows$n_causal)\\n # Weighted mean CS size (weight by n_cs per replicate)\\n if (total_cs > 0) {\\n avg_size <- sum(rows$mean_size * rows$n_cs) / total_cs\\n } else {\\n avg_size <- 0\\n }\\n summary_rows[[length(summary_rows) + 1]] <- data.frame(\\n method = m,\\n total_cs = total_cs,\\n total_false_cs = total_false_cs,\\n total_found = total_found,\\n total_causal = total_causal,\\n FDR = if (total_cs > 0) total_false_cs / total_cs else 0,\\n power = total_found / total_causal,\\n mean_size = avg_size,\\n n_rep = nrow(rows),\\n stringsAsFactors = FALSE\\n )\\n }\\n do.call(rbind, summary_rows)\\n}\\n\\n# ============================================================\\n# Function: run_simulation\\n# Main loop: for each replicate, simulate phenotype, compute z,\\n# run all methods, collect results. Print final summary.\\n# ============================================================\\nrun_simulation <- function(X, R_true, sketches, R_subs, ld_struct,\\n B_values, n_rep, n_causal, pve_per, L, seed) {\\n set.seed(seed)\\n n <- nrow(X)\\n results <- list()\\n rep_times <- numeric()\\n t_total <- proc.time()\\n\\n for (rep_i in seq_len(n_rep)) {\\n eta_str <- \\\"\\\"\\n if (rep_i > 1) {\\n eta_min <- mean(rep_times) * (n_rep - rep_i + 1) / 60\\n eta_str <- sprintf(\\\" (ETA: %.0f min)\\\", eta_min)\\n }\\n log_msg(\\\"=== Replicate %d / %d ===%s\\\", rep_i, n_rep, eta_str)\\n t_rep <- proc.time()\\n\\n # Simulate phenotype\\n sim <- simulate_phenotype(X, ld_struct, n_causal, pve_per)\\n log_msg(\\\" Causal variants: %s\\\", paste(sim$causal_idx, collapse = \\\", \\\"))\\n\\n # Compute z-scores\\n t_z <- proc.time()\\n log_msg(\\\" Computing z-scores (%d variants)...\\\", ncol(X))\\n z <- compute_zscores(X, sim$y)\\n log_msg(\\\" z-scores done in %.1f sec, max|z|=%.2f\\\",\\n (proc.time() - t_z)[3], max(abs(z)))\\n\\n # Gold standard\\n row <- run_one_method(\\\"insample_R\\\", z, sim$causal_idx, n, L, R = R_true)\\n if (!is.null(row)) { row$rep <- rep_i; results[[length(results) + 1]] <- row }\\n\\n # For each B\\n for (B in B_values) {\\n Bstr <- as.character(B)\\n # Subsample\\n row <- run_one_method(sprintf(\\\"subsample_B%d\\\", B), z, sim$causal_idx,\\n n, L, R = R_subs[[Bstr]])\\n if (!is.null(row)) { row$rep <- rep_i; results[[length(results) + 1]] <- row }\\n # Stochastic, no correction\\n row <- run_one_method(sprintf(\\\"stoch_B%d_nocorr\\\", B), z, sim$causal_idx,\\n n, L, X = sketches[[Bstr]])\\n if (!is.null(row)) { row$rep <- rep_i; results[[length(results) + 1]] <- row }\\n # Stochastic, with correction\\n row <- run_one_method(sprintf(\\\"stoch_B%d_corr\\\", B), z, sim$causal_idx,\\n n, L, X = sketches[[Bstr]], stochastic_ld_sample = B)\\n if (!is.null(row)) { row$rep <- rep_i; results[[length(results) + 1]] <- row }\\n # Stochastic + NIG prior, with correction\\n row <- run_one_method(sprintf(\\\"stoch_B%d_NIG_corr\\\", B), z, sim$causal_idx,\\n n, L, X = sketches[[Bstr]], stochastic_ld_sample = B,\\n estimate_residual_method = \\\"NIG\\\")\\n if (!is.null(row)) { row$rep <- rep_i; results[[length(results) + 1]] <- row }\\n }\\n\\n elapsed_rep <- (proc.time() - t_rep)[3]\\n rep_times <- c(rep_times, elapsed_rep)\\n log_msg(\\\" Replicate %d done in %.1f sec (%.1f min)\\\",\\n rep_i, elapsed_rep, elapsed_rep / 60)\\n }\\n\\n elapsed_total <- (proc.time() - t_total)[3]\\n log_msg(\\\"All %d replicates completed in %.1f min (avg %.1f sec/rep)\\\",\\n n_rep, elapsed_total / 60, mean(rep_times))\\n\\n results_df <- do.call(rbind, results)\\n\\n # --- Final summary (accumulated across all replicates) ---\\n summary_df <- summarize_results(results_df)\\n log_msg(\\\"\\\")\\n log_msg(\\\"====================================================\\\")\\n log_msg(\\\" FINAL SUMMARY (accumulated over %d replicates)\\\", n_rep)\\n log_msg(\\\"====================================================\\\")\\n log_msg(\\\"%-30s %6s %6s %6s %8s %8s\\\",\\n \\\"method\\\", \\\"FDR\\\", \\\"power\\\", \\\"n_cs\\\", \\\"false\\\", \\\"size\\\")\\n log_msg(\\\"%-30s %6s %6s %6s %8s %8s\\\",\\n \\\"------------------------------\\\", \\\"------\\\", \\\"------\\\", \\\"------\\\", \\\"--------\\\", \\\"--------\\\")\\n for (i in seq_len(nrow(summary_df))) {\\n s <- summary_df[i, ]\\n log_msg(\\\"%-30s %6.3f %6.3f %6d %8d %8.0f\\\",\\n s$method, s$FDR, s$power, s$total_cs, s$total_false_cs, s$mean_size)\\n }\\n log_msg(\\\"====================================================\\\")\\n\\n list(results = results_df, summary = summary_df)\\n}\\n\\nlog_msg(\\\"All functions defined.\\\")\"\n },\n {\n \"cell_type\": \"markdown\",\n \"metadata\": {},\n \"source\": [\n \"## Run Simulation\\n\",\n \"\\n\",\n \"Execution proceeds in four phases:\\n\",\n \"1. Build LD structure (fast)\\n\",\n \"2. Generate genotype matrix and true LD (slow \\u2014 several minutes)\\n\",\n \"3. Pre-compute stochastic sketches and subsample LD for each $B$\\n\",\n \"4. Run replicates: simulate phenotype, compute z-scores, run all methods\\n\",\n \"\\n\",\n \"**To monitor progress**, open a second terminal and run:\\n\",\n \"```bash\\n\",\n \"tail -f stochastic_ld_benchmark.log\\n\",\n \"```\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": null,\n \"metadata\": {},\n \"outputs\": [],\n \"source\": \"# ============================================================\\n# Phase 1: Build LD structure\\n# ============================================================\\nlog_msg(\\\"Phase 1: Building LD structure (p=%d)...\\\", p)\\nld_struct <- build_ld_structure(p, seed = seed)\\nlog_msg(\\\" %d blocks, sizes %d-%d, rho %.2f-%.2f\\\",\\n ld_struct$n_blocks,\\n min(sapply(ld_struct$blocks, function(b) b$size)),\\n max(sapply(ld_struct$blocks, function(b) b$size)),\\n min(sapply(ld_struct$blocks, function(b) b$rho)),\\n max(sapply(ld_struct$blocks, function(b) b$rho)))\\n\\n# ============================================================\\n# Phase 2: Generate genotypes and true LD\\n# ============================================================\\nlog_msg(\\\"Phase 2: Generating genotypes (%d x %d)...\\\", n, p)\\nt0 <- proc.time()\\ngeno <- generate_genotypes(n, ld_struct, seed = seed + 1)\\nX <- geno$X\\nR_true <- geno$R_true\\nrm(geno)\\nlog_msg(\\\"Phase 2 complete in %.1f min\\\", (proc.time() - t0)[3] / 60)\\n\\n# ============================================================\\n# Phase 3: Pre-compute LD approximations\\n# ============================================================\\nlog_msg(\\\"Phase 3: Computing LD approximations for B = {%s}...\\\",\\n paste(B_values, collapse = \\\", \\\"))\\nt0 <- proc.time()\\nld_approx <- compute_ld_approximations(X, B_values, seed = seed + 2)\\nsketches <- ld_approx$sketches\\nR_subs <- ld_approx$R_subs\\nrm(ld_approx)\\nlog_msg(\\\"Phase 3 complete in %.1f min\\\", (proc.time() - t0)[3] / 60)\\n\\n# ============================================================\\n# Phase 4: Run simulation replicates\\n# ============================================================\\nn_methods <- 1 + length(B_values) * 4 # insample + 4 per B\\nlog_msg(\\\"Phase 4: Running %d replicates x %d methods...\\\", n_rep, n_methods)\\nsim_output <- run_simulation(X, R_true, sketches, R_subs, ld_struct,\\n B_values, n_rep, n_causal, pve_per, L,\\n seed = seed + 100)\\nresults <- sim_output$results\\nsummary_df <- sim_output$summary\\nlog_msg(\\\"Simulation complete. %d result rows.\\\", nrow(results))\"\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": null,\n \"metadata\": {},\n \"outputs\": [],\n \"source\": [\n \"# ============================================================\\n\",\n \"# Save results to RDS (both per-replicate and summary)\\n\",\n \"# ============================================================\\n\",\n \"rds_file <- sprintf(\\\"stochastic_ld_benchmark_n%d_p%d_nrep%d.rds\\\", n, p, n_rep)\\n\",\n \"saveRDS(list(results = results, summary = summary_df), file = rds_file)\\n\",\n \"log_msg(\\\"Results saved to %s\\\", rds_file)\\n\",\n \"close(log_con) # close log file\\n\",\n \"\\n\",\n \"cat(\\\"\\\\n=== FINAL SUMMARY ===\\\\n\\\")\\n\",\n \"print(summary_df[, c(\\\"method\\\", \\\"FDR\\\", \\\"power\\\", \\\"total_cs\\\", \\\"total_false_cs\\\", \\\"mean_size\\\")],\\n\",\n \" row.names = FALSE)\"\n ]\n },\n {\n \"cell_type\": \"markdown\",\n \"metadata\": {},\n \"source\": [\n \"## Results and Visualization\\n\",\n \"\\n\",\n \"Three plots:\\n\",\n \"1. **FDR bar plot** \\u2014 with a horizontal line at the nominal 0.05 level\\n\",\n \"2. **Power bar plot**\\n\",\n \"3. **Power vs. FDR scatter** \\u2014 summarizing the trade-off\"\n ]\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": null,\n \"metadata\": {},\n \"outputs\": [],\n \"source\": \"# ============================================================\\n# Load and display summary (from accumulated raw counts)\\n# ============================================================\\n# To reload from saved file:\\n# dat <- readRDS(rds_file)\\n# results <- dat$results\\n# summary_df <- dat$summary\\n\\n# Order methods logically\\nmethod_order <- c(\\\"insample_R\\\")\\nfor (B in B_values) {\\n method_order <- c(method_order,\\n paste0(\\\"subsample_B\\\", B),\\n paste0(\\\"stoch_B\\\", B, \\\"_nocorr\\\"),\\n paste0(\\\"stoch_B\\\", B, \\\"_corr\\\"),\\n paste0(\\\"stoch_B\\\", B, \\\"_NIG_corr\\\"))\\n}\\nsummary_df$method <- factor(summary_df$method, levels = method_order)\\nsummary_df <- summary_df[order(summary_df$method), ]\\n\\ncat(\\\"\\\\n=== Summary (accumulated over all replicates) ===\\\\n\\\")\\nprint(summary_df[, c(\\\"method\\\", \\\"FDR\\\", \\\"power\\\", \\\"total_cs\\\", \\\"total_false_cs\\\",\\n \\\"total_found\\\", \\\"total_causal\\\", \\\"mean_size\\\")], row.names = FALSE)\"\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": null,\n \"metadata\": {},\n \"outputs\": [],\n \"source\": \"# ============================================================\\n# FDR bar plot (from accumulated counts)\\n# ============================================================\\nmethod_colors <- c(\\\"insample_R\\\" = \\\"gray50\\\")\\nfor (B in B_values) {\\n method_colors[paste0(\\\"subsample_B\\\", B)] <- \\\"steelblue\\\"\\n method_colors[paste0(\\\"stoch_B\\\", B, \\\"_nocorr\\\")] <- \\\"tomato\\\"\\n method_colors[paste0(\\\"stoch_B\\\", B, \\\"_corr\\\")] <- \\\"seagreen\\\"\\n method_colors[paste0(\\\"stoch_B\\\", B, \\\"_NIG_corr\\\")] <- \\\"mediumpurple\\\"\\n}\\n\\npar(mar = c(12, 4, 3, 1))\\nbp <- barplot(summary_df$FDR, names.arg = summary_df$method,\\n col = method_colors[as.character(summary_df$method)],\\n las = 2, ylab = \\\"FDR\\\", main = \\\"False Discovery Rate by Method\\\",\\n ylim = c(0, max(summary_df$FDR, 0.1) * 1.2))\\nabline(h = 0.05, col = \\\"darkred\\\", lty = 2, lwd = 2)\\ntext(max(bp), 0.05, \\\" 0.05\\\", adj = c(0, -0.3), col = \\\"darkred\\\", cex = 0.8)\\nlegend(\\\"topright\\\",\\n legend = c(\\\"In-sample R\\\", \\\"Subsample\\\", \\\"Stoch (no corr)\\\",\\n \\\"Stoch (corrected)\\\", \\\"NIG (corrected)\\\"),\\n fill = c(\\\"gray50\\\", \\\"steelblue\\\", \\\"tomato\\\", \\\"seagreen\\\",\\n \\\"mediumpurple\\\"), cex = 0.7, bty = \\\"n\\\")\"\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": null,\n \"metadata\": {},\n \"outputs\": [],\n \"source\": \"# ============================================================\\n# Power bar plot (from accumulated counts)\\n# ============================================================\\npar(mar = c(12, 4, 3, 1))\\nbp <- barplot(summary_df$power, names.arg = summary_df$method,\\n col = method_colors[as.character(summary_df$method)],\\n las = 2, ylab = \\\"Power\\\", main = \\\"Power by Method\\\",\\n ylim = c(0, 1))\\nlegend(\\\"topright\\\",\\n legend = c(\\\"In-sample R\\\", \\\"Subsample\\\", \\\"Stoch (no corr)\\\",\\n \\\"Stoch (corrected)\\\", \\\"NIG (corrected)\\\"),\\n fill = c(\\\"gray50\\\", \\\"steelblue\\\", \\\"tomato\\\", \\\"seagreen\\\",\\n \\\"mediumpurple\\\"), cex = 0.7, bty = \\\"n\\\")\"\n },\n {\n \"cell_type\": \"code\",\n \"execution_count\": null,\n \"metadata\": {},\n \"outputs\": [],\n \"source\": \"# ============================================================\\n# Power vs FDR scatter plot (from accumulated counts)\\n# ============================================================\\npar(mar = c(5, 4, 3, 1))\\nmethod_pch <- c(\\\"insample_R\\\" = 16)\\npch_vals <- c(17, 15, 18)\\nfor (i in seq_along(B_values)) {\\n B <- B_values[i]\\n method_pch[paste0(\\\"subsample_B\\\", B)] <- pch_vals[i]\\n method_pch[paste0(\\\"stoch_B\\\", B, \\\"_nocorr\\\")] <- pch_vals[i]\\n method_pch[paste0(\\\"stoch_B\\\", B, \\\"_corr\\\")] <- pch_vals[i]\\n method_pch[paste0(\\\"stoch_B\\\", B, \\\"_NIG_corr\\\")] <- pch_vals[i]\\n}\\n\\nplot(summary_df$FDR, summary_df$power, type = \\\"n\\\",\\n xlim = c(0, max(summary_df$FDR, 0.1) * 1.3), ylim = c(0, 1),\\n xlab = \\\"FDR\\\", ylab = \\\"Power\\\", main = \\\"Power vs FDR\\\")\\npoints(summary_df$FDR, summary_df$power,\\n col = method_colors[as.character(summary_df$method)],\\n pch = method_pch[as.character(summary_df$method)], cex = 2)\\ntext(summary_df$FDR, summary_df$power, labels = summary_df$method,\\n pos = 4, cex = 0.5, col = \\\"gray30\\\")\\nabline(v = 0.05, col = \\\"darkred\\\", lty = 2, lwd = 2)\\ntext(0.05, 0, \\\"FDR = 0.05\\\", adj = c(-0.1, -0.3), col = \\\"darkred\\\", cex = 0.8)\\nlegend(\\\"bottomright\\\",\\n legend = c(\\\"In-sample R\\\", \\\"Subsample\\\", \\\"Stoch (no corr)\\\",\\n \\\"Stoch (corrected)\\\", \\\"NIG (corrected)\\\",\\n paste0(\\\"B=\\\", B_values)),\\n col = c(\\\"gray50\\\", \\\"steelblue\\\", \\\"tomato\\\", \\\"seagreen\\\",\\n \\\"mediumpurple\\\", rep(\\\"black\\\", 3)),\\n pch = c(16, 16, 16, 16, 16, pch_vals),\\n pt.cex = 1.5, cex = 0.6, bty = \\\"n\\\")\"\n },\n {\n \"cell_type\": \"markdown\",\n \"metadata\": {},\n \"source\": [\n \"## Command-Line Execution\\n\",\n \"\\n\",\n \"```bash\\n\",\n \"cd /path/to/notebooks\\n\",\n \"\\n\",\n \"# Terminal 1: run the notebook\\n\",\n \"jupyter nbconvert --execute --to notebook \\\\\\n\",\n \" --output stochastic_ld_benchmark_executed.ipynb \\\\\\n\",\n \" --ExecutePreprocessor.timeout=7200 \\\\\\n\",\n \" stochastic_ld_benchmark.ipynb\\n\",\n \"\\n\",\n \"# Terminal 2: monitor progress\\n\",\n \"tail -f stochastic_ld_benchmark.log\\n\",\n \"```\\n\",\n \"\\n\",\n \"For the full run, edit the setup cell to set `n_rep <- 100`.\\n\",\n \"\\n\",\n \"Results are saved to `stochastic_ld_benchmark_n100000_p5000_nrep100.rds`.\"\n ]\n }\n ],\n \"metadata\": {\n \"kernelspec\": {\n \"display_name\": \"R\",\n \"language\": \"R\",\n \"name\": \"ir\"\n },\n \"language_info\": {\n \"codemirror_mode\": \"r\",\n \"file_extension\": \".r\",\n \"mimetype\": \"text/x-r-source\",\n \"name\": \"R\",\n \"pygments_lexer\": \"r\",\n \"version\": \"4.4.3\"\n }\n },\n \"nbformat\": 4,\n \"nbformat_minor\": 4\n}" }, { "path": "man/FinemappingConvergence.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/example_dataset.R\n\\docType{data}\n\\name{FinemappingConvergence}\n\\alias{FinemappingConvergence}\n\\title{Simulated Fine-mapping Data with Convergence Problem.}\n\\format{\n\\code{FinemappingConvergence} is a list with the following\nelements:\n\n\\describe{\n\n \\item{XtX}{Summary statistics computed using the centered and\n scaled genotype matrix.}\n\n \\item{Xty}{Summary statistics computed using the centered and\n scaled genotype data, and the centered simulated response.}\n\n \\item{yty}{yty is computed using the centered simulated response.}\n\n \\item{n}{The sample size (50,000).}\n\n \\item{true_coef}{The coefficients used to simulate the responses.}\n\n \\item{z}{z-scores from a simple (single-SNP) linear regression.}}\n}\n\\description{\nData simulated using real genotypes from 50,000\n individuals and 200 SNPs. Two of the SNPs have non-zero effects\n on the multivariate response. The response data are generated under\n a linear regression model. The simulated response and the columns\n of the genotype matrix are centered.\n}\n\\examples{\ndata(FinemappingConvergence)\n}\n\\seealso{\nA similar data set with more SNPs is used in the\n \\dQuote{Refine SuSiE model} vignette.\n}\n\\keyword{data}\n" }, { "path": "man/N2finemapping.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/example_dataset.R\n\\docType{data}\n\\name{N2finemapping}\n\\alias{N2finemapping}\n\\title{Simulated Fine-mapping Data with Two Effect Variables}\n\\format{\n\\code{N2finemapping} is a list with the following elements:\n\n\\describe{\n\n \\item{X}{Centered and scaled genotype data.}\n\n \\item{chrom}{Chromomsome of the original data, in hg38 coordinates.}\n\n \\item{pos}{Chromomosomal position of the original data, in hg38\n coordinates. The information can be used to compare impact of using\n other genotype references of the same variables in \\code{susie_rss}\n application.}\n\n \\item{true_coef}{Simulated effect sizes.}\n\n \\item{residual_variance}{Simulated residual covariance matrix.}\n\n \\item{Y}{Simulated multivariate response.}\n\n \\item{allele_freq}{Allele frequencies based on the original\n genotype data.}\n\n \\item{V}{Suggested prior covariance matrix for effect sizes of\n the two non-zero effect variables.}\n}\n}\n\\description{\nThis data set contains a genotype matrix for 574\n individuals and 1,002 variables. The variables are genotypes after\n centering and scaling, and therefore retain the correlation\n structure of the original genotype data. Two of the variables have\n non-zero effects on the multivariate response. The response data\n are generated under a multivariate linear regression model. See\n Wang \\emph{et al} (2020) for details.\n}\n\\examples{\ndata(N2finemapping)\n}\n\\references{\nG. Wang, A. Sarkar, P. Carbonetto and M. Stephens (2020). A simple\n new approach to variable selection in regression, with application\n to genetic fine-mapping. \\emph{Journal of the Royal Statistical\n Society, Series B} \\doi{10.1101/501114}.\n}\n\\keyword{data}\n" }, { "path": "man/N3finemapping.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/example_dataset.R\n\\docType{data}\n\\name{N3finemapping}\n\\alias{N3finemapping}\n\\title{Simulated Fine-mapping Data with Three Effect Variables.}\n\\format{\n\\code{N3finemapping} is a list with the following elements:\n\n\\describe{\n\n \\item{X}{N by P variable matrix of centered and scaled genotype\ndata.}\n\n \\item{chrom}{Chromomsome of the original data, in hg38 coordinate.}\n\n \\item{pos}{Chromomosomal positoin of the original data, in hg38\ncoordinate. The information can be used to compare impact of using\nother genotype references of the same variables in susie_rss\napplication.}\n\n \\item{true_coef}{The simulated effect sizes.}\n\n \\item{residual_variance}{The simulated residual covariance matrix.}\n\n \\item{Y}{The simulated response variables.}\n\n \\item{allele_freq}{Allele frequency of the original genotype data.}\n\n \\item{V}{Prior covariance matrix for effect size of the three\nnon-zero effect variables.} }\n}\n\\description{\nThe data-set contains a matrix of 574\nindividuals and 1,001 variables. These variables are real-world\ngenotypes centered and scaled, and therefore retains the\ncorrelation structure of variables in the original genotype data. 3\nout of the variables have non-zero effects. The response data is\ngenerated under a multivariate linear regression model. See Wang\n\\emph{et al} (2020) for more details.\n}\n\\examples{\ndata(N3finemapping)\n}\n\\references{\nG. Wang, A. Sarkar, P. Carbonetto and M. Stephens (2020). A simple\n new approach to variable selection in regression, with application\n to genetic fine-mapping. \\emph{Journal of the Royal Statistical\n Society, Series B} \\doi{10.1101/501114}.\n}\n\\keyword{data}\n" }, { "path": "man/SummaryConsistency.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/example_dataset.R\n\\docType{data}\n\\name{SummaryConsistency}\n\\alias{SummaryConsistency}\n\\title{Simulated Fine-mapping Data with LD matrix From Reference Panel.}\n\\format{\n\\code{SummaryConsistency} is a list with the following\nelements:\n\n\\describe{\n\n \\item{z}{z-scores computed by fitting univariate simple regression\n variable-by-variable.}\n\n \\item{ldref}{LD matrix estimated from the reference panel.}\n\n \\item{flip_id}{The index of the SNP with the flipped allele.}\n\n \\item{signal_id}{The index of the SNP with the non-zero effect.}}\n}\n\\description{\nData simulated using real genotypes from 10,000\n individuals and 200 SNPs. One SNP have non-zero effect\n on the multivariate response. The response data are generated under\n a linear regression model. There is also one SNP with flipped allele\n between summary statistics and the reference panel.\n}\n\\examples{\ndata(SummaryConsistency)\n}\n\\seealso{\nA similar data set with more samples is used in the\n \\dQuote{Diagnostic for fine-mapping with summary statistics}\n vignette.\n}\n\\keyword{data}\n" }, { "path": "man/absolute.order.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/univariate_regression.R\n\\name{absolute.order}\n\\alias{absolute.order}\n\\title{Ordering of Predictors from Coefficient Estimates}\n\\usage{\nabsolute.order(beta)\n}\n\\arguments{\n\\item{beta}{A vector of estimated regression coefficients.}\n}\n\\value{\nAn ordering of the predictors.\n}\n\\description{\nThis function orders the predictors by decreasing\n order of the magnitude of the estimated regression coefficient.\n}\n\\examples{\n### generate synthetic data\nset.seed(1)\nn = 200\np = 300\nX = matrix(rnorm(n*p),n,p)\nbeta = double(p)\nbeta[1:10] = 1:10\ny = X \\%*\\% beta + rnorm(n)\n\n### order predictors by magnitude of univariate regression coefficient\nbeta.hat = univariate_regression(X,y)$betahat\norder = absolute.order(beta.hat)\n\n}\n" }, { "path": "man/add_delta_features.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/diagnosis_reports.R\n\\name{add_delta_features}\n\\alias{add_delta_features}\n\\title{Add per-slot delta features (change from previous iteration)}\n\\usage{\nadd_delta_features(df)\n}\n\\arguments{\n\\item{df}{data.frame from collect_ash_diag + label_diag_truth}\n}\n\\value{\ndf with added delta_, lag1_, and cum_ columns\n}\n\\description{\nComputes delta_c_hat, delta_V, delta_lbf, delta_max_alpha,\ndelta_alpha_entropy, delta_purity for each slot across iterations.\nAlso adds lag1 features (previous iteration values) and\ncumulative features (max c_hat ever, min alpha_entropy ever).\nThese temporal features help ML models detect trajectories\n(e.g., a slot that was strong then weakened = collapse signal).\n}\n\\examples{\n\\dontrun{\ndf <- susieR:::collect_ash_diag(fit)\ndf <- susieR:::label_diag_truth(df, fit, causal)\ndf <- susieR:::add_delta_features(df)\n# Now df has delta_c_hat, lag1_c_hat, cum_max_c_hat, etc.\n# Use for decision tree: rpart::rpart(cs_label ~ ., data = df_last_iter)\n}\n\n}\n\\keyword{internal}\n" }, { "path": "man/block_coordinate_ascent.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/refinement.R\n\\name{block_coordinate_ascent}\n\\alias{block_coordinate_ascent}\n\\title{Block coordinate ascent for iterative model refinement.}\n\\usage{\nblock_coordinate_ascent(\n model,\n data,\n step_fn,\n max_iter = 100,\n tol = 0.001,\n verbose = FALSE\n)\n}\n\\arguments{\n\\item{model}{Fitted model (e.g., from \\code{susie_workhorse} or\n\\code{mvsusie_workhorse}).}\n\n\\item{data}{Data object passed to \\code{step_fn}.}\n\n\\item{step_fn}{A function with signature\n\\code{function(model, data, iter)} that performs one block coordinate\nupdate. Must return a named list with elements:\n\\describe{\n \\item{model}{(required) The updated model.}\n \\item{data}{(optional) Updated data object, e.g. after changing\n residual variance. If \\code{NULL}, the data is unchanged.}\n \\item{converged}{(optional) Logical; if \\code{TRUE}, stop\n iterating.}\n \\item{log_msg}{(optional) Character string appended to verbose\n output.}\n}}\n\n\\item{max_iter}{Maximum number of block ascent iterations\n(default 100).}\n\n\\item{tol}{Convergence tolerance for relative ELBO change\n(default 1e-3).}\n\n\\item{verbose}{If \\code{TRUE}, print progress each iteration\n(default \\code{FALSE}).}\n}\n\\value{\nThe refined model, with \\code{model$converged} set to\n \\code{TRUE} or \\code{FALSE}.\n}\n\\description{\nGeneric framework for post-convergence refinement of fitted models.\nRepeatedly applies a block update (\\code{step_fn}) to a fitted model,\nmonitoring ELBO for convergence and stability. Both CS refinement\n(\\code{\\link{run_refine}}) and residual variance estimation (mvsusieR)\nare instances of block coordinate ascent over different parameter blocks.\n}\n\\details{\nConvergence is reached when either:\n\\itemize{\n \\item \\code{step_fn} returns \\code{converged = TRUE}\n (the block update signals no further improvement), or\n \\item the relative ELBO change falls below \\code{tol}\n (ELBO stabilized across block updates).\n}\n\nA warning is issued if the ELBO decreases between iterations.\n}\n" }, { "path": "man/calculate_posterior_moments_mixture_common.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/mixture_prior.R\n\\name{calculate_posterior_moments_mixture_common}\n\\alias{calculate_posterior_moments_mixture_common}\n\\title{Compute mixture posterior moments}\n\\usage{\ncalculate_posterior_moments_mixture_common(params, model, l)\n}\n\\arguments{\n\\item{params}{Params object with prior_variance_grid and mixture_weights}\n\n\\item{model}{Model with lbf_grid[[l]] (p x K), alpha[l,] already computed,\nand ser_stats cached from loglik_mixture_common}\n\n\\item{l}{Effect index}\n}\n\\value{\nUpdated model with mu[l,] and mu2[l,]\n}\n\\description{\nFor each grid point k, computes the conjugate normal posterior moments\n(mean, variance) given prior variance V_k. Forms the mixture posterior\nusing responsibility weights r_jk = w_k * BF_jk / sum_k' w_k' * BF_jk'.\n}\n\\details{\nUses betahat and shat2 from ser_stats (produced by the data-type-specific\ncompute_ser_statistics), so this function is data-type-agnostic.\n}\n\\keyword{internal}\n" }, { "path": "man/check_alpha_pip_cycle_convergence.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_utils.R\n\\name{check_alpha_pip_cycle_convergence}\n\\alias{check_alpha_pip_cycle_convergence}\n\\title{Check alpha/PIP fixed-point or short-cycle convergence}\n\\usage{\ncheck_alpha_pip_cycle_convergence(data, params, model)\n}\n\\description{\nUses one tolerance for both marginal PIPs and alpha. Lag 1 is ordinary\nconvergence; larger lags detect a periodic orbit and average alpha over it.\n}\n\\keyword{internal}\n" }, { "path": "man/cleanup_extra_fields.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/generic_methods.R\n\\name{cleanup_extra_fields}\n\\alias{cleanup_extra_fields}\n\\title{Class-specific extra fields to strip in cleanup_model.default}\n\\usage{\ncleanup_extra_fields(data)\n}\n\\description{\nDefault returns `character(0)`. Subclasses (e.g., mfsusieR's\n`raw_residuals`, mvsusieR's `Y_imputed`/`llik_cache`) override\nto add their per-class scratch fields. Result is unioned with\nthe standard temp_fields list inside `cleanup_model.default`.\n}\n\\keyword{internal}\n" }, { "path": "man/coef.mr.ash.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/mr.ash.R\n\\name{coef.mr.ash}\n\\alias{coef.mr.ash}\n\\title{Extract Regression Coefficients from Mr.ASH Fit}\n\\usage{\n\\method{coef}{mr.ash}(object, ...)\n}\n\\arguments{\n\\item{object}{A Mr.ASH fit, usually the result of calling\n\\code{mr.ash}.}\n\n\\item{...}{Additional arguments passed to the default S3 method.}\n}\n\\value{\nA p+1 vector. The first element gives the estimated\n intercept, and the remaining p elements are the estimated\n regression coefficients.\n \n## generate synthetic data\nset.seed(1)\nn = 200\np = 300\nX = matrix(rnorm(n*p),n,p)\nbeta = double(p)\nbeta[1:10] = 1:10\ny = X %*% beta + rnorm(n)\n\n## fit mr.ash\nfit.mr.ash = mr.ash(X, y)\n\n## coefficient\ncoef.mr.ash = coef(fit.mr.ash)\nintercept = coef.mr.ash[1]\nbeta = coef.mr.ash[-1]\n}\n\\description{\nRetrieve posterior mean estimates of the regression\n coefficients in a Mr.ASH model.\n}\n" }, { "path": "man/coef.susie.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/predict.susie.R\n\\name{coef.susie}\n\\alias{coef.susie}\n\\title{Extract regression coefficients from susie fit}\n\\usage{\n\\method{coef}{susie}(object, ...)\n}\n\\arguments{\n\\item{object}{A susie fit.}\n\n\\item{\\dots}{Additional arguments passed to the generic \\code{coef}\nmethod.}\n}\n\\value{\nA p+1 vector, the first element being an intercept, and the\n remaining p elements being estimated regression coefficients.\n}\n\\description{\nExtract regression coefficients from susie fit\n}\n" }, { "path": "man/collect_ash_diag.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/diagnosis_reports.R\n\\name{collect_ash_diag}\n\\alias{collect_ash_diag}\n\\title{Collect diagnostic data.frames across iterations}\n\\usage{\ncollect_ash_diag(fit)\n}\n\\arguments{\n\\item{fit}{SuSiE fit object (must have been run with .ash_debug = TRUE)}\n}\n\\value{\ndata.frame with nrow = L * n_ash_iters, or NULL if no diagnostics\n}\n\\description{\nCall this after running susie() to rbind all per-iteration diagnostics\ninto a single ML-ready data.frame.\n}\n\\examples{\n\\dontrun{\n# Full ML pipeline:\ndata(unmappable_data)\nX <- unmappable_data$X; y <- as.vector(unmappable_data$y)\ncausal <- which(unmappable_data$beta != 0)\n\nfit <- susie(X, y, L=10, slot_prior=slot_prior_betabinom(),\n unmappable_effects=\"ash\", max_iter=50)\n\ndf <- susieR:::collect_ash_diag(fit) # all iterations\ndf <- susieR:::label_diag_truth(df, fit, causal) # TP/FP labels\ndf <- susieR:::add_delta_features(df) # temporal features\n\n# Inspect FP slot across iterations:\nsubset(df, cs_label == \"FP\", select = c(iter, slot, sentinel,\n c_hat, lbf, max_alpha, alpha_entropy, mask_tier, delta_c_hat))\n\n# 4-way comparison (BB+ash vs V0, with/without mr.ash):\noptions(susie.skip_mrash = TRUE)\nfit_nomrash <- susie(X, y, L=10, slot_prior=slot_prior_betabinom(),\n unmappable_effects=\"ash\", max_iter=50)\noptions(susie.skip_mrash = FALSE)\ndf_nomrash <- susieR:::collect_ash_diag(fit_nomrash)\n\n# Decision tree analysis:\n# library(rpart)\n# last_iter <- df[df$iter == max(df$iter) & df$V > 0, ]\n# tree <- rpart(cs_label ~ c_hat + lbf + max_alpha + alpha_entropy +\n# purity + mask_tier + delta_c_hat, data = last_iter)\n}\n\n}\n\\keyword{internal}\n" }, { "path": "man/compare_ash_methods.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/diagnosis_reports.R\n\\name{compare_ash_methods}\n\\alias{compare_ash_methods}\n\\title{Compare two diagnostic runs side by side}\n\\usage{\ncompare_ash_methods(df1, df2, label1 = \"Method1\", label2 = \"Method2\")\n}\n\\arguments{\n\\item{df1}{First diagnostic data.frame}\n\n\\item{df2}{Second diagnostic data.frame}\n\n\\item{label1}{Label for first run (e.g., \"BB+ash\")}\n\n\\item{label2}{Label for second run (e.g., \"V0\")}\n}\n\\description{\nTakes two data.frames (from diagnose_bb_ash_iter or\ndiagnose_ash_filter_archived_iter) at the same iteration\nand prints a side-by-side comparison.\n}\n\\keyword{internal}\n" }, { "path": "man/compute_marginal_bhat_shat.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/univariate_regression.R\n\\name{compute_marginal_bhat_shat}\n\\alias{compute_marginal_bhat_shat}\n\\title{Per-Position Marginal OLS Regression of `Y` on Each Column of `X`}\n\\usage{\ncompute_marginal_bhat_shat(X, Y, predictor_weights = NULL, sigma2 = NULL)\n}\n\\arguments{\n\\item{X}{numeric matrix `n x J`, expected column-centred.}\n\n\\item{Y}{numeric matrix `n x T` or numeric vector of length `n`.\nWhen a vector, is treated as a one-column matrix.}\n\n\\item{predictor_weights}{optional numeric vector of length `J`\ngiving `colSums(X^2)`. Computed internally when `NULL`.\nCallers that have this cached on the data object pass it\nthrough to avoid recomputation.}\n\n\\item{sigma2}{optional numeric scalar giving a known residual\nvariance. When supplied, `Shat[j, t] = sqrt(sigma2 /\npredictor_weights[j])` (single-effect-residual form). When\n`NULL`, `Shat` is the per-pair empirical residual standard\nerror: for each `(j, t)` pair, the sample SD of `Y[, t] -\nX[, j] * Bhat[j, t]` divided by `sqrt(n - 1)`. The latter\nmatches the form used by data-driven prior init routines\n(e.g., for fitting a normal-mixture prior via `ashr::ash`).}\n}\n\\value{\nlist with elements `Bhat` (`J x T`) and `Shat` (`J x T`).\n}\n\\description{\nComputes the marginal OLS regression coefficient and\n standard error for each `(X column, Y column)` pair, treating\n the regressions as independent. `X` is assumed column-centred\n (no intercept term in the per-pair regression); each `Y`\n column is treated independently. Returns the J x T matrices\n `Bhat` and `Shat`.\n\nUsed internally by single-effect-regression style routines that\nneed a per-position marginal estimate. Vectorised across columns\nof `Y` so callers can pass either a numeric vector (T = 1) or a\nnumeric matrix (T > 1) without looping at the call site.\n}\n\\examples{\nset.seed(1)\nX <- matrix(rnorm(50 * 5), 50, 5)\nX <- scale(X, center = TRUE, scale = FALSE)\nY <- matrix(rnorm(50 * 3), 50, 3)\nout <- compute_marginal_bhat_shat(X, Y)\ndim(out$Bhat) # 5 x 3\ndim(out$Shat) # 5 x 3\n\n}\n" }, { "path": "man/compute_suff_stat.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_rss_utils.R\n\\name{compute_suff_stat}\n\\alias{compute_suff_stat}\n\\title{Compute sufficient statistics for input to \\code{susie_ss}}\n\\usage{\ncompute_suff_stat(X, y, standardize = FALSE)\n}\n\\arguments{\n\\item{X}{An n by p matrix of covariates.}\n\n\\item{y}{An n vector.}\n\n\\item{standardize}{Logical flag indicating whether to standardize\ncolumns of X to unit variance prior to computing summary data}\n}\n\\value{\nA list of sufficient statistics (\\code{XtX, Xty, yty, n})\n and \\code{X_colmeans}, \\code{y_mean}.\n}\n\\description{\nComputes the sufficient statistics \\eqn{X'X, X'y, y'y}\n and \\eqn{n} after centering (and possibly standardizing) the\n columns of \\eqn{X} and centering \\eqn{y} to have mean zero. We also\n store the column means of \\eqn{X} and mean of \\eqn{y}.\n}\n\\examples{\ndata(N2finemapping)\nss <- compute_suff_stat(N2finemapping$X, N2finemapping$Y[, 1])\n\n}\n" }, { "path": "man/data_small.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/example_dataset.R\n\\docType{data}\n\\name{data_small}\n\\alias{data_small}\n\\title{Simulated Small-sample eQTL Data.}\n\\format{\n\\code{data_small} is a list with the following elements:\n\n\\describe{\n\n \\item{y}{Simulated gene expression response.}\n\n \\item{X}{Genotype matrix.}}\n}\n\\description{\nA simulated eQTL data set with 47 individuals and 7,430\n variables. The response is a simulated gene expression phenotype and\n the variables are genotypes. This data set illustrates the small\n sample-size setting considered in Denault \\emph{et al} (2025).\n}\n\\examples{\ndata(data_small)\n}\n\\references{\nW. R. P. Denault \\emph{et al} (2025). Accounting for uncertainty in\n residual variances improves fine-mapping in small sample studies.\n \\emph{bioRxiv} \\doi{10.1101/2025.05.16.654543}.\n}\n\\seealso{\nThe \\dQuote{Small data example} vignette.\n}\n\\keyword{data}\n" }, { "path": "man/diagnose_ash_filter_archived_iter.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/diagnosis_reports.R\n\\name{diagnose_ash_filter_archived_iter}\n\\alias{diagnose_ash_filter_archived_iter}\n\\title{V0 archived filter per-iteration diagnostic}\n\\usage{\ndiagnose_ash_filter_archived_iter(\n model,\n Xcorr,\n masked,\n b_confident,\n sentinels,\n effect_purity,\n current_case,\n current_collision,\n mrash_output\n)\n}\n\\value{\ndata.frame with one row per slot, all features\n}\n\\description{\nV0 archived filter per-iteration diagnostic\n}\n\\keyword{internal}\n" }, { "path": "man/diagnose_bb_ash_iter.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/diagnosis_reports.R\n\\name{diagnose_bb_ash_iter}\n\\alias{diagnose_bb_ash_iter}\n\\title{BB+ash per-iteration diagnostic}\n\\usage{\ndiagnose_bb_ash_iter(\n model,\n Xcorr,\n mask,\n b_confident,\n sentinels,\n sentinel_collision,\n is_confident_now,\n is_trusted,\n emerging_slots,\n active_slots,\n c_hat,\n ash_result,\n p,\n high_chat = NULL,\n low_chat = NULL,\n collision_threshold = 0.9,\n purity_threshold = 0.5,\n masking_threshold = 0.5,\n nPIP_threshold = 0.05,\n c_hat_excess_threshold = 0.2,\n alpha_entropy_threshold = log(5),\n slot_prior = NULL,\n mask_smoothness = NULL,\n mask_amount = NULL,\n mask_concentration = NULL,\n mask_burnin = NULL,\n mask_spread_pip_at_sent = NULL,\n mask_pip_prot_at_sent = NULL\n)\n}\n\\value{\ndata.frame with one row per slot, all features\n}\n\\description{\nBB+ash per-iteration diagnostic\n}\n\\keyword{internal}\n" }, { "path": "man/estimate_s_rss.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_rss_utils.R\n\\name{estimate_s_rss}\n\\alias{estimate_s_rss}\n\\title{Estimate s in \\code{susie_rss} Model Using Regularized LD}\n\\usage{\nestimate_s_rss(z, R, n, r_tol = 1e-08, method = \"null-mle\")\n}\n\\arguments{\n\\item{z}{A p-vector of z scores.}\n\n\\item{R}{A p by p symmetric, positive semidefinite correlation\nmatrix.}\n\n\\item{n}{The sample size. (Optional, but highly recommended.)}\n\n\\item{r_tol}{Tolerance level for eigenvalue check of positive\nsemidefinite matrix of R.}\n\n\\item{method}{a string specifies the method to estimate \\eqn{s}.}\n}\n\\value{\nA number between 0 and 1.\n}\n\\description{\nThe estimated s gives information about the\n consistency between the z scores and LD matrix. A larger \\eqn{s}\n means there is a strong inconsistency between z scores and LD\n matrix. The \\dQuote{null-mle} method obtains mle of \\eqn{s} under\n \\eqn{z | R ~ N(0,(1-s)R + s I)}, \\eqn{0 < s < 1}. The\n \\dQuote{null-partialmle} method obtains mle of \\eqn{s} under\n \\eqn{U^T z | R ~ N(0,s I)}, in which \\eqn{U} is a matrix containing\n the of eigenvectors that span the null space of R; that is, the\n eigenvectors corresponding to zero eigenvalues of R. The estimated\n \\eqn{s} from \\dQuote{null-partialmle} could be greater than 1. The\n \\dQuote{null-pseudomle} method obtains mle of \\eqn{s} under\n pseudolikelihood \\eqn{L(s) = \\prod_{j=1}^{p} p(z_j | z_{-j}, s,\n R)}, \\eqn{0 < s < 1}.\n}\n\\examples{\nset.seed(1)\nn <- 500\np <- 1000\nbeta <- rep(0, p)\nbeta[1:4] <- 0.01\nX <- matrix(rnorm(n * p), nrow = n, ncol = p)\nX <- scale(X, center = TRUE, scale = TRUE)\ny <- drop(X \\%*\\% beta + rnorm(n))\ninput_ss <- compute_suff_stat(X, y, standardize = TRUE)\nss <- univariate_regression(X, y)\nR <- cor(X)\nattr(R, \"eigen\") <- eigen(R, symmetric = TRUE)\nzhat <- with(ss, betahat / sebetahat)\n\n# Estimate s using the unadjusted z-scores.\ns0 <- estimate_s_rss(zhat, R)\n\n# Estimate s using the adjusted z-scores.\ns1 <- estimate_s_rss(zhat, R, n)\n\n}\n" }, { "path": "man/extract_bb_ash_features.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/diagnosis_reports.R\n\\name{extract_bb_ash_features}\n\\alias{extract_bb_ash_features}\n\\title{Extract ML feature table from a completed BB+ash fit}\n\\usage{\nextract_bb_ash_features(fit, X, causal = NULL)\n}\n\\arguments{\n\\item{fit}{Completed susie fit (with slot_prior + ash)}\n\n\\item{X}{Design matrix (used to compute Xcorr if needed)}\n\n\\item{causal}{Integer vector of true causal indices (for labeling)}\n}\n\\value{\ndata.frame with one row per slot, all features + TP/FP label\n}\n\\description{\nComputes per-slot features from the converged model. Call with\nsusieR:::extract_bb_ash_features(fit, X_or_Xcorr, causal).\n}\n\\keyword{internal}\n" }, { "path": "man/format_extra_diag.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/model_methods.R\n\\name{format_extra_diag}\n\\alias{format_extra_diag}\n\\title{Append class-specific extra-diag columns to the verbose row}\n\\usage{\nformat_extra_diag(model)\n}\n\\description{\nDefault returns an empty string. Subclasses override to inject\ncolumns such as `max_pi_null`, `max_KL_l`, alpha-entropy\nn_eff. Output is appended after the V column in the per-iter\ntabular line.\n}\n\\keyword{internal}\n" }, { "path": "man/format_sigma2_summary.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/model_methods.R\n\\name{format_sigma2_summary}\n\\alias{format_sigma2_summary}\n\\title{Format the per-iter sigma2 cell for verbose output}\n\\usage{\nformat_sigma2_summary(model)\n}\n\\description{\nDefault returns the scalar sigma2 in `%.4f`. Subclasses\n(e.g., mfsusieR's list-of-vectors sigma2; mvsusieR's\nmatrix sigma2) override to a compact summary string of\nfixed width.\n}\n\\keyword{internal}\n" }, { "path": "man/get.full.posterior.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/mr.ash.R\n\\name{get.full.posterior}\n\\alias{get.full.posterior}\n\\title{Approximation Posterior Expectations from Mr.ASH Fit}\n\\usage{\nget.full.posterior(fit)\n}\n\\arguments{\n\\item{fit}{A Mr.ASH fit obtained, for example, by running\n\\code{mr.ash}.}\n}\n\\value{\nA list object with the following elements:\n\n\\item{phi}{An p x K matrix containing the posterior assignment\n probabilities, where p is the number of predictors, and K is the\n number of mixture components. (Each row of \\code{phi} should sum to\n 1.)}\n\n\\item{m}{An p x K matrix containing the posterior means conditional\n on assignment to each mixture component.}\n\n\\item{s2}{An p x K matrix containing the posterior variances\n conditional on assignment to each mixture component.}\n}\n\\description{\nRecover the parameters specifying the variational\n approximation to the posterior distribution of the regression\n coefficients. To streamline the model fitting implementation, and\n to reduce memory requirements, \\code{\\link{mr.ash}} does not store\n all the parameters needed to specify the approximate posterior.\n}\n\\examples{\n## generate synthetic data\nset.seed(1)\nn = 200\np = 300\nX = matrix(rnorm(n*p),n,p)\nbeta = double(p)\nbeta[1:10] = 1:10\ny = X \\%*\\% beta + rnorm(n)\n\n## fit mr.ash\nfit.mr.ash = mr.ash(X, y)\n\n## recover full posterior\nfull.post = get.full.posterior(fit.mr.ash)\n\n}\n" }, { "path": "man/get_alpha_l.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/model_methods.R\n\\name{get_alpha_l}\n\\alias{get_alpha_l}\n\\title{Get posterior inclusion probabilities for effect l}\n\\usage{\nget_alpha_l(model, l)\n}\n\\description{\nGet posterior inclusion probabilities for effect l\n}\n\\keyword{internal}\n" }, { "path": "man/get_cs_correlation.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_get_functions.R\n\\name{get_cs_correlation}\n\\alias{get_cs_correlation}\n\\title{Get Correlations Between CSs, using Variable with Maximum PIP From Each CS}\n\\usage{\nget_cs_correlation(model, X = NULL, Xcorr = NULL, max = FALSE)\n}\n\\arguments{\n\\item{model}{A SuSiE fit, typically an output from\n\\code{\\link{susie}} or one of its variants.}\n\n\\item{X}{n by p matrix of values of the p variables (covariates) in\nn samples. When provided, correlation between variables will be\ncomputed and used to remove CSs whose minimum correlation among\nvariables is smaller than \\code{min_abs_corr}.}\n\n\\item{Xcorr}{p by p matrix of correlations between variables\n(covariates). When provided, it will be used to remove CSs whose\nminimum correlation among variables is smaller than\n\\code{min_abs_corr}.}\n\n\\item{max}{When \\code{max = FAFLSE}, return a matrix of CS\ncorrelations. When \\code{max = TRUE}, return only the maximum\nabsolute correlation among all pairs of correlations.}\n}\n\\value{\nA matrix of correlations between CSs, or the maximum\n absolute correlation when \\code{max = TRUE}.\n}\n\\description{\nThis function evaluates the correlation between single effect\n CSs. It is not part of the SuSiE inference. Rather, it is designed as\n a diagnostic tool to assess how correlated the reported CS are.\n}\n" }, { "path": "man/get_objective.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/model_methods.R\n\\name{get_objective}\n\\alias{get_objective}\n\\title{Compute the SuSiE ELBO (evidence lower bound)}\n\\usage{\nget_objective(data, params, model)\n}\n\\arguments{\n\\item{data}{Data object.}\n\n\\item{params}{Params object.}\n\n\\item{model}{Model object.}\n}\n\\value{\nScalar ELBO value.\n}\n\\description{\nBuilding-block function used by downstream packages implementing\ncustom IBSS loops.\n}\n\\keyword{internal}\n" }, { "path": "man/get_posterior_mean_l.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/model_methods.R\n\\name{get_posterior_mean_l}\n\\alias{get_posterior_mean_l}\n\\title{Get PIP-weighted posterior mean for effect l (alpha * mu)}\n\\usage{\nget_posterior_mean_l(model, l)\n}\n\\description{\nGet PIP-weighted posterior mean for effect l (alpha * mu)\n}\n\\keyword{internal}\n" }, { "path": "man/get_posterior_mean_sum.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/model_methods.R\n\\name{get_posterior_mean_sum}\n\\alias{get_posterior_mean_sum}\n\\title{Get sum of PIP-weighted posterior means across all effects}\n\\usage{\nget_posterior_mean_sum(model)\n}\n\\description{\nGet sum of PIP-weighted posterior means across all effects\n}\n\\keyword{internal}\n" }, { "path": "man/get_posterior_moments_l.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/model_methods.R\n\\name{get_posterior_moments_l}\n\\alias{get_posterior_moments_l}\n\\title{Get posterior moments for effect l (for EM prior variance update)}\n\\usage{\nget_posterior_moments_l(model, l)\n}\n\\description{\nGet posterior moments for effect l (for EM prior variance update)\n}\n\\keyword{internal}\n" }, { "path": "man/get_prior_variance_l.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/model_methods.R\n\\name{get_prior_variance_l}\n\\alias{get_prior_variance_l}\n\\title{Get prior variance for effect l}\n\\usage{\nget_prior_variance_l(model, l)\n}\n\\description{\nGet prior variance for effect l\n}\n\\keyword{internal}\n" }, { "path": "man/get_slot_weight.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/generic_methods.R\n\\name{get_slot_weight}\n\\alias{get_slot_weight}\n\\title{Get the slot weight for effect l}\n\\usage{\nget_slot_weight(model, l)\n}\n\\arguments{\n\\item{model}{SuSiE model object.}\n\n\\item{l}{Effect index.}\n}\n\\value{\nScalar weight (default 1).\n}\n\\description{\nReturns the weight by which effect l's contribution to the fitted\nvalues is scaled. When \\code{model$slot_weights} is NULL (the default),\nall effects have weight 1 and standard SuSiE behavior is recovered.\n}\n\\details{\nSlot weights enable a natural mechanism for adaptively estimating the\nnumber of effects: each slot l can have a weight in [0,1] reflecting\nthe posterior probability that the slot is active. With a suitable\nprior on the number of active effects, this generalizes SuSiE's fixed\nL to a data-driven estimate.\n}\n\\keyword{internal}\n" }, { "path": "man/ibss_finalize.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/iterative_bayesian_stepwise_selection.R\n\\name{ibss_finalize}\n\\alias{ibss_finalize}\n\\title{Finalize IBSS model}\n\\usage{\nibss_finalize(\n data,\n params,\n model,\n elbo = NULL,\n iter = NA_integer_,\n tracking = NULL\n)\n}\n\\arguments{\n\\item{data}{Data object (individual, ss, or rss_lambda)}\n\n\\item{params}{Validated params object}\n\n\\item{model}{Converged model object}\n\n\\item{elbo}{ELBO values (optional)}\n\n\\item{iter}{Number of iterations completed}\n\n\\item{tracking}{Tracking data (optional)}\n}\n\\value{\nFinalized model object with credible sets and PIPs.\n}\n\\description{\nComputes credible sets, PIPs, z-scores, and cleans up temporary\nfields from the model object.\n}\n\\keyword{internal}\n" }, { "path": "man/ibss_initialize.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/iterative_bayesian_stepwise_selection.R\n\\name{ibss_initialize}\n\\alias{ibss_initialize}\n\\alias{ibss_initialize.default}\n\\title{Initialize IBSS model}\n\\usage{\nibss_initialize(data, params)\n\n\\method{ibss_initialize}{default}(data, params)\n}\n\\arguments{\n\\item{data}{Data object (individual, ss, or rss_lambda)}\n\n\\item{params}{Validated params object}\n}\n\\value{\nInitialized model object ready for the IBSS iteration loop.\n}\n\\description{\nCreates and initializes the model object for the IBSS algorithm.\n}\n\\keyword{internal}\n" }, { "path": "man/is_symmetric_matrix.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_utils.R\n\\name{is_symmetric_matrix}\n\\alias{is_symmetric_matrix}\n\\title{Check for symmetric matrix}\n\\usage{\nis_symmetric_matrix(x)\n}\n\\arguments{\n\\item{x}{A matrix to check}\n}\n\\value{\nLogical indicating if x is symmetric\n}\n\\description{\nCheck for symmetric matrix\n}\n\\keyword{internal}\n" }, { "path": "man/kriging_rss.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_rss_utils.R\n\\name{kriging_rss}\n\\alias{kriging_rss}\n\\title{Compute Distribution of z-scores of Variant j Given Other z-scores, and Detect Possible Allele Switch Issue}\n\\usage{\nkriging_rss(\n z,\n R,\n n,\n r_tol = 1e-08,\n s = estimate_s_rss(z, R, n, r_tol, method = \"null-mle\")\n)\n}\n\\arguments{\n\\item{z}{A p-vector of z scores.}\n\n\\item{R}{A p by p symmetric, positive semidefinite correlation\nmatrix.}\n\n\\item{n}{The sample size. (Optional, but highly recommended.)}\n\n\\item{r_tol}{Tolerance level for eigenvalue check of positive\nsemidefinite matrix of R.}\n\n\\item{s}{an estimated s from \\code{estimate_s_rss}}\n}\n\\value{\na list containing a ggplot2 plot object and a table. The plot\n compares observed z score vs the expected value. The possible allele\n switched variants are labeled as red points (log LR > 2 and abs(z) > 2).\n The table summarizes the conditional distribution for each variant\n and the likelihood ratio test. The table has the following columns:\n the observed z scores, the conditional expectation, the conditional\n variance, the standardized differences between the observed z score\n and expected value, the log likelihood ratio statistics.\n}\n\\description{\nUnder the null, the rss model with regularized LD\n matrix is \\eqn{z|R,s ~ N(0, (1-s)R + s I))}. We use a mixture of\n normals to model the conditional distribution of z_j given other z\n scores, \\eqn{z_j | z_{-j}, R, s ~ \\sum_{k=1}^{K} \\pi_k\n N(-\\Omega_{j,-j} z_{-j}/\\Omega_{jj}, \\sigma_{k}^2/\\Omega_{jj})},\n \\eqn{\\Omega = ((1-s)R + sI)^{-1}}, \\eqn{\\sigma_1, ..., \\sigma_k}\n is a grid of fixed positive numbers. We estimate the mixture\n weights \\eqn{\\pi} We detect the possible allele switch issue\n using likelihood ratio for each variant.\n}\n\\examples{\n# See also the vignette, \"Diagnostic for fine-mapping with summary\n# statistics.\"\nset.seed(1)\nn <- 500\np <- 1000\nbeta <- rep(0, p)\nbeta[1:4] <- 0.01\nX <- matrix(rnorm(n * p), nrow = n, ncol = p)\nX <- scale(X, center = TRUE, scale = TRUE)\ny <- drop(X \\%*\\% beta + rnorm(n))\nss <- univariate_regression(X, y)\nR <- cor(X)\nattr(R, \"eigen\") <- eigen(R, symmetric = TRUE)\nzhat <- with(ss, betahat / sebetahat)\ncond_dist <- kriging_rss(zhat, R, n = n)\ncond_dist$plot\n\n}\n" }, { "path": "man/label_diag_truth.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/diagnosis_reports.R\n\\name{label_diag_truth}\n\\alias{label_diag_truth}\n\\title{Label diagnostic table with ground truth TP/FP}\n\\usage{\nlabel_diag_truth(df, fit, causal)\n}\n\\arguments{\n\\item{df}{Diagnostic data.frame (from collect_ash_diag or single iter)}\n\n\\item{fit}{SuSiE fit object}\n\n\\item{causal}{Integer vector of causal variant indices}\n}\n\\value{\ndf with added 'cs_label' column: \"TP\", \"FP\", or \"-\" (no CS)\n}\n\\description{\nFor each slot at the final iteration, check if its CS (if any) contains\na causal variant.\n}\n\\keyword{internal}\n" }, { "path": "man/loglik_mixture_common.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/mixture_prior.R\n\\name{loglik_mixture_common}\n\\alias{loglik_mixture_common}\n\\title{Compute mixture log-Bayes factors and posterior inclusion probabilities}\n\\usage{\nloglik_mixture_common(params, model, ser_stats, l)\n}\n\\arguments{\n\\item{params}{Params object with prior_variance_grid (K-vector) and\nmixture_weights (K-vector summing to 1)}\n\n\\item{model}{Current model object with pi (prior weights)}\n\n\\item{ser_stats}{List with betahat (p-vector) and shat2 (p-vector)}\n\n\\item{l}{Effect index}\n}\n\\value{\nUpdated model with alpha[l,], lbf[l], lbf_variable[l,], lbf_grid[[l]]\n}\n\\description{\nFor each grid point k and variant j, computes the Wakefield approximate\nBayes factor (ABF), then forms the mixture BF as a weighted sum over grid\npoints. Stores the full p x K log-BF matrix in model$lbf_grid[[l]] for\ndownstream use (e.g., mixsqp M-step in susieAnn).\n}\n\\keyword{internal}\n" }, { "path": "man/mr.ash.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/mr.ash.R\n\\name{mr.ash}\n\\alias{mr.ash}\n\\title{Multiple Regression with Adaptive Shrinkage}\n\\usage{\nmr.ash(\n X,\n y,\n Z = NULL,\n sa2 = NULL,\n method_q = c(\"sigma_dep_q\", \"sigma_indep_q\"),\n method_g = c(\"caisa\", \"accelerate\", \"block\"),\n max.iter = 1000,\n min.iter = 1,\n beta.init = NULL,\n update.pi = TRUE,\n pi = NULL,\n update.sigma2 = TRUE,\n sigma2 = NULL,\n update.order = NULL,\n standardize = FALSE,\n intercept = TRUE,\n tol = set_default_tolerance(),\n verbose = TRUE\n)\n}\n\\arguments{\n\\item{X}{The input matrix, of dimension (n,p); each column is a\nsingle predictor; and each row is an observation vector. Here, n is\nthe number of samples and p is the number of predictors. The matrix\ncannot be sparse.}\n\n\\item{y}{The observed continuously-valued responses, a vector of\nlength p.}\n\n\\item{Z}{The covariate matrix, of dimension (n,k), where k is the\nnumber of covariates. This feature is not yet implemented;\n\\code{Z} must be set to \\code{NULL}.}\n\n\\item{sa2}{The vector of prior mixture component variances. The\nvariances should be in increasing order, starting at zero; that is,\n\\code{sort(sa2)} should be the same as \\code{sa2}. When \\code{sa2}\nis \\code{NULL}, the default setting is used, \\code{sa2[k] =\n(2^(0.05*(k-1)) - 1)^2}, for \\code{k = 1:20}. For this default\nsetting, \\code{sa2[1] = 0}, and \\code{sa2[20]} is roughly 1.}\n\n\\item{method_q}{The algorithm used to update the variational\napproximation to the posterior distribution of the regression\ncoefficients, \\code{method = \"sigma_dep_q\"} and \\code{method =\n\"sigma_indep_q\"}, take different approaches to updating the\nresidual variance \\eqn{sigma^2}.}\n\n\\item{method_g}{\\code{method = \"caisa\"}, an abbreviation of\n\"Cooridinate Ascent Iterative Shinkage Algorithm\", fits the model\nby approximate EM; it iteratively updates the variational\napproximation to the posterior distribution of the regression\ncoefficients (the approximate E-step) and the model parameters\n(mixture weights and residual covariance) in an approximate\nM-step. Settings \\code{method = \"block\"} and\n\\code{method = \"accelerate\"} are considered experimental.}\n\n\\item{max.iter}{The maximum number of outer loop iterations allowed.}\n\n\\item{min.iter}{The minimum number of outer loop iterations allowed.}\n\n\\item{beta.init}{The initial estimate of the (approximate)\nposterior mean regression coefficients. This should be \\code{NULL},\nor a vector of length p. When \\code{beta.init} is \\code{NULL}, the\nposterior mean coefficients are all initially set to zero.}\n\n\\item{update.pi}{If \\code{update.pi = TRUE}, the mixture\nproportions in the mixture-of-normals prior are estimated from the\ndata. In the manuscript, \\code{update.pi = TRUE}.}\n\n\\item{pi}{The initial estimate of the mixture proportions\n\\eqn{\\pi_1, \\ldots, \\pi_K}. If \\code{pi} is \\code{NULL}, the\nmixture weights are initialized to \\code{rep(1/K,K)}}, where\n\\code{K = length(sa2).}\n\n\\item{update.sigma2}{If \\code{update.sigma2 = TRUE}, the residual\nvariance \\eqn{sigma^2} is estimated from the data. In the manuscript,\n\\code{update.sigma = TRUE}.}\n\n\\item{sigma2}{The initial estimate of the residual variance,\n\\eqn{\\sigma^2}. If \\code{sigma2 = NULL}, the residual variance is\ninitialized to the empirical variance of the residuals based on the\ninitial estimates of the regression coefficients, \\code{beta.init},\nafter removing linear effects of the intercept and any covariances.}\n\n\\item{update.order}{The order in which the co-ordinate ascent\nupdates for estimating the posterior mean coefficients are\nperformed. \\code{update.order} can be \\code{NULL}, \\code{\"random\"},\nor any permutation of \\eqn{(1,\\ldots,p)}, where \\code{p} is the number\nof columns in the input matrix \\code{X}. When \\code{update.order}\nis \\code{NULL}, the co-ordinate ascent updates are performed in\norder in which they appear in \\code{X}; this is equivalent to\nsetting \\code{update.order = 1:p}. When \\code{update.order =\n\"random\"}, the co-ordinate ascent updates are performed in a\nrandomly generated order, and this random ordering is different at\neach outer-loop iteration.}\n\n\\item{standardize}{The logical flag for standardization of the\ncolumns of X variable, prior to the model fitting. The coefficients\nare always returned on the original scale.}\n\n\\item{intercept}{When \\code{intercept = TRUE}, an intercept is\nincluded in the regression model.}\n\n\\item{tol}{Additional settings controlling behaviour of the model\nfitting algorithm. \\code{tol$convtol} controls the termination\ncriterion for the model fitting. The outer-loop updates stop when\nthe relative L2 change in the estimates of the posterior mean\ncoefficients is less than \\code{convtol}, i.e., \\code{||beta_new -\nbeta_old||_2 / max(1, ||beta_old||_2) < convtol}.\n\\code{tol$epstol} is a small, positive number added to the\nlikelihoods to avoid logarithms of zero.}\n\n\\item{verbose}{If \\code{verbose = TRUE}, some information about the\nstatus of the model fitting is printed to the console.}\n}\n\\value{\nA list object with the following elements:\n\n\\item{intercept}{The estimated intercept.}\n\n\\item{beta}{A vector containing posterior mean estimates of the\n regression coefficients for all predictors.}\n\n\\item{sigma2}{The estimated residual variance.}\n\n\\item{pi}{A vector of containing the estimated mixture\n proportions.}\n\n\\item{iter}{The number of outer-loop iterations that were\n performed.}\n\n\\item{update.order}{The ordering used for performing the\n coordinate-wise updates. For \\code{update.order = \"random\"}, the\n orderings for outer-loop iterations are provided in a vector of\n length \\code{p*max.iter}, where \\code{p} is the number of predictors.}\n\n\\item{varobj}{A vector of length \\code{numiter}, containing the\n value of the variational objective (equal to the negative \"evidence\n lower bound\") attained at each (outer-loop) model fitting\n iteration. Note that the objective does not account for the\n intercept term, even when \\code{intercept = TRUE}; therefore, this\n value shoudl be interpreted as being an approximation to the\n marginal likelihood \\emph{conditional} on the estimate of the\n intercept.}\n\n\\item{data}{The preprocessed data (X, Z, y) provided as input to the model\n fitting algorithm. \\code{data$w} is equal to\n \\code{diag(crossprod(X))}, in which \\code{X} is the preprocessed\n data matrix. Additionally, \\code{data$sa2} gives the prior variances\n used.}\n}\n\\description{\nModel fitting algorithms for Multiple Regression with\n Adaptive Shrinkage (\"Mr.ASH\"). Mr.ASH is a variational empirical\n Bayes (VEB) method for multiple linear regression. The fitting\n algorithms (locally) maximize the approximate marginal likelihood\n (the \"evidence lower bound\", or ELBO) via coordinate-wise updates.\n}\n\\details{\nMr.ASH is a statistical inference method for the following\nmultiple linear regression model: \\deqn{y | X, \\beta, \\sigma^2 ~\nN(X \\beta, \\sigma I_n),} in which the regression coefficients\n\\eqn{\\beta} admit a mixture-of-normals prior, \\deqn{\\beta | \\pi,\n\\sigma ~ g = \\sum_{k=1}^K N(0, \\sigma^2 \\sigma_k^2).} Each mixture\ncomponent in the prior, \\eqn{g}, is a normal density centered at\nzero, with variance \\eqn{\\sigma^2 \\sigma_k^2}. \n\nThe fitting algorithm, it run for a large enough number of\niterations, will find an approximate posterior for the regression\ncoefficients, denoted by \\eqn{q(\\beta)}, residual variance\nparameter \\eqn{sigma^2}, and prior mixture weights \\eqn{\\pi_1,\n\\ldots, \\pi_K} maximizing the evidence lower bound, \\deqn{F(q, \\pi,\n\\sigma^2) = E_q \\log p(y | X, \\beta, \\sigma^2) - \\sum_{j=1}^p\nD_{KL}(q_j || g),} where \\eqn{D_{KL}(q_j || g)} denotes the\nKullback-Leibler (KL) divergence, a measure of the \"distance\"\nbetween (approximate) posterior \\eqn{q_j(\\beta_j)} and prior\n\\eqn{g(\\beta_j)}. The fitting algorithm iteratively updates the\napproximate posteriors \\eqn{q_1, \\ldots, q_p}, separately for each\n\\eqn{j = 1, \\ldots, p} (in an order determined by\n\\code{update.order}), then separately updates the mixture weights\nand \\eqn{\\pi} and residual variance \\eqn{\\sigma^2}. This\ncoordinate-wise update scheme iterates until the convergence\ncriterion is met, or until the algorithm hits an upper bound on\nthe number of iterations (specified by \\code{max.iter}). Coordinate-wise \noptimization algorithms for model fitting are implemented in C++ for \nefficient handling of large-scale data\n\nSee \\sQuote{References} for more details about the model and\nalgorithm.\n}\n\\examples{\n### generate synthetic data\nset.seed(1)\nn = 200\np = 300\nX = matrix(rnorm(n*p),n,p)\nbeta = double(p)\nbeta[1:10] = 1:10\ny = X \\%*\\% beta + rnorm(n)\n\n### fit Mr.ASH\nfit.mr.ash = mr.ash(X,y, method_q = \"sigma_indep_q\")\n#' fit.mr.ash = mr.ash(X,y, method_q = \"sigma_dep_q\")\n\n### prediction routine\nXnew = matrix(rnorm(n*p),n,p)\nynew = Xnew \\%*\\% beta + rnorm(n)\nypred = predict(fit.mr.ash, Xnew)\n\n### test error\nrmse = norm(ynew - ypred, '2') / sqrt(n)\n\n### coefficients\nbetahat = predict(fit.mr.ash, type = \"coefficients\")\n# this equals c(fit.mr.ash$intercept, fit.mr.ash$beta)\n\n}\n\\references{\nY. Kim (2020), Bayesian shrinkage methods for high dimensional\nregression. Ph.D. thesis, University of Chicago.\n}\n\\seealso{\n\\code{\\link{get.full.posterior}}, \\code{\\link{predict.mr.ash}}\n}\n" }, { "path": "man/mr.ash.rss.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/mr.ash.rss.R\n\\name{mr.ash.rss}\n\\alias{mr.ash.rss}\n\\title{Bayesian Multiple Regression with Mixture-of-Normals Prior (RSS)}\n\\usage{\nmr.ash.rss(\n bhat,\n shat,\n R,\n var_y,\n n,\n s0,\n w0,\n sigma2_e = NULL,\n mu1_init = numeric(0),\n tol = 1e-08,\n max_iter = 1e+05,\n z = numeric(0),\n update_w0 = TRUE,\n update_sigma = TRUE,\n compute_ELBO = TRUE,\n standardize = FALSE\n)\n}\n\\arguments{\n\\item{bhat}{Numeric vector of observed effect sizes (standardized).}\n\n\\item{shat}{Numeric vector of standard errors of effect sizes.}\n\n\\item{R}{Numeric matrix of the correlation matrix.}\n\n\\item{var_y}{Numeric value of the variance of the outcome.\nIf NULL, it is set to Inf (effects on standardized scale).}\n\n\\item{n}{Integer value of the sample size.}\n\n\\item{s0}{Numeric vector of prior variances for the mixture components.}\n\n\\item{w0}{Numeric vector of prior weights for the mixture components.}\n\n\\item{sigma2_e}{Numeric value of the initial error variance estimate.\nIf \\code{NULL} (default), initialized to \\code{var_y} (matching\n\\code{mr.ash} behavior of using residual variance with zero\ninitialization), or 1 when \\code{var_y = Inf}.}\n\n\\item{mu1_init}{Numeric vector of initial values for the posterior mean of\nthe coefficients. Default is \\code{numeric(0)} (initialize to zero).}\n\n\\item{tol}{Numeric value of the convergence tolerance. Default is 1e-8.}\n\n\\item{max_iter}{Integer value of the maximum number of iterations.\nDefault is 1e5.}\n\n\\item{z}{Numeric vector of Z-scores. If not provided, computed as\n\\code{bhat / shat}.}\n\n\\item{update_w0}{Logical value indicating whether to update the mixture\nweights. Default is TRUE.}\n\n\\item{update_sigma}{Logical value indicating whether to update the error\nvariance. Default is TRUE.}\n\n\\item{compute_ELBO}{Logical value indicating whether to compute the\nEvidence Lower Bound (ELBO). Default is TRUE.}\n\n\\item{standardize}{Logical value indicating whether to standardize the\ninput data. Default is FALSE.}\n}\n\\value{\nA list containing the following components:\n\\describe{\n \\item{beta}{Numeric vector of posterior mean coefficients (same as mu1).}\n \\item{sigma2}{Numeric value of the residual variance (same as sigma2_e).}\n \\item{pi}{Numeric vector of mixture weights (same as w0).}\n \\item{iter}{Integer, number of iterations performed.}\n \\item{varobj}{Numeric vector of ELBO values per iteration.}\n \\item{mu1}{Numeric vector of the posterior mean of the coefficients.}\n \\item{sigma2_1}{Numeric vector of the posterior variance of the coefficients.}\n \\item{w1}{Numeric matrix of the posterior assignment probabilities.}\n \\item{sigma2_e}{Numeric value of the error variance.}\n \\item{w0}{Numeric vector of the mixture weights.}\n \\item{ELBO}{Numeric value of the Evidence Lower Bound (if \\code{compute_ELBO = TRUE}).}\n}\n}\n\\description{\nThis function performs Bayesian multiple regression with a\n mixture-of-normals prior using summary statistics (RSS: Regression with\n Summary Statistics). It uses a C++ implementation for efficient computation.\n}\n\\examples{\n# Generate example data\nset.seed(985115)\nn <- 350\np <- 16\nsigmasq_error <- 0.5\nzeroes <- rbinom(p, 1, 0.6)\nbeta.true <- rnorm(p, 1, sd = 4)\nbeta.true[zeroes] <- 0\n\nX <- cbind(matrix(rnorm(n * p), nrow = n))\nX <- scale(X, center = TRUE, scale = FALSE)\ny <- X \\%*\\% matrix(beta.true, ncol = 1) + rnorm(n, 0, sqrt(sigmasq_error))\ny <- scale(y, center = TRUE, scale = FALSE)\n\n# Set the prior\nK <- 9\nsigma0 <- c(0.001, .1, .5, 1, 5, 10, 20, 30, .005)\nomega0 <- rep(1 / K, K)\n\n# Calculate summary statistics\nb.hat <- sapply(1:p, function(j) {\n summary(lm(y ~ X[, j]))$coefficients[-1, 1]\n})\ns.hat <- sapply(1:p, function(j) {\n summary(lm(y ~ X[, j]))$coefficients[-1, 2]\n})\nR.hat <- cor(X)\nvar_y <- var(y)\nsigmasq_init <- 1.5\n\n# Run mr.ash.rss\nout <- mr.ash.rss(b.hat, s.hat,\n R = R.hat, var_y = var_y, n = n,\n sigma2_e = sigmasq_init, s0 = sigma0, w0 = omega0,\n mu1_init = rep(0, ncol(X)), tol = 1e-8, max_iter = 1e5,\n update_w0 = TRUE, update_sigma = TRUE, compute_ELBO = TRUE,\n standardize = FALSE\n)\n\n}\n" }, { "path": "man/path.order.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/univariate_regression.R\n\\name{path.order}\n\\alias{path.order}\n\\title{Ordering of Predictors by Regularization Path}\n\\usage{\npath.order(fit)\n}\n\\arguments{\n\\item{fit}{A fit object whose \\code{coef()} method returns a matrix of\ncoefficients with the intercept in the first row and one column per\npenalty strength (as produced by typical penalized-regression\nimplementations).}\n}\n\\value{\nAn ordering of the predictors.\n}\n\\description{\nThis function determines an ordering of the predictors\n based on the regularization path of the penalized regression; in\n particular, the predictors are ordered based on the order in which\n the coefficients are included in the model as the penalty strength\n decreases.\n}\n\\examples{\n### generate synthetic data\nset.seed(1)\nn = 200\np = 30\nX = matrix(rnorm(n*p),n,p)\nbeta = double(p)\nbeta[1:10] = 1:10\ny = X \\%*\\% beta + rnorm(n)\n\n### build a minimal example 'fit' object with the same structure as a\n### fit from a penalized regression: a coefficient matrix with the\n### intercept in row 1 and one column per (decreasing) penalty value.\nbeta_path = matrix(0, p + 1, p)\nfor (k in 1:p) beta_path[k + 1, k:p] = 1\nfit = list(coefficients = beta_path)\norder = path.order(fit)\n\n}\n" }, { "path": "man/post_loglik_prior_hook.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/single_effect_regression.R\n\\name{post_loglik_prior_hook}\n\\alias{post_loglik_prior_hook}\n\\title{Post-loglik prior-update hook}\n\\usage{\npost_loglik_prior_hook(data, params, model, ser_stats, l, V_init)\n}\n\\description{\nS3 generic, called after `loglik` / posterior moments / KL.\nDefault routes to `optimize_prior_variance` for `EM`. Returns\n`list(V, model)`.\n}\n\\keyword{internal}\n" }, { "path": "man/pre_loglik_prior_hook.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/single_effect_regression.R\n\\name{pre_loglik_prior_hook}\n\\alias{pre_loglik_prior_hook}\n\\title{Pre-loglik prior-update hook}\n\\usage{\npre_loglik_prior_hook(data, params, model, ser_stats, l, V_init)\n}\n\\description{\nS3 generic, called between SER stats and `loglik`. Default\nroutes to `optimize_prior_variance` for `optim` / `uniroot` /\n`simple`. Returns `list(V, model)`.\n}\n\\keyword{internal}\n" }, { "path": "man/predict.mr.ash.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/mr.ash.R\n\\name{predict.mr.ash}\n\\alias{predict.mr.ash}\n\\title{Predict Outcomes or Extract Coefficients from Mr.ASH Fit}\n\\usage{\n\\method{predict}{mr.ash}(object, newx = NULL, type = c(\"response\", \"coefficients\"), ...)\n}\n\\arguments{\n\\item{object}{A mr_ash fit, usually the result of calling\n\\code{mr.ash}.}\n\n\\item{newx}{The input matrix, of dimension (n,p); each column is a\nsingle predictor; and each row is an observation vector. Here, n is\nthe number of samples and p is the number of predictors. When\n\\code{newx} is \\code{NULL}, the fitted values for the training data\nare provided.}\n\n\\item{type}{The type of output. For \\code{type = \"response\"},\npredicted or fitted outcomes are returned; for \\code{type =\n\"coefficients\"}, the estimated coefficients are returned.}\n\n\\item{...}{Additional arguments passed to the default S3 method.}\n}\n\\value{\nFor \\code{type = \"response\"}, predicted or fitted outcomes\nare returned; for \\code{type = \"coefficients\"}, the estimated\ncoefficients are returned.\n}\n\\description{\nThis function predicts outcomes (y) given the observed\n variables (X) and a Mr.ASH model; alternatively, retrieve the\n estimates of the regression coefficients.\n}\n\\examples{\n## generate synthetic data\nset.seed(1)\nn = 200\np = 300\nX = matrix(rnorm(n*p),n,p)\nbeta = double(p)\nbeta[1:10] = 1:10\ny = X \\%*\\% beta + rnorm(n)\n\n## fit mr.ash\nfit.mr.ash = mr.ash(X, y)\n\n## predict\nXnew = matrix(rnorm(n*p),n,p)\nypred = predict(fit.mr.ash, Xnew)\n\n}\n" }, { "path": "man/predict.susie.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/predict.susie.R\n\\name{predict.susie}\n\\alias{predict.susie}\n\\title{Predict outcomes or extract coefficients from susie fit.}\n\\usage{\n\\method{predict}{susie}(object, newx = NULL, type = c(\"response\", \"coefficients\"), ...)\n}\n\\arguments{\n\\item{object}{A susie fit.}\n\n\\item{newx}{A new value for X at which to do predictions.}\n\n\\item{type}{The type of output. For \\code{type = \"response\"},\npredicted or fitted outcomes are returned; for \\code{type =\n\"coefficients\"}, the estimated coefficients are returned.}\n\n\\item{\\dots}{Other arguments used by generic predict function. These\nextra arguments are not used here.}\n}\n\\value{\nFor \\code{type = \"response\"}, predicted or fitted outcomes\n are returned; for \\code{type = \"coefficients\"}, the estimated\n coefficients are returned. If the susie fit has intercept =\n \\code{NA} (which is common when using \\code{susie_ss}) then\n predictions are computed using an intercept of 0, and a warning is\n emitted.\n}\n\\description{\nPredict outcomes or extract coefficients from susie fit.\n}\n" }, { "path": "man/print.summary.susie_post_outcome_configuration.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_post_outcome_configuration.R\n\\name{print.summary.susie_post_outcome_configuration}\n\\alias{print.summary.susie_post_outcome_configuration}\n\\title{Print a summary.susie_post_outcome_configuration object}\n\\usage{\n\\method{print}{summary.susie_post_outcome_configuration}(x, ...)\n}\n\\arguments{\n\\item{x}{Output of [summary.susie_post_outcome_configuration()].}\n\n\\item{...}{Ignored.}\n}\n\\value{\nThe input invisibly.\n}\n\\description{\nPretty-prints the tidy tables built by\n[summary.susie_post_outcome_configuration()] with optional ANSI color\nhighlighting. See that page for the color encoding.\n}\n\\seealso{\n[summary.susie_post_outcome_configuration()]\n}\n" }, { "path": "man/resolve_mixture_prior.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/mixture_prior.R\n\\name{resolve_mixture_prior}\n\\alias{resolve_mixture_prior}\n\\title{Resolve fixed mixture prior parameters}\n\\usage{\nresolve_mixture_prior(\n estimate_prior_method,\n estimate_prior_variance,\n prior_variance_grid,\n mixture_weights\n)\n}\n\\description{\nCalled from susie, susie_ss, and susie_rss to handle the\nprior_variance_grid / mixture_weights parameters. When\nprior_variance_grid is non-NULL, overrides estimate_prior_method\nto \"fixed_mixture\" and validates inputs. Returns a list with\nthe resolved estimate_prior_method, estimate_prior_variance,\nprior_variance_grid, and mixture_weights.\n}\n\\keyword{internal}\n" }, { "path": "man/safe_cor.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_utils.R\n\\name{safe_cor}\n\\alias{safe_cor}\n\\title{Computes correlation matrix from data matrix\nHandles constant columns without warnings - returns 0 correlation for constant cols\nUses Rfast::cora when available (much faster for large matrices), falls back\nto crossprod-based computation otherwise.}\n\\usage{\nsafe_cor(X)\n}\n\\arguments{\n\\item{X}{Data matrix (n x p)}\n}\n\\value{\nCorrelation matrix (p x p)\n}\n\\description{\nComputes correlation matrix from data matrix\nHandles constant columns without warnings - returns 0 correlation for constant cols\nUses Rfast::cora when available (much faster for large matrices), falls back\nto crossprod-based computation otherwise.\n}\n\\keyword{internal}\n" }, { "path": "man/safe_cov2cor.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_utils.R\n\\name{safe_cov2cor}\n\\alias{safe_cov2cor}\n\\title{Converts covariance matrix to correlation matrix\nConstant variables (zero variance) get correlation 0 with others, 1 with self}\n\\usage{\nsafe_cov2cor(V)\n}\n\\arguments{\n\\item{V}{Covariance matrix}\n}\n\\value{\nCorrelation matrix\n}\n\\description{\nConverts covariance matrix to correlation matrix\nConstant variables (zero variance) get correlation 0 with others, 1 with self\n}\n\\keyword{internal}\n" }, { "path": "man/scale_design_matrix.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_utils.R\n\\name{scale_design_matrix}\n\\alias{scale_design_matrix}\n\\title{Scale design matrix using centering and scaling parameters}\n\\usage{\nscale_design_matrix(X, center = NULL, scale = NULL)\n}\n\\arguments{\n\\item{X}{Matrix to scale (n x p)}\n\n\\item{center}{Vector of column means to subtract (length p), or NULL}\n\n\\item{scale}{Vector of column SDs to divide by (length p), or NULL}\n}\n\\value{\nScaled matrix with centered and scaled columns\n}\n\\description{\nApplies column-wise centering and scaling to match the space used by\ncompute_XtX() and compute_Xty() for unmappable effects methods.\n}\n\\keyword{internal}\n" }, { "path": "man/set_prior_variance_l.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/model_methods.R\n\\name{set_prior_variance_l}\n\\alias{set_prior_variance_l}\n\\title{Set prior variance for effect l}\n\\usage{\nset_prior_variance_l(model, l, V)\n}\n\\description{\nSet prior variance for effect l\n}\n\\keyword{internal}\n" }, { "path": "man/slot_prior_betabinom.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/slot_prior.R\n\\name{slot_prior_betabinom}\n\\alias{slot_prior_betabinom}\n\\alias{slot_prior_poisson}\n\\title{Slot Activity Prior for SuSiE}\n\\usage{\nslot_prior_betabinom(\n a_beta = NULL,\n b_beta = NULL,\n c_hat_init = NULL,\n skip_threshold_multiplier = 0\n)\n\nslot_prior_poisson(\n C,\n nu = NULL,\n update_schedule = c(\"sequential\", \"batch\"),\n c_hat_init = NULL,\n skip_threshold_multiplier = 0\n)\n}\n\\arguments{\n\\item{a_beta}{Shape parameter for the Beta prior on inclusion\nprobability rho. Default 1.}\n\n\\item{b_beta}{Shape parameter for the Beta prior on inclusion\nprobability rho. Default 2, giving a moderate sparsity preference\nwith \\code{E[rho] = 1/3 ~ 0.33}. Setting \\code{a_beta = 1}\nand \\code{b_beta = 1} gives a uniform prior on [0,1], providing\nautomatic multiplicity correction following Scott and Berger (2010).}\n\n\\item{c_hat_init}{Optional numeric L-vector of initial slot activity\nprobabilities for warm-starting. If NULL, initialized at the\nprior mean.}\n\n\\item{skip_threshold_multiplier}{Multiplier for the adaptive skip\nthreshold. Slots with c_hat below this fraction of the baseline\n(prior with zero signal) are skipped. Default 0 (no skipping).\nThe threshold is recomputed after each sweep from the current\nmodel state, and is set to 0 on the first sweep so all slots\nare evaluated at least once.}\n\n\\item{C}{Expected number of causal variants for the Gamma-Poisson prior\non the per-block causal rate. Must be positive. Not used by\n\\code{slot_prior_betabinom}.}\n\n\\item{nu}{Overdispersion parameter for the Gamma-Poisson prior on the\nper-block causal rate. Not used by \\code{slot_prior_betabinom}.\nLarger values give stronger shrinkage toward C. Default 8 when\nnot specified.}\n\n\\item{update_schedule}{How the Gamma shape parameter is updated\nduring IBSS iterations (Gamma-Poisson only; ignored for\nBeta-Binomial which is inherently sequential).\n\\code{\"batch\"} updates once per full sweep (standard CAVI).\n\\code{\"sequential\"} updates after each slot (faster convergence\nper iteration, used by susieAnn).}\n}\n\\value{\nA list of class \\code{\"slot_prior\"} with the appropriate\n subclass.\n}\n\\description{\nConstruct a prior specification for the slot activity\n model, which regularizes the number of active single effects in\n SuSiE. Two prior families are available: Beta-Binomial (default,\n recommended for single-locus) and Gamma-Poisson (recommended for\n genome-wide applications via susieAnn).\n}\n\\details{\nTwo prior types are available:\n\\describe{\n \\item{\\code{slot_prior_betabinom}}{Uses a Beta-Binomial model\n for slot inclusion. The inclusion probability rho is given a\n Beta(a_beta, b_beta) prior and integrated out analytically,\n yielding an adaptive multiplicity correction that penalizes\n less when more slots are active. This is the recommended\n default for single-locus applications. See Scott and Berger\n (2010) for the theoretical justification.}\n \\item{\\code{slot_prior_poisson}}{Uses the Gamma-Poisson model\n with Poisson approximation for slot indicators. Recommended\n for genome-wide applications via susieAnn, where C and nu\n are estimated across loci.}\n}\n}\n\\examples{\n# Default: Beta-Binomial with Beta(1, 2) prior on inclusion probability\nslot_prior_betabinom()\n\n# Gamma-Poisson for susieAnn\nslot_prior_poisson(C = 5, nu = 8)\n\n# Pass to susie\n# fit <- susie(X, y, slot_prior = slot_prior_betabinom())\n\n}\n\\references{\nScott, J. G. and Berger, J. O. (2010). Bayes and empirical-Bayes\nmultiplicity adjustment in the variable-selection problem.\n\\emph{Annals of Statistics}, 38(5), 2587--2619.\n}\n" }, { "path": "man/summary.susie.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/summary.susie.R\n\\name{summary.susie}\n\\alias{summary.susie}\n\\alias{print.summary.susie}\n\\title{Summarize Susie Fit.}\n\\usage{\n\\method{summary}{susie}(object, ...)\n\n\\method{print}{summary.susie}(x, ...)\n}\n\\arguments{\n\\item{object}{A susie fit.}\n\n\\item{\\dots}{Additional arguments passed to the generic \\code{summary}\nor \\code{print.summary} method.}\n\n\\item{x}{A susie summary.}\n}\n\\value{\n\\code{summary.susie} returns a list containing a data frame\n of variables and a data frame of credible sets.\n}\n\\description{\n\\code{summary} method for the \\dQuote{susie} class.\n}\n" }, { "path": "man/summary.susie_post_outcome_configuration.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_post_outcome_configuration.R\n\\name{summary.susie_post_outcome_configuration}\n\\alias{summary.susie_post_outcome_configuration}\n\\title{Summarise a susie_post_outcome_configuration result}\n\\usage{\n\\method{summary}{susie_post_outcome_configuration}(\n object,\n prob_thresh = 0.8,\n ambiguous_lower = 0.5,\n signal_only = TRUE,\n color = \"auto\",\n ...\n)\n}\n\\arguments{\n\\item{object}{Output of [susie_post_outcome_configuration()].}\n\n\\item{prob_thresh}{Threshold above which `marginal_prob` counts as a\nsignal (default `0.8`).}\n\n\\item{ambiguous_lower}{Lower edge of the \"ambiguous\" band for the\nSuSiEx color coding: marginals in\n`[ambiguous_lower, prob_thresh)` are colored yellow. Default `0.5`.\nSet to `prob_thresh` to disable the band.}\n\n\\item{signal_only}{Logical. If `TRUE` (default), drop CS tuples where\nno trait is active and drop coloc rows whose dominant hypothesis is\nH0. Pass `FALSE` to keep everything.}\n\n\\item{color}{One of `\"auto\"` (default; honors [crayon::has_color()]),\n`TRUE` (force colors on), or `FALSE` (force them off).}\n\n\\item{...}{Ignored.}\n}\n\\value{\nA list of class `\"summary.susie_post_outcome_configuration\"`\nwith components:\n\\describe{\n \\item{`$susiex`}{`data.frame` (or `NULL` when no signals): one row per\n CS tuple. Columns: `tuple` (e.g. `\"(1,1,1)\"`), one numeric column\n per trait carrying that trait's `marginal_prob`, `top_pattern`\n (binary configuration string for the most-probable configuration),\n `top_prob` (its probability).}\n \\item{`$coloc_pairwise`}{`data.frame` (or `NULL`): the original coloc\n table extended with `verdict` (named hypothesis label) and `top_pp`\n (the dominant PP value).}\n \\item{`$susiex_n_total`, `$susiex_n_kept`, `$coloc_n_total`,\n `$coloc_n_kept`}{row counts before and after `signal_only`\n filtering, used by the print method to footer hidden rows.}\n \\item{`$prob_thresh`, `$ambiguous_lower`, `$signal_only`, `$color`}{\n parameters echoed for the print method.}\n}\n}\n\\description{\nBuilds tidy tables from the nested list returned by\n[susie_post_outcome_configuration()] and prints them with ANSI color\nhighlighting via [print.summary.susie_post_outcome_configuration()].\nThe summary itself is an S3 object: index `$susiex` and\n`$coloc_pairwise` to grab the data.frames for downstream use.\n}\n\\details{\nColor encoding (when ANSI colors are available):\n\\itemize{\n \\item SuSiEx per-trait marginal probability: bold dark green when\n `>= prob_thresh` (active), yellow when in\n `[ambiguous_lower, prob_thresh)`, dim otherwise. The `active`\n logical from the raw result is encoded by color and is not shown\n as a separate column.\n \\item Coloc verdict: bold dark green for H4 (shared causal), magenta\n for H3 (distinct causals), blue for H1 or H2 (single-trait causal),\n dim for H0 (no signal). The dominant PP per row is bolded.\n}\n\nRobustness: this method is defensive against malformed input. Empty\nlists, NULL components, missing fields, length-mismatched per-trait\nvectors, trait names that collide with reserved columns\n(`tuple`, `top_pattern`, `top_prob`), and coloc data.frames that\nlack some optional columns (`hit1`, `hit2`) all degrade gracefully\nrather than erroring.\n}\n\\seealso{\n[susie_post_outcome_configuration()],\n [print.summary.susie_post_outcome_configuration()]\n}\n" }, { "path": "man/susie.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie.R\n\\name{susie}\n\\alias{susie}\n\\title{Sum of Single Effects (SuSiE) Regression}\n\\usage{\nsusie(\n X,\n y,\n L = min(10, ncol(X)),\n scaled_prior_variance = 0.2,\n residual_variance = NULL,\n prior_weights = NULL,\n null_weight = 0,\n standardize = TRUE,\n intercept = TRUE,\n estimate_residual_variance = TRUE,\n estimate_residual_method = c(\"MoM\", \"MLE\", \"NIG\"),\n estimate_prior_variance = TRUE,\n estimate_prior_method = c(\"optim\", \"EM\", \"simple\"),\n prior_variance_grid = NULL,\n mixture_weights = NULL,\n unmappable_effects = c(\"none\", \"inf\", \"ash\", \"ash_filter_archived\"),\n check_null_threshold = 0,\n prior_tol = 1e-09,\n residual_variance_upperbound = Inf,\n model_init = NULL,\n s_init = NULL,\n coverage = 0.95,\n min_abs_corr = 0.5,\n compute_univariate_zscore = FALSE,\n na.rm = FALSE,\n max_iter = 100,\n L_greedy = NULL,\n greedy_lbf_cutoff = 0.1,\n tol = 1e-04,\n convergence_method = c(\"elbo\", \"pip\"),\n verbose = FALSE,\n track_fit = FALSE,\n residual_variance_lowerbound = NULL,\n refine = FALSE,\n n_purity = 100,\n alpha0 = 1/sqrt(nrow(X)),\n beta0 = 1/sqrt(nrow(X)),\n init_only = FALSE,\n slot_prior = NULL\n)\n}\n\\arguments{\n\\item{X}{An n by p matrix of covariates.}\n\n\\item{y}{The observed responses, a vector of length n.}\n\n\\item{L}{Maximum number of non-zero effects in the model. If L is larger than\nthe number of covariates, p, L is set to p.}\n\n\\item{scaled_prior_variance}{The prior variance, divided by\n\\code{var(y)} (or by \\code{(1/(n-1))yty} for\n\\code{susie_ss}); that is, the prior variance of each\nnon-zero element of b is \\code{var(y) * scaled_prior_variance}. The\nvalue provided should be either a scalar or a vector of length\n\\code{L}. If \\code{estimate_prior_variance = TRUE}, this provides\ninitial estimates of the prior variances.}\n\n\\item{residual_variance}{Variance of the residual. If\n\\code{estimate_residual_variance = TRUE}, this value provides the\ninitial estimate of the residual variance. By default, it is set to\n\\code{var(y)} in \\code{susie} and \\code{(1/(n-1))yty} in\n\\code{susie_ss}.}\n\n\\item{prior_weights}{A vector of length p, in which each entry\ngives the prior probability that corresponding column of X has a\nnonzero effect on the outcome, y. The weights are internally\nnormalized to sum to 1. When \\code{NULL} (the default), uniform\nprior weights are used (each variable is assigned probability\n\\code{1/p}).}\n\n\\item{null_weight}{Prior probability of no effect (a number between 0 and 1,\nand cannot be exactly 1).}\n\n\\item{standardize}{If \\code{standardize = TRUE}, standardize the\ncolumns of X to unit variance prior to fitting (or equivalently\nstandardize XtX and Xty to have the same effect). Note that\n\\code{scaled_prior_variance} specifies the prior on the\ncoefficients of X \\emph{after} standardization (if it is\nperformed). If you do not standardize, you may need to think more\ncarefully about specifying \\code{scaled_prior_variance}. Whatever\nyour choice, the coefficients returned by \\code{coef} are given for\n\\code{X} on the original input scale. Any column of \\code{X} that\nhas zero variance is not standardized.}\n\n\\item{intercept}{If \\code{intercept = TRUE}, the intercept is\nfitted; it \\code{intercept = FALSE}, the intercept is set to\nzero. Setting \\code{intercept = FALSE} is generally not\nrecommended.}\n\n\\item{estimate_residual_variance}{If\n\\code{estimate_residual_variance = TRUE}, the residual variance is\nestimated, using \\code{residual_variance} as an initial value. If\n\\code{estimate_residual_variance = FALSE}, the residual variance is\nfixed to the value supplied by \\code{residual_variance}.}\n\n\\item{estimate_residual_method}{The method used for estimating residual variance.\nFor the original SuSiE model, \"MLE\" and \"MoM\" estimation is equivalent, but for\nthe infinitesimal model, \"MoM\" is more stable. We recommend using \"NIG\"\nwhen n < 80 for improved coverage, although it is currently only implemented\nfor individual-level data.}\n\n\\item{estimate_prior_variance}{If \\code{estimate_prior_variance =\nTRUE}, the prior variance is estimated (this is a separate\nparameter for each of the L effects). If provided,\n\\code{scaled_prior_variance} is then used as an initial value for\nthe optimization. When \\code{estimate_prior_variance = FALSE}, the\nprior variance for each of the L effects is determined by the\nvalue supplied to \\code{scaled_prior_variance}.}\n\n\\item{estimate_prior_method}{The method used for estimating prior\nvariance. When \\code{estimate_prior_method = \"simple\"} is used, the\nlikelihood at the specified prior variance is compared to the\nlikelihood at a variance of zero, and the setting with the larger\nlikelihood is retained. When \\code{prior_variance_grid} is provided,\nthis is automatically set to \\code{\"fixed_mixture\"}.}\n\n\\item{prior_variance_grid}{Numeric vector of K prior variances defining\na mixture-of-normals prior on effect sizes. When provided, the SER\nevaluates Bayes factors at each grid point and forms a mixture BF\nweighted by \\code{mixture_weights}. This bypasses the scalar prior\nvariance optimization. Default is \\code{NULL} (standard scalar V path).}\n\n\\item{mixture_weights}{Numeric vector of K non-negative weights summing\nto 1, giving the mixture proportions for the variance grid. Default is\n\\code{NULL}, which uses uniform weights when \\code{prior_variance_grid}\nis provided.}\n\n\\item{unmappable_effects}{The method for modeling unmappable effects:\n\"none\", \"inf\", \"ash\".}\n\n\\item{check_null_threshold}{When the prior variance is estimated,\ncompare the estimate with the null, and set the prior variance to\nzero unless the log-likelihood using the estimate is larger by this\nthreshold amount. For example, if you set\n\\code{check_null_threshold = 0.1}, this will \"nudge\" the estimate\ntowards zero when the difference in log-likelihoods is small. A\nnote of caution that setting this to a value greater than zero may\nlead the IBSS fitting procedure to occasionally decrease the ELBO. This\nsetting is disabled when using \\code{unmappable_effects = \"inf\"} or\n\\code{unmappable_effects = \"ash\"}.}\n\n\\item{prior_tol}{When the prior variance is estimated, compare the\nestimated value to \\code{prior_tol} at the end of the computation,\nand exclude a single effect from PIP computation if the estimated\nprior variance is smaller than this tolerance value.}\n\n\\item{residual_variance_upperbound}{Upper limit on the estimated\nresidual variance. It is only relevant when\n\\code{estimate_residual_variance = TRUE}.}\n\n\\item{model_init}{A previous susie fit with which to initialize.}\n\n\\item{s_init}{Deprecated alias for \\code{model_init}.}\n\n\\item{coverage}{A number between 0 and 1 specifying the\n\\dQuote{coverage} of the estimated confidence sets.}\n\n\\item{min_abs_corr}{Minimum absolute correlation allowed in a\ncredible set. The default, 0.5, corresponds to a squared\ncorrelation of 0.25, which is a commonly used threshold for\ngenotype data in genetic studies. This \"purity\" filter is\napplied to the CSs reported in the fit object, so the CS list\nreturned here may be a subset of the one produced by calling\n\\code{\\link{susie_get_cs}} on the same fit without passing\n\\code{X} or \\code{Xcorr} (in which case the purity filter is\nskipped).}\n\n\\item{compute_univariate_zscore}{If \\code{compute_univariate_zscore\n= TRUE}, the univariate regression z-scores are outputted for each\nvariable.}\n\n\\item{na.rm}{Drop any missing values in y from both X and y.}\n\n\\item{max_iter}{Maximum number of IBSS iterations to perform.}\n\n\\item{L_greedy}{Integer or \\code{NULL}. When non-\\code{NULL}, run a\ngreedy outer loop that grows the number of effects from\n\\code{L_greedy} up to \\code{L} in linear steps until the fit\nsaturates. The default \\code{NULL} runs the usual fixed-\\code{L}\nfit.}\n\n\\item{greedy_lbf_cutoff}{Numeric saturation threshold for the\n\\code{L_greedy} outer loop. Default is 0.1.}\n\n\\item{tol}{tol A small, non-negative number specifying the convergence\ntolerance for the IBSS fitting procedure.}\n\n\\item{convergence_method}{When \\code{converge_method = \"elbo\"} the fitting\nprocedure halts when the difference in the variational lower bound, or\n\\dQuote{ELBO} (the objective function to be maximized), is\nless than \\code{tol}. When \\code{converge_method = \"pip\"} the fitting\nprocedure halts when the maximum absolute difference in \\code{alpha} is less\nthan \\code{tol}.}\n\n\\item{verbose}{If \\code{verbose = TRUE}, the algorithm's progress,\na summary of the optimization settings, and refinement progress (if\n\\code{refine = TRUE}) are printed to the console.}\n\n\\item{track_fit}{If \\code{track_fit = TRUE}, \\code{trace}\nis also returned containing detailed information about the\nestimates at each iteration of the IBSS fitting procedure.}\n\n\\item{residual_variance_lowerbound}{Lower limit on the estimated\nresidual variance. It is only relevant when\n\\code{estimate_residual_variance = TRUE}.}\n\n\\item{refine}{If \\code{refine = TRUE}, then an additional\niterative refinement procedure is used, after the IBSS algorithm,\nto check and escape from local optima (see details).}\n\n\\item{n_purity}{Passed as argument \\code{n_purity} to\n\\code{\\link{susie_get_cs}}.}\n\n\\item{alpha0}{Numerical parameter for the NIG prior when using\n\\code{estimate_residual_method = \"NIG\"}. Defaults to\n\\code{1/sqrt(n)}, where \\code{n} is the sample size. When calling\n\\code{susie_rss} with NIG, \\code{n} must be supplied; otherwise\nvalidation errors.}\n\n\\item{beta0}{Numerical parameter for the NIG prior when using\n\\code{estimate_residual_method = \"NIG\"}. Defaults to\n\\code{1/sqrt(n)}, where \\code{n} is the sample size. When calling\n\\code{susie_rss} with NIG, \\code{n} must be supplied; otherwise\nvalidation errors.}\n\n\\item{init_only}{Logical. If \\code{TRUE}, return a list with\n\\code{data} and \\code{params} objects without running the IBSS\nalgorithm. Used by packages like susieAnn that implement their own\nouter loop around SuSiE's building blocks. Default is \\code{FALSE}.}\n\n\\item{slot_prior}{Optional slot activity prior created by\n\\code{\\link{slot_prior_betabinom}} or \\code{\\link{slot_prior_poisson}}.\nUse \\code{slot_prior_betabinom(a_beta, b_beta)} for the usual\nsingle-locus setting; it places a Beta-Binomial prior on the\nnumber of active effects and gives an adaptive multiplicity\ncorrection. Use \\code{slot_prior_poisson(C, nu)} when you want a\nGamma-Poisson prior centered on an expected number \\code{C} of\nactive effects. When supplied, each single-effect slot has an\nestimated activity probability \\code{c_hat}; fitted values and\nPIPs are weighted by these activity probabilities, and convergence\nis checked using \\code{convergence_method = \"pip\"}.}\n}\n\\value{\nA \\code{\"susie\"} object with some or all of the following elements:\n\n\\item{alpha}{An L by p matrix of posterior inclusion probabilities.}\n\n\\item{mu}{An L by p matrix of posterior means, conditional on inclusion.}\n\n\\item{mu2}{An L by p matrix of posterior second moments, conditional on\n inclusion.}\n\n\\item{Xr}{A vector of length n, equal to \\code{X \\%*\\% colSums(alpha * mu)}.}\n\n\\item{lbf}{Log-Bayes Factor for each single effect.}\n\n\\item{lbf_variable}{Log-Bayes Factor for each variable and single effect.}\n\n\\item{intercept}{Intercept (fixed or estimated).}\n\n\\item{sigma2}{Residual variance (fixed or estimated).}\n\n\\item{V}{Prior variance of the non-zero elements of b.}\n\n\\item{elbo}{The variational lower bound (or ELBO) achieved at each iteration.}\n\n\\item{fitted}{Vector of length n containing the fitted values.}\n\n\\item{sets}{Credible sets estimated from model fit.}\n\n\\item{pip}{A vector of length p giving the marginal posterior inclusion\n probabilities.}\n\n\\item{z}{A vector of univariate z-scores.}\n\n\\item{niter}{Number of IBSS iterations performed.}\n\n\\item{converged}{\\code{TRUE} or \\code{FALSE} indicating whether\n the IBSS converged to a solution within the chosen tolerance\n level.}\n\n\\item{theta}{If \\code{unmappable_effects = \"inf\"} or\n \\code{unmappable_effects = \"ash\"}, then \\code{theta} is a p-vector of posterior\n means for the unmappable effects.}\n\n\\item{tau2}{If \\code{unmappable_effects = \"inf\"} or\n \\code{unmappable_effects = \"ash\"}, then \\code{tau2} is the unmappable variance.}\n}\n\\description{\nPerforms a sparse Bayesian multiple linear regression\nof y on X, using the \"Sum of Single Effects\" model from Wang et al\n(2020). In brief, this function fits the regression model \\eqn{y =\n\\mu + X b + e}, where elements of \\eqn{e} are \\emph{i.i.d.} normal\nwith zero mean and variance \\code{residual_variance}, \\eqn{\\mu} is\nan intercept term and \\eqn{b} is a vector of length p representing\nthe effects to be estimated. The \\dQuote{susie assumption} is that\n\\eqn{b = \\sum_{l=1}^L b_l} where each \\eqn{b_l} is a vector of\nlength p with exactly one non-zero element. The prior on the\nnon-zero element is normal with zero mean and variance \\code{var(y)\n* scaled_prior_variance}. The value of \\code{L} is fixed, and\nshould be chosen to provide a reasonable upper bound on the number\nof non-zero effects to be detected. Typically, the hyperparameters\n\\code{residual_variance} and \\code{scaled_prior_variance} will be\nestimated during model fitting, although they can also be fixed as\nspecified by the user. See functions \\code{\\link{susie_get_cs}} and\nother functions of form \\code{susie_get_*} to extract the most\ncommonly-used results from a susie fit.\n\n#' @details The function \\code{susie} implements the IBSS algorithm\nfrom Wang et al (2020). The option \\code{refine = TRUE} implements\nan additional step to help reduce problems caused by convergence of\nthe IBSS algorithm to poor local optima (which is rare in our\nexperience, but can provide misleading results when it occurs). The\nrefinement step incurs additional computational expense that\nincreases with the number of CSs found in the initial run.\n\nThe function \\code{susie_ss} implements essentially the same\nalgorithms, but using sufficient statistics. (The statistics are\nsufficient for the regression coefficients \\eqn{b}, but not for the\nintercept \\eqn{\\mu}; see below for how the intercept is treated.)\nIf the sufficient statistics are computed correctly then the\nresults from \\code{susie_ss} should be the same as (or very\nsimilar to) \\code{susie}, although runtimes will differ as\ndiscussed below. The sufficient statistics are the sample\nsize \\code{n}, and then the p by p matrix \\eqn{X'X}, the p-vector\n\\eqn{X'y}, and the sum of squared y values \\eqn{y'y}, all computed\nafter centering the columns of \\eqn{X} and the vector \\eqn{y} to\nhave mean 0; these can be computed using \\code{compute_suff_stat}.\n\nThe handling of the intercept term in \\code{susie_ss} needs\nsome additional explanation. Computing the summary data after\ncentering \\code{X} and \\code{y} effectively ensures that the\nresulting posterior quantities for \\eqn{b} allow for an intercept\nin the model; however, the actual value of the intercept cannot be\nestimated from these centered data. To estimate the intercept term\nthe user must also provide the column means of \\eqn{X} and the mean\nof \\eqn{y} (\\code{X_colmeans} and \\code{y_mean}). If these are not\nprovided, they are treated as \\code{NA}, which results in the\nintercept being \\code{NA}. If for some reason you prefer to have\nthe intercept be 0 instead of \\code{NA} then set\n\\code{X_colmeans = 0,y_mean = 0}.\n\nFor completeness, we note that if \\code{susie_ss} is run on\n\\eqn{X'X, X'y, y'y} computed \\emph{without} centering \\eqn{X} and\n\\eqn{y}, and with \\code{X_colmeans = 0,y_mean = 0}, this is\nequivalent to \\code{susie} applied to \\eqn{X, y} with\n\\code{intercept = FALSE} (although results may differ due to\ndifferent initializations of \\code{residual_variance} and\n\\code{scaled_prior_variance}). However, this usage is not\nrecommended for for most situations.\n\nThe computational complexity of \\code{susie} is \\eqn{O(npL)} per\niteration, whereas \\code{susie_ss} is \\eqn{O(p^2L)} per\niteration (not including the cost of computing the sufficient\nstatistics, which is dominated by the \\eqn{O(np^2)} cost of\ncomputing \\eqn{X'X}). Because of the cost of computing \\eqn{X'X},\n\\code{susie} will usually be faster. However, if \\eqn{n >> p},\nand/or if \\eqn{X'X} is already computed, then\n\\code{susie_ss} may be faster.\n}\n" }, { "path": "man/susieR-package.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susieR-package.R\n\\docType{package}\n\\name{susieR-package}\n\\alias{susieR}\n\\alias{susieR-package}\n\\title{susieR: Sum of Single Effects Linear Regression}\n\\description{\nImplements methods for variable selection in linear regression based on the \"Sum of Single Effects\" (SuSiE) model, as described in Wang et al (2020) \\doi{10.1101/501114} and Zou et al (2021) \\doi{10.1101/2021.11.03.467167}. These methods provide simple summaries, called \"Credible Sets\", for accurately quantifying uncertainty in which variables should be selected. The methods are motivated by genetic fine-mapping applications, and are particularly well-suited to settings where variables are highly correlated and detectable effects are sparse. The fitting algorithm, a Bayesian analogue of stepwise selection methods called \"Iterative Bayesian Stepwise Selection\" (IBSS), is simple and fast, allowing the SuSiE model be fit to large data sets (thousands of samples and hundreds of thousands of variables).\n}\n\\seealso{\nUseful links:\n\\itemize{\n \\item \\url{https://github.com/stephenslab/susieR}\n \\item Report bugs at \\url{https://github.com/stephenslab/susieR/issues}\n}\n\n}\n\\author{\n\\strong{Maintainer}: Peter Carbonetto \\email{peter.carbonetto@gmail.com}\n\nAuthors:\n\\itemize{\n \\item Gao Wang \\email{wang.gao@columbia.edu}\n \\item Yuxin Zou\n \\item Alexander McCreight\n \\item Kaiqian Zhang\n \\item William R.P. Denault\n \\item Matthew Stephens\n}\n\n}\n\\keyword{internal}\n" }, { "path": "man/susie_auto.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_auto.R\n\\name{susie_auto}\n\\alias{susie_auto}\n\\title{Attempt at Automating SuSiE for Hard Problems}\n\\usage{\nsusie_auto(\n X,\n y,\n L_init = 1,\n L_max = 512,\n verbose = FALSE,\n init_tol = 1,\n standardize = TRUE,\n intercept = TRUE,\n max_iter = 100,\n tol = 0.01,\n ...\n)\n}\n\\arguments{\n\\item{X}{An n by p matrix of covariates.}\n\n\\item{y}{The observed responses, a vector of length n.}\n\n\\item{L_init}{The initial value of L.}\n\n\\item{L_max}{The largest value of L to consider.}\n\n\\item{verbose}{If \\code{verbose = TRUE}, the algorithm's progress,\nand a summary of the optimization settings, are printed to the\nconsole.}\n\n\\item{init_tol}{The tolerance to passed to \\code{susie} during\nearly runs (set large to shorten the initial runs).}\n\n\\item{standardize}{If \\code{standardize = TRUE}, standardize the\ncolumns of X to unit variance prior to fitting. Note that\n\\code{scaled_prior_variance} specifies the prior on the\ncoefficients of X \\emph{after} standardization (if it is\nperformed). If you do not standardize, you may need to think more\ncarefully about specifying \\code{scaled_prior_variance}. Whatever\nyour choice, the coefficients returned by \\code{coef} are given for\n\\code{X} on the original input scale. Any column of \\code{X} that\nhas zero variance is not standardized.}\n\n\\item{intercept}{If \\code{intercept = TRUE}, the intercept is\nfitted; it \\code{intercept = FALSE}, the intercept is set to\nzero. Setting \\code{intercept = FALSE} is generally not\nrecommended.}\n\n\\item{max_iter}{Maximum number of IBSS iterations to perform.}\n\n\\item{tol}{A small, non-negative number specifying the convergence\ntolerance for the IBSS fitting procedure. The fitting procedure\nwill halt when the difference in the variational lower bound, or\n\\dQuote{ELBO} (the objective function to be maximized), is\nless than \\code{tol}.}\n\n\\item{\\dots}{Additional arguments passed to \\code{\\link{susie}}.}\n}\n\\value{\nSee \\code{\\link{susie}} for a description of return values.\n}\n\\description{\n\\code{susie_auto} is an attempt to automate reliable\n running of susie even on hard problems. It implements a three-stage\n strategy for each L: first, fit susie with very small residual\n error; next, estimate residual error; finally, estimate the prior\n variance. If the last step estimates some prior variances to be\n zero, stop. Otherwise, double L, and repeat. Initial runs are\n performed with relaxed tolerance; the final run is performed using\n the default susie tolerance.\n}\n\\examples{\nset.seed(1)\nn = 1000\np = 1000\nbeta = rep(0,p)\nbeta[1:4] = 1\nX = matrix(rnorm(n*p),nrow = n,ncol = p)\nX = scale(X,center = TRUE,scale = TRUE)\ny = drop(X \\%*\\% beta + rnorm(n))\nres = susie_auto(X,y)\nplot(beta,coef(res)[-1])\nabline(a = 0,b = 1,col = \"skyblue\",lty = \"dashed\")\nplot(y,predict(res))\nabline(a = 0,b = 1,col = \"skyblue\",lty = \"dashed\")\n\n}\n\\seealso{\n\\code{\\link{susie}}\n}\n" }, { "path": "man/susie_get_methods.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_get_functions.R\n\\name{susie_get_objective}\n\\alias{susie_get_objective}\n\\alias{susie_get_posterior_mean}\n\\alias{susie_get_posterior_sd}\n\\alias{susie_get_niter}\n\\alias{susie_get_prior_variance}\n\\alias{susie_get_residual_variance}\n\\alias{susie_get_lfsr}\n\\alias{susie_get_posterior_samples}\n\\alias{susie_get_cs}\n\\alias{susie_get_pip}\n\\title{Inferences From Fitted SuSiE Model}\n\\usage{\nsusie_get_objective(res, last_only = TRUE, warning_tol = 1e-06)\n\nsusie_get_posterior_mean(res, prior_tol = 1e-09)\n\nsusie_get_posterior_sd(res, prior_tol = 1e-09)\n\nsusie_get_niter(res)\n\nsusie_get_prior_variance(res)\n\nsusie_get_residual_variance(res)\n\nsusie_get_lfsr(res)\n\nsusie_get_posterior_samples(susie_fit, num_samples)\n\nsusie_get_cs(\n res,\n X = NULL,\n Xcorr = NULL,\n coverage = 0.95,\n min_abs_corr = 0.5,\n dedup = TRUE,\n squared = FALSE,\n check_symmetric = TRUE,\n n_purity = 100,\n use_rfast = NULL,\n ld_extend_threshold = 0.99\n)\n\nsusie_get_pip(res, prune_by_cs = FALSE, prior_tol = 1e-09)\n}\n\\arguments{\n\\item{res}{A susie fit, typically an output from\n\\code{\\link{susie}} or one of its variants. For\n\\code{susie_get_pip} and \\code{susie_get_cs}, this may instead be\nthe posterior inclusion probability matrix, \\code{alpha}.}\n\n\\item{last_only}{If \\code{last_only = FALSE}, return the ELBO from\nall iterations; otherwise return the ELBO from the last iteration\nonly.}\n\n\\item{warning_tol}{Warn if ELBO is decreasing by this\ntolerance level.}\n\n\\item{prior_tol}{Filter out effects having estimated prior variance\nsmaller than this threshold.}\n\n\\item{susie_fit}{A susie fit, an output from \\code{\\link{susie}}.}\n\n\\item{num_samples}{The number of draws from the posterior\ndistribution.}\n\n\\item{X}{n by p matrix of values of the p variables (covariates) in\nn samples. When provided, correlation between variables will be\ncomputed and used to remove CSs whose minimum correlation among\nvariables is smaller than \\code{min_abs_corr}.}\n\n\\item{Xcorr}{p by p matrix of correlations between variables\n(covariates). When provided, it will be used to remove CSs whose\nminimum correlation among variables is smaller than\n\\code{min_abs_corr}.}\n\n\\item{coverage}{A number between 0 and 1 specifying desired\ncoverage of each CS.}\n\n\\item{min_abs_corr}{A \"purity\" threshold for the CS. Any CS that\ncontains a pair of variables with correlation less than this\nthreshold will be filtered out and not reported. This filter is\nonly applied when \\code{X} or \\code{Xcorr} is provided; otherwise\nit is ignored and a warning is issued.}\n\n\\item{dedup}{If \\code{dedup = TRUE}, remove duplicate CSs.}\n\n\\item{squared}{If \\code{squared = TRUE}, report min, mean and\nmedian of squared correlation instead of the absolute correlation.}\n\n\\item{check_symmetric}{If \\code{check_symmetric = TRUE}, perform a\ncheck for symmetry of matrix \\code{Xcorr} when \\code{Xcorr} is\nprovided (not \\code{NULL}).}\n\n\\item{n_purity}{The maximum number of credible set (CS) variables\nused in calculating the correlation (\\dQuote{purity})\nstatistics. When the number of variables included in the CS is\ngreater than this number, the CS variables are randomly subsampled.}\n\n\\item{use_rfast}{Use the Rfast package for the purity calculations.\nBy default \\code{use_rfast = TRUE} if the Rfast package is\ninstalled.}\n\n\\item{ld_extend_threshold}{Threshold for extending CS by LD (default 0.99).\nVariants with |correlation| > threshold with any CS member are added.\nSet to NULL to disable LD extension. Requires Xcorr (would not work if only X is provided).}\n\n\\item{prune_by_cs}{Whether or not to ignore single effects not in\na reported CS when calculating PIP.}\n}\n\\value{\n\\code{susie_get_objective} returns the evidence lower bound\n(ELBO) achieved by the fitted susie model and, optionally, at each\niteration of the IBSS fitting procedure.\n\n\\code{susie_get_residual_variance} returns the (estimated or\nfixed) residual variance parameter.\n\n\\code{susie_get_prior_variance} returns the (estimated or fixed)\nprior variance parameters.\n\n\\code{susie_get_posterior_mean} returns the posterior mean for the\nregression coefficients of the fitted susie model.\n\n\\code{susie_get_posterior_sd} returns the posterior standard\ndeviation for coefficients of the fitted susie model.\n\n\\code{susie_get_niter} returns the number of model fitting\niterations performed.\n\n\\code{susie_get_pip} returns a vector containing the posterior\ninclusion probabilities (PIPs) for all variables.\n\n\\code{susie_get_lfsr} returns a vector containing the average lfsr\nacross variables for each single-effect, weighted by the posterior\ninclusion probability (alpha).\n\n\\code{susie_get_posterior_samples} returns a list containing the\neffect sizes samples and causal status with two components: \\code{b},\nan \\code{num_variables} x \\code{num_samples} matrix of effect\nsizes; \\code{gamma}, an \\code{num_variables} x \\code{num_samples}\nmatrix of causal status random draws.\n\n\\code{susie_get_cs} returns credible sets (CSs) from a susie fit,\nas well as summaries of correlation among the variables included in\neach CS. If desired, one can filter out CSs that do not meet a\nspecified \\dQuote{purity} threshold; to do this, either \\code{X} or\n\\code{Xcorr} must be supplied. It returns a list with the following\nelements:\n\n\\item{cs}{A list in which each list element is a vector containing\n the indices of the variables in the CS.}\n\n\\item{coverage}{The nominal coverage specified for each CS.}\n\n\\item{purity}{If \\code{X} or \\code{Xcorr} iis provided), the\n purity of each CS.}\n\n\\item{cs_index}{If \\code{X} or \\code{Xcorr} is provided) the index\n (number between 1 and L) of each reported CS in the supplied susie\n fit.}\n}\n\\description{\nThese functions access basic properties or draw\n inferences from a fitted susie model.\n}\n\\examples{\nset.seed(1)\nn <- 1000\np <- 1000\nbeta <- rep(0, p)\nbeta[1:4] <- 1\nX <- matrix(rnorm(n * p), nrow = n, ncol = p)\nX <- scale(X, center = TRUE, scale = TRUE)\ny <- drop(X \\%*\\% beta + rnorm(n))\ns <- susie(X, y, L = 10)\nsusie_get_objective(s)\nsusie_get_objective(s, last_only = FALSE)\nsusie_get_residual_variance(s)\nsusie_get_prior_variance(s)\nsusie_get_posterior_mean(s)\nsusie_get_posterior_sd(s)\nsusie_get_niter(s)\nsusie_get_pip(s)\nsusie_get_lfsr(s)\n\n}\n" }, { "path": "man/susie_init_coef.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_get_functions.R\n\\name{susie_init_coef}\n\\alias{susie_init_coef}\n\\title{Initialize a susie object using regression coefficients}\n\\usage{\nsusie_init_coef(coef_index, coef_value, p)\n}\n\\arguments{\n\\item{coef_index}{An L-vector containing the the indices of the\nnonzero coefficients.}\n\n\\item{coef_value}{An L-vector containing initial coefficient\nestimates.}\n\n\\item{p}{A scalar giving the number of variables.}\n}\n\\value{\nA list with elements \\code{alpha}, \\code{mu} and \\code{mu2}\n to be used by \\code{susie}.\n}\n\\description{\nInitialize a susie object using regression coefficients\n}\n\\examples{\nset.seed(1)\nn = 1000\np = 1000\nbeta = rep(0,p)\nbeta[sample(1:1000,4)] = 1\nX = matrix(rnorm(n*p),nrow = n,ncol = p)\nX = scale(X,center = TRUE,scale = TRUE)\ny = drop(X \\%*\\% beta + rnorm(n))\n\n# Initialize susie to ground-truth coefficients.\ns = susie_init_coef(which(beta != 0),beta[beta != 0],length(beta))\nres = susie(X,y,L = 10,model_init=s)\n\n}\n" }, { "path": "man/susie_plot_changepoint.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_plot.R\n\\name{susie_plot_changepoint}\n\\alias{susie_plot_changepoint}\n\\title{Plot changepoint data and susie fit using ggplot2}\n\\usage{\nsusie_plot_changepoint(\n s,\n y,\n line_col = \"blue\",\n line_size = 1.5,\n cs_col = \"red\"\n)\n}\n\\arguments{\n\\item{s}{A susie fit generated by\n\\code{susie_trendfilter(y,order = 0)}.}\n\n\\item{y}{An n-vector of observations that are ordered in time or\nspace (assumed equally-spaced).}\n\n\\item{line_col}{Color for the line showing fitted values.}\n\n\\item{line_size}{Size of the lines showing fitted values}\n\n\\item{cs_col}{Color of the shaded rectangles showing credible\nsets.}\n}\n\\value{\nA ggplot2 plot object.\n}\n\\description{\nPlots original data, y, overlaid with line showing\n susie fitted value and shaded rectangles showing credible sets for\n changepoint locations.\n}\n\\examples{\nset.seed(1)\nmu <- c(rep(0, 50), rep(1, 50), rep(3, 50), rep(-2, 50), rep(0, 300))\ny <- mu + rnorm(500)\n# Here we use a less sensitive tolerance so that the example takes\n# less time; in practice you will likely want to use a more stringent\n# setting such as tol = 0.001.\ns <- susie_trendfilter(y, tol = 0.1)\n\n# Produces ggplot with credible sets for changepoints.\nsusie_plot_changepoint(s, y)\n\n}\n" }, { "path": "man/susie_plots.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_plot.R\n\\name{susie_plot}\n\\alias{susie_plot}\n\\alias{susie_plot_iteration}\n\\title{SuSiE Plots.}\n\\usage{\nsusie_plot(\n model,\n y,\n add_bar = FALSE,\n pos = NULL,\n b = NULL,\n max_cs = 400,\n add_legend = NULL,\n ...\n)\n\nsusie_plot_iteration(model, L, file_prefix, pos = NULL)\n}\n\\arguments{\n\\item{model}{A SuSiE fit, typically an output from\n\\code{\\link{susie}} or one of its variants. For \\code{suse_plot},\nthe susie fit must have \\code{model$z}, \\code{model$PIP}, and may\ninclude \\code{model$sets}. \\code{model} may also be a vector of\nz-scores or PIPs.}\n\n\\item{y}{A string indicating what to plot: either \\code{\"z_original\"} for\nz-scores, \\code{\"z\"} for z-score derived p-values on (base-10) log-scale,\n\\code{\"PIP\"} for posterior inclusion probabilities,\n\\code{\"log10PIP\"} for posterior inclusion probabiliities on the\n(base-10) log-scale. For any other setting, the data are plotted as\nis.}\n\n\\item{add_bar}{If \\code{add_bar = TRUE}, add horizontal bar to\nsignals in credible interval.}\n\n\\item{pos}{Indices of variables to plot. If \\code{pos = NULL} all\nvariables are plotted.}\n\n\\item{b}{For simulated data, set \\code{b = TRUE} to highlight\n\"true\" effects (highlights in red).}\n\n\\item{max_cs}{The largest credible set to display, either based on\npurity (set \\code{max_cs} between 0 and 1), or based on size (set\n\\code{max_cs > 1}).}\n\n\\item{add_legend}{If \\code{add_legend = TRUE}, add a legend to\nannotate the size and purity of each CS discovered. It can also be\nspecified as location where legends should be added, e.g.,\n\\code{add_legend = \"bottomright\"} (default location is\n\\code{\"topright\"}).}\n\n\\item{\\dots}{Additional arguments passed to\n\\code{\\link[graphics]{plot}}.}\n\n\\item{L}{An integer specifying the number of credible sets to plot.}\n\n\\item{file_prefix}{Prefix to path of output plot file. If not\nspecified, the plot, or plots, will be saved to a temporary\ndirectory generated using \\code{\\link{tempdir}}.}\n}\n\\value{\nInvisibly returns \\code{NULL}.\n}\n\\description{\n\\code{susie_plot} produces a per-variable summary of\n the SuSiE credible sets. \\code{susie_plot_iteration} produces a\n diagnostic plot for the susie model fitting. For\n \\code{susie_plot_iteration}, several plots will be created if\n \\code{track_fit = TRUE} when calling \\code{susie}.\n}\n\\examples{\nset.seed(1)\nn <- 1000\np <- 1000\nbeta <- rep(0, p)\nbeta[sample(1:1000, 4)] <- 1\nX <- matrix(rnorm(n * p), nrow = n, ncol = p)\nX <- scale(X, center = TRUE, scale = TRUE)\ny <- drop(X \\%*\\% beta + rnorm(n))\nres <- susie(X, y, L = 10)\nsusie_plot(res, \"PIP\")\nsusie_plot(res, \"PIP\", add_bar = TRUE)\nsusie_plot(res, \"PIP\", add_legend = TRUE)\nsusie_plot(res, \"PIP\", pos = 1:500, add_legend = TRUE)\n# Plot selected regions with adjusted x-axis position label\nres$genomic_position <- 1000 + (1:length(res$pip))\nsusie_plot(res, \"PIP\",\n add_legend = TRUE,\n pos = list(attr = \"genomic_position\", start = 1000, end = 1500)\n)\n# True effects are shown in red.\nsusie_plot(res, \"PIP\", b = beta, add_legend = TRUE)\n\nset.seed(1)\nn <- 1000\np <- 1000\nbeta <- rep(0, p)\nbeta[sample(1:1000, 4)] <- 1\nX <- matrix(rnorm(n * p), nrow = n, ncol = p)\nX <- scale(X, center = TRUE, scale = TRUE)\ny <- drop(X \\%*\\% beta + rnorm(n))\nres <- susie(X, y, L = 10)\nsusie_plot_iteration(res, L = 10)\n\n}\n\\seealso{\n\\code{\\link{susie_plot_changepoint}}\n}\n" }, { "path": "man/susie_post_outcome_configuration.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_post_outcome_configuration.R\n\\name{susie_post_outcome_configuration}\n\\alias{susie_post_outcome_configuration}\n\\title{Post-hoc causal-configuration probabilities for one or more SuSiE-class fits}\n\\usage{\nsusie_post_outcome_configuration(\n input,\n by = c(\"fit\", \"outcome\"),\n method = c(\"susiex\", \"coloc_pairwise\"),\n prob_thresh = 0.8,\n cs_only = TRUE,\n p1 = 1e-04,\n p2 = 1e-04,\n p12 = 5e-06,\n ...\n)\n}\n\\arguments{\n\\item{input}{A single fit of class \\code{susie}, \\code{mvsusie}, or\n\\code{mfsusie}, OR a list of such fits.}\n\n\\item{by}{Either \\code{\"fit\"} (one trait per input fit; default) or\n\\code{\"outcome\"} (multi-output fits expand into per-outcome traits).}\n\n\\item{method}{Character scalar; one of \\code{\"susiex\"} (default) or\n\\code{\"coloc_pairwise\"}. Pick the analysis to run; for both, call\nthe function twice.}\n\n\\item{prob_thresh}{Per-trait marginal threshold for the convenience\n\\code{$active} flags in the SuSiEx output. Default \\code{0.8}.}\n\n\\item{cs_only}{Logical. If \\code{TRUE} (default) only enumerate over CSs\npresent in each fit's \\code{$sets$cs}; if \\code{FALSE} loop over all L\nrows of \\code{$alpha}. Either way, effects whose entire alpha row is\nzero are skipped. When \\code{TRUE}, every fit must carry a non-null\n\\code{$sets$cs} or the function errors.}\n\n\\item{p1, p2, p12}{Coloc per-SNP causal priors: \\code{p1} for trait 1\nalone, \\code{p2} for trait 2 alone, \\code{p12} for shared causal.\nDefaults match \\code{coloc::coloc.bf_bf}: \\code{p1 = p2 = 1e-4},\n\\code{p12 = 5e-6}. Only used when \\code{\"coloc_pairwise\"} is in\n\\code{methods}.}\n\n\\item{...}{Currently ignored.}\n}\n\\value{\nA list of class \\code{\"susie_post_outcome_configuration\"} with\nexactly one of the following components, depending on \\code{method}:\n\\describe{\n \\item{\\code{$susiex}}{(when \\code{method = \"susiex\"}) A list of length\n equal to the number of CS tuples considered. Each element has\n components \\code{cs_indices} (length-N integer tuple),\n \\code{logBF_trait} (length N), \\code{configs} (\\eqn{2^N \\times N}\n binary matrix), \\code{config_prob} (length \\eqn{2^N}),\n \\code{marginal_prob} (length-N per-trait marginal posterior\n probability of being active across the configuration ensemble),\n and \\code{active} (logical, \\code{marginal_prob >= prob_thresh}).}\n \\item{\\code{$coloc_pairwise}}{(when \\code{method = \"coloc_pairwise\"})\n A data.frame with one row per (trait1, trait2, l1, l2)\n combination, columns \\code{trait1, trait2, l1, l2, hit1, hit2,\n PP.H0, PP.H1, PP.H2, PP.H3, PP.H4}.}\n}\nPretty-print with \\code{summary(out)}.\n}\n\\description{\nRuns one of two complementary post-hoc analyses, selected by\n\\code{method}: \\code{\"susiex\"} (default) for the SuSiEx \\eqn{2^N}\ncombinatorial enumeration, reporting the posterior probability of\nevery binary causality pattern across the \\eqn{N} input traits; or\n\\code{\"coloc_pairwise\"} for the coloc pairwise ABF, reporting the\nfive colocalisation hypothesis posteriors (H0/H1/H2/H3/H4) for every\npair of traits. To get both, call the function twice and combine.\n}\n\\details{\nTwo grouping modes are supported through the \\code{by} argument:\n\\describe{\n \\item{\\code{\"fit\"}}{Each input fit contributes a single trait view.\n Multi-output fits (\\code{mvsusie}, \\code{mfsusie}) are kept whole: the\n trait's per-(CS, SNP) log Bayes factors are the joint composite\n stored on the fit as \\code{lbf_variable}. Configuration enumeration\n loops over the cross-product \\eqn{L_1 \\times \\dots \\times L_N} of CS\n indices.}\n \\item{\\code{\"outcome\"}}{Multi-output fits fan out into per-outcome views,\n each with its own per-(CS, SNP) log Bayes factors read from\n \\code{fit$lbf_variable_outcome} (an \\eqn{L \\times J \\times R} or\n \\eqn{L \\times J \\times M} array). All per-outcome views share the\n joint fit's PIP matrix and CS list, so the configuration enumeration\n reduces to a single index \\eqn{l \\in 1..L}. Single-output \\code{susie}\n fits pass through unchanged. Requires \\code{$lbf_variable_outcome} on the\n fit (set \\code{attach_lbf_variable_outcome = TRUE} when fitting).}\n}\n\n\\subsection{SuSiEx algorithm}{\nFor each credible-set tuple \\eqn{(l_1, \\dots, l_N)}:\n\\enumerate{\n \\item Per-trait CS-level log BF (alpha-weighted SNP average):\n \\deqn{\\log\\mathrm{BF}^{(n)}_{l_n} = \\sum_j \\alpha_{n,l_n,j}\\,\n \\log\\mathrm{BF}_{n,l_n,j}.}\n \\item Enumerate the \\eqn{2^N} binary configurations\n \\eqn{c \\in \\{0,1\\}^N}.\n \\item Configuration log BF:\n \\deqn{\\log\\mathrm{BF}^{(c)} = \\sum_{n: c_n = 1} \\log\\mathrm{BF}^{(n)}_{l_n}.}\n \\item Normalise under a uniform prior over the \\eqn{2^N} configurations.\n \\item Per-trait marginal: \\eqn{P(\\mathrm{trait}\\,n\\,\\mathrm{causal}) =\n \\sum_{c: c_n = 1} P(c \\mid \\mathrm{tuple})}.\n}\n}\n\n\\subsection{Coloc pairwise algorithm}{\nFor each unordered trait pair \\eqn{(n, n')} and each CS pair\n\\eqn{(l_n, l_{n'})}, with per-SNP log BFs\n\\eqn{\\ell_1 = \\log\\mathrm{BF}_{n,l_n,\\cdot}} and\n\\eqn{\\ell_2 = \\log\\mathrm{BF}_{n',l_{n'},\\cdot}} (length \\eqn{J}), the\nfive hypothesis log-BFs are\n\\deqn{\\log\\mathrm{BF}_{H_0} = 0,\\quad\n \\log\\mathrm{BF}_{H_1} = \\log p_1 + \\mathrm{LSE}(\\ell_1),\\quad\n \\log\\mathrm{BF}_{H_2} = \\log p_2 + \\mathrm{LSE}(\\ell_2),}\n\\deqn{\\log\\mathrm{BF}_{H_3} = \\log p_1 + \\log p_2 +\n \\mathrm{logdiff}(\\mathrm{LSE}(\\ell_1) + \\mathrm{LSE}(\\ell_2),\\;\n \\mathrm{LSE}(\\ell_1 + \\ell_2)),}\n\\deqn{\\log\\mathrm{BF}_{H_4} = \\log p_{12} + \\mathrm{LSE}(\\ell_1 + \\ell_2),}\nand the corresponding posteriors are\n\\eqn{\\mathrm{PP.H}_h = \\exp(\\log\\mathrm{BF}_{H_h} -\n \\mathrm{LSE}(\\log\\mathrm{BF}_{H_0:H_4}))}, where\n\\eqn{\\mathrm{LSE}} is the log-sum-exp.\n\\itemize{\n \\item H0: no causal variant in either CS.\n \\item H1: causal in trait \\eqn{n} only.\n \\item H2: causal in trait \\eqn{n'} only.\n \\item H3: distinct causals in the two traits.\n \\item H4: a single shared causal variant.\n}\n}\n}\n\\references{\nSuSiEx, Nature Genetics 2024 (combinatorial \\eqn{2^N} enumeration).\nWallace, PLoS Genetics 2020 (coloc pairwise H0/H1/H2/H3/H4 ABF).\n}\n" }, { "path": "man/susie_rss.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie.R\n\\name{susie_rss}\n\\alias{susie_rss}\n\\title{SuSiE with Regression Summary Statistics (RSS)}\n\\usage{\nsusie_rss(\n z = NULL,\n R = NULL,\n n = NULL,\n X = NULL,\n bhat = NULL,\n shat = NULL,\n var_y = NULL,\n L = min(10, if (is.list(R) && !is.matrix(R)) ncol(R[[1]]) else if (!is.null(R)) ncol(R)\n else if (is.list(X) && !is.matrix(X)) ncol(X[[1]]) else ncol(X)),\n maf = NULL,\n maf_thresh = 0,\n scaled_prior_variance = 0.2,\n residual_variance = NULL,\n prior_weights = NULL,\n null_weight = 0,\n standardize = TRUE,\n estimate_residual_variance = FALSE,\n estimate_residual_method = c(\"MoM\", \"MLE\", \"NIG\"),\n estimate_prior_variance = TRUE,\n estimate_prior_method = c(\"optim\", \"EM\", \"simple\"),\n prior_variance_grid = NULL,\n mixture_weights = NULL,\n unmappable_effects = c(\"none\", \"inf\", \"ash\", \"ash_filter_archived\"),\n check_null_threshold = 0,\n prior_tol = 1e-09,\n residual_variance_lowerbound = 0,\n residual_variance_upperbound = Inf,\n model_init = NULL,\n s_init = NULL,\n coverage = 0.95,\n min_abs_corr = 0.5,\n max_iter = 100,\n L_greedy = NULL,\n greedy_lbf_cutoff = 0.1,\n tol = 1e-04,\n convergence_method = c(\"elbo\", \"pip\"),\n verbose = FALSE,\n track_fit = FALSE,\n check_input = FALSE,\n check_prior = TRUE,\n n_purity = 100,\n r_tol = 1e-08,\n refine = FALSE,\n R_finite = NULL,\n R_mismatch = c(\"none\", \"map\", \"map_qc\"),\n eig_delta_rel = 0.001,\n eig_delta_abs = 0,\n artifact_threshold = 0.1,\n alpha0 = if (is.null(n)) NULL else 1/sqrt(n),\n beta0 = if (is.null(n)) NULL else 1/sqrt(n),\n init_only = FALSE,\n slot_prior = NULL\n)\n}\n\\arguments{\n\\item{z}{A p-vector of z-scores.}\n\n\\item{R}{A p by p correlation matrix. Exactly one of \\code{R} or\n\\code{X} must be provided.}\n\n\\item{n}{The sample size, not required but recommended.}\n\n\\item{X}{A factor matrix (B x p) such that \\code{R = crossprod(X) /\nnrow(X)} approximates the R (correlation) matrix. When\n\\code{nrow(X) >= ncol(X)}, the correlation matrix \\code{R} is\nformed explicitly and the standard path is used. When\n\\code{nrow(X) < ncol(X)}, a low-rank path is used that avoids\nforming the p x p matrix, reducing per-iteration cost from\nO(Lp^2) to O(LBp). Columns of \\code{X} are standardized\ninternally.}\n\n\\item{bhat}{Alternative summary data giving the estimated effects\n(a vector of length p). This, together with \\code{shat}, may be\nprovided instead of \\code{z}.}\n\n\\item{shat}{Alternative summary data giving the standard errors of\nthe estimated effects (a vector of length p). This, together with\n\\code{bhat}, may be provided instead of \\code{z}.}\n\n\\item{var_y}{The sample variance of y, defined as \\eqn{y'y/(n-1)}.\nWhen the sample variance is not provided, the coefficients\n(returned from \\code{coef}) are computed on the\n\\dQuote{standardized} X, y scale.}\n\n\\item{L}{Maximum number of non-zero effects in the model. If L is larger than\nthe number of covariates, p, L is set to p.}\n\n\\item{maf}{A p-vector of minor allele frequencies; to be used along with\n\\code{maf_thresh} to filter input summary statistics.}\n\n\\item{maf_thresh}{Variants with MAF smaller than this threshold are not used.}\n\n\\item{scaled_prior_variance}{The prior variance, divided by\n\\code{var(y)} (or by \\code{(1/(n-1))yty} for\n\\code{susie_ss}); that is, the prior variance of each\nnon-zero element of b is \\code{var(y) * scaled_prior_variance}. The\nvalue provided should be either a scalar or a vector of length\n\\code{L}. If \\code{estimate_prior_variance = TRUE}, this provides\ninitial estimates of the prior variances.}\n\n\\item{residual_variance}{Variance of the residual. If\n\\code{estimate_residual_variance = TRUE}, this value provides the\ninitial estimate of the residual variance. By default, it is set to\n\\code{var(y)} in \\code{susie} and \\code{(1/(n-1))yty} in\n\\code{susie_ss}.}\n\n\\item{prior_weights}{A vector of length p, in which each entry\ngives the prior probability that corresponding column of X has a\nnonzero effect on the outcome, y. The weights are internally\nnormalized to sum to 1. When \\code{NULL} (the default), uniform\nprior weights are used (each variable is assigned probability\n\\code{1/p}).}\n\n\\item{null_weight}{Prior probability of no effect (a number between 0 and 1,\nand cannot be exactly 1).}\n\n\\item{standardize}{If \\code{standardize = TRUE}, standardize the\ncolumns of X to unit variance prior to fitting (or equivalently\nstandardize XtX and Xty to have the same effect). Note that\n\\code{scaled_prior_variance} specifies the prior on the\ncoefficients of X \\emph{after} standardization (if it is\nperformed). If you do not standardize, you may need to think more\ncarefully about specifying \\code{scaled_prior_variance}. Whatever\nyour choice, the coefficients returned by \\code{coef} are given for\n\\code{X} on the original input scale. Any column of \\code{X} that\nhas zero variance is not standardized.}\n\n\\item{estimate_residual_variance}{The default is FALSE, the\nresidual variance is fixed to 1 or variance of y. If the in-sample\nR matrix is provided, we recommend setting\n\\code{estimate_residual_variance = TRUE}.}\n\n\\item{estimate_residual_method}{The method used for estimating residual variance.\nFor the original SuSiE model, \"MLE\" and \"MoM\" estimation is equivalent, but for\nthe infinitesimal model, \"MoM\" is more stable. We recommend using \"NIG\"\nwhen n < 80 for improved coverage, although it is currently only implemented\nfor individual-level data.}\n\n\\item{estimate_prior_variance}{If \\code{estimate_prior_variance =\nTRUE}, the prior variance is estimated (this is a separate\nparameter for each of the L effects). If provided,\n\\code{scaled_prior_variance} is then used as an initial value for\nthe optimization. When \\code{estimate_prior_variance = FALSE}, the\nprior variance for each of the L effects is determined by the\nvalue supplied to \\code{scaled_prior_variance}.}\n\n\\item{estimate_prior_method}{The method used for estimating prior\nvariance. When \\code{estimate_prior_method = \"simple\"} is used, the\nlikelihood at the specified prior variance is compared to the\nlikelihood at a variance of zero, and the setting with the larger\nlikelihood is retained. When \\code{prior_variance_grid} is provided,\nthis is automatically set to \\code{\"fixed_mixture\"}.}\n\n\\item{prior_variance_grid}{Numeric vector of K prior variances defining\na mixture-of-normals prior on effect sizes. When provided, the SER\nevaluates Bayes factors at each grid point and forms a mixture BF\nweighted by \\code{mixture_weights}. This bypasses the scalar prior\nvariance optimization. Default is \\code{NULL} (standard scalar V path).}\n\n\\item{mixture_weights}{Numeric vector of K non-negative weights summing\nto 1, giving the mixture proportions for the variance grid. Default is\n\\code{NULL}, which uses uniform weights when \\code{prior_variance_grid}\nis provided.}\n\n\\item{unmappable_effects}{The method for modeling unmappable effects:\n\"none\", \"inf\", \"ash\".}\n\n\\item{check_null_threshold}{When the prior variance is estimated,\ncompare the estimate with the null, and set the prior variance to\nzero unless the log-likelihood using the estimate is larger by this\nthreshold amount. For example, if you set\n\\code{check_null_threshold = 0.1}, this will \"nudge\" the estimate\ntowards zero when the difference in log-likelihoods is small. A\nnote of caution that setting this to a value greater than zero may\nlead the IBSS fitting procedure to occasionally decrease the ELBO. This\nsetting is disabled when using \\code{unmappable_effects = \"inf\"} or\n\\code{unmappable_effects = \"ash\"}.}\n\n\\item{prior_tol}{When the prior variance is estimated, compare the\nestimated value to \\code{prior_tol} at the end of the computation,\nand exclude a single effect from PIP computation if the estimated\nprior variance is smaller than this tolerance value.}\n\n\\item{residual_variance_lowerbound}{Lower limit on the estimated\nresidual variance. It is only relevant when\n\\code{estimate_residual_variance = TRUE}.}\n\n\\item{residual_variance_upperbound}{Upper limit on the estimated\nresidual variance. It is only relevant when\n\\code{estimate_residual_variance = TRUE}.}\n\n\\item{model_init}{A previous susie fit with which to initialize.}\n\n\\item{s_init}{Deprecated alias for \\code{model_init}.}\n\n\\item{coverage}{A number between 0 and 1 specifying the\n\\dQuote{coverage} of the estimated confidence sets.}\n\n\\item{min_abs_corr}{Minimum absolute correlation allowed in a\ncredible set. The default, 0.5, corresponds to a squared\ncorrelation of 0.25, which is a commonly used threshold for\ngenotype data in genetic studies. This \"purity\" filter is\napplied to the CSs reported in the fit object, so the CS list\nreturned here may be a subset of the one produced by calling\n\\code{\\link{susie_get_cs}} on the same fit without passing\n\\code{X} or \\code{Xcorr} (in which case the purity filter is\nskipped).}\n\n\\item{max_iter}{Maximum number of IBSS iterations to perform.}\n\n\\item{L_greedy}{Integer or \\code{NULL}. When non-\\code{NULL}, run a\ngreedy outer loop that grows the number of effects from\n\\code{L_greedy} up to \\code{L} in linear steps until the fit\nsaturates. The default \\code{NULL} runs the usual fixed-\\code{L}\nfit.}\n\n\\item{greedy_lbf_cutoff}{Numeric saturation threshold for the\n\\code{L_greedy} outer loop. Default is 0.1.}\n\n\\item{tol}{tol A small, non-negative number specifying the convergence\ntolerance for the IBSS fitting procedure.}\n\n\\item{convergence_method}{When \\code{converge_method = \"elbo\"} the fitting\nprocedure halts when the difference in the variational lower bound, or\n\\dQuote{ELBO} (the objective function to be maximized), is\nless than \\code{tol}. When \\code{converge_method = \"pip\"} the fitting\nprocedure halts when the maximum absolute difference in \\code{alpha} is less\nthan \\code{tol}.}\n\n\\item{verbose}{If \\code{verbose = TRUE}, the algorithm's progress,\na summary of the optimization settings, and refinement progress (if\n\\code{refine = TRUE}) are printed to the console.}\n\n\\item{track_fit}{If \\code{track_fit = TRUE}, \\code{trace}\nis also returned containing detailed information about the\nestimates at each iteration of the IBSS fitting procedure.}\n\n\\item{check_input}{If \\code{check_input = TRUE}, \\code{susie_ss} performs\nadditional checks on \\code{XtX} and \\code{Xty}. The checks are:\n(1) check that \\code{XtX} is positive semidefinite; (2) check that\n\\code{Xty} is in the space spanned by the non-zero eigenvectors of \\code{XtX}.}\n\n\\item{check_prior}{If \\code{check_prior = TRUE}, it checks if the\nestimated prior variance becomes unreasonably large (comparing with\n10 * max(abs(z))^2).}\n\n\\item{n_purity}{Passed as argument \\code{n_purity} to\n\\code{\\link{susie_get_cs}}.}\n\n\\item{r_tol}{Tolerance level for eigenvalue check of positive semidefinite\nmatrix \\code{XtX}.}\n\n\\item{refine}{If \\code{refine = TRUE}, then an additional\niterative refinement procedure is used, after the IBSS algorithm,\nto check and escape from local optima (see details).}\n\n\\item{R_finite}{Controls variance inflation to account\nfor estimating the R matrix from a finite reference panel. Accepts three\ntypes of input:\n\\describe{\n \\item{\\code{NULL} (default)}{The R matrix is treated as trusted, and no\n finite-reference variance inflation is applied.}\n \\item{\\code{TRUE}}{Infer the reference sample size B from the input\n \\code{X}. Sets \\code{B = nrow(X)} for single-panel input,\n or \\code{B = min(nrow(X_k))} across panels for multi-panel\n input. Requires \\code{X} to be provided (errors if only\n \\code{R} is given, since B cannot be inferred).}\n \\item{Number}{Explicit reference sample size B.}\n}\nWhen active, this dynamically inflates the null variance of each\nvariable's score statistic at every IBSS iteration to account for\nfinite-reference uncertainty in the Single Effect Regression (SER).\nWhen provided, the output includes a\n\\code{R_finite_diagnostics} element with per-region and\nper-variable quality metrics.}\n\n\\item{R_mismatch}{R-bias correction mode. \\code{\"none\"} (default) is off.\n\\code{\"map\"} adds a region-level population-mismatch variance\ncomponent on top of the finite-reference correction; recommended\nwhenever \\code{R} comes from a different cohort than the GWAS.\n\\code{\"map_qc\"} is \\code{\"map\"} plus a QC score (\\code{Q_art}) that\nwarns when the fitted residual carries energy in directions where\nthe supplied \\code{R} indicates signal should be weak. For\nallele-coding / strand-flip checks, see the kriging diagnostic in\n\\code{susie_rss}'s companion utilities.\nRequires \\code{R_finite}; auto-disables \\code{estimate_residual_variance}\nwith a warning.}\n\n\\item{eig_delta_rel, eig_delta_abs}{Cutoffs for \"low-eigenvalue\"\ndirections of \\code{R} used by the QC diagnostic\n(\\code{R_mismatch = \"map_qc\"}). Default \\code{eig_delta_rel = 1e-3},\n\\code{eig_delta_abs = 0}; the threshold is\n\\code{max(eig_delta_abs, eig_delta_rel * max_eigenvalue(R))}. Tighter\n(smaller) values flag fewer regions.}\n\n\\item{artifact_threshold}{Flag threshold on the QC score \\code{Q_art}\n(a fraction in [0, 1]). Default \\code{0.1}; flag fires when\n\\code{Q_art > artifact_threshold}. Heuristic, not a calibrated test.}\n\n\\item{alpha0}{Numerical parameter for the NIG prior when using\n\\code{estimate_residual_method = \"NIG\"}. Defaults to\n\\code{1/sqrt(n)}, where \\code{n} is the sample size. When calling\n\\code{susie_rss} with NIG, \\code{n} must be supplied; otherwise\nvalidation errors.}\n\n\\item{beta0}{Numerical parameter for the NIG prior when using\n\\code{estimate_residual_method = \"NIG\"}. Defaults to\n\\code{1/sqrt(n)}, where \\code{n} is the sample size. When calling\n\\code{susie_rss} with NIG, \\code{n} must be supplied; otherwise\nvalidation errors.}\n\n\\item{init_only}{Logical. If \\code{TRUE}, return a list with\n\\code{data} and \\code{params} objects without running the IBSS\nalgorithm. Default is \\code{FALSE}.}\n\n\\item{slot_prior}{Optional slot activity prior created by\n\\code{\\link{slot_prior_betabinom}} or \\code{\\link{slot_prior_poisson}}.\nUse \\code{slot_prior_betabinom(a_beta, b_beta)} for the usual\nsingle-locus setting; it places a Beta-Binomial prior on the\nnumber of active effects and gives an adaptive multiplicity\ncorrection. Use \\code{slot_prior_poisson(C, nu)} when you want a\nGamma-Poisson prior centered on an expected number \\code{C} of\nactive effects. When supplied, each single-effect slot has an\nestimated activity probability \\code{c_hat}; fitted values and\nPIPs are weighted by these activity probabilities, and convergence\nis checked using \\code{convergence_method = \"pip\"}.}\n}\n\\value{\nIn addition to the standard \\code{\"susie\"} output (see\n \\code{\\link{susie}}), the returned object may contain:\n\n\\item{R_finite_diagnostics}{A list of diagnostics for the\n finite-reference correction (only present when\n \\code{R_finite} is provided), containing:\n \\code{B} (the reference sample size);\n \\code{p} (number of variables);\n \\code{effective_rank} (debiased \\eqn{\\tilde{r} = p^2 / \\|R\\|_F^2});\n \\code{r_over_B} (\\eqn{\\tilde{r}/B}, one number per region; values\n \\eqn{\\le 0.2} indicate the reference panel is adequate);\n \\code{Rhat_diag_deviation} (\\eqn{|\\hat{R}_{jj} - 1|}, one number\n per variable);\n \\code{lambda_bias} (region-level scalar on the default\n \\code{lambda = 0} sufficient-statistics path when\n \\code{R_mismatch != \"none\"});\n \\code{B_corrected} (effective reference sample size after the\n R-bias correction, \\eqn{1/(1/B + \\lambda_{\\mathrm{bias}})};\n substantially\n smaller than the input \\code{B} flags a dominant population\n mismatch component);\n \\code{per_variable_penalty} (final-iteration\n \\eqn{v_j / \\sigma^2 = \\tau_j^2 / \\sigma^2 - 1}, one number per\n variable; values \\eqn{\\le 0.2} indicate minimal power loss,\n values \\eqn{\\gg 1} flag variables where the correction is doing\n heavy lifting).}\n}\n\\description{\nPerforms SuSiE regression using z-scores and correlation matrix.\nThis is the sufficient-statistics RSS interface. For the specialized\nregularized eigendecomposition likelihood with \\code{lambda > 0}, use\n\\code{\\link{susie_rss_lambda}}.\n}\n" }, { "path": "man/susie_rss_lambda.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie.R\n\\name{susie_rss_lambda}\n\\alias{susie_rss_lambda}\n\\title{Sum of Single Effects Regression using the RSS-lambda likelihood}\n\\usage{\nsusie_rss_lambda(\n z = NULL,\n R = NULL,\n n = NULL,\n X = NULL,\n L = min(10, if (!is.null(R)) ncol(R) else ncol(X)),\n lambda,\n maf = NULL,\n maf_thresh = 0,\n prior_variance = 50,\n residual_variance = NULL,\n prior_weights = NULL,\n null_weight = 0,\n intercept_value = 0,\n estimate_residual_variance = FALSE,\n estimate_residual_method = \"MLE\",\n estimate_prior_variance = TRUE,\n estimate_prior_method = c(\"optim\", \"EM\", \"simple\"),\n prior_variance_grid = NULL,\n mixture_weights = NULL,\n check_null_threshold = 0,\n prior_tol = 1e-09,\n residual_variance_lowerbound = 0,\n model_init = NULL,\n coverage = 0.95,\n min_abs_corr = 0.5,\n max_iter = 100,\n L_greedy = NULL,\n greedy_lbf_cutoff = 0.1,\n tol = 1e-04,\n convergence_method = c(\"elbo\", \"pip\"),\n verbose = FALSE,\n track_fit = FALSE,\n check_prior = TRUE,\n check_R = TRUE,\n check_z = FALSE,\n n_purity = 100,\n r_tol = 1e-08,\n refine = FALSE,\n init_only = FALSE,\n slot_prior = NULL\n)\n}\n\\arguments{\n\\item{z}{A p-vector of z-scores.}\n\n\\item{R}{A p by p correlation matrix. Exactly one of \\code{R} or\n\\code{X} must be provided.}\n\n\\item{n}{The sample size, not required but recommended.}\n\n\\item{X}{A factor matrix (B x p) such that \\code{R = crossprod(X) /\nnrow(X)} approximates the R (correlation) matrix. When\n\\code{nrow(X) >= ncol(X)}, the correlation matrix \\code{R} is\nformed explicitly and the standard path is used. When\n\\code{nrow(X) < ncol(X)}, a low-rank path is used that avoids\nforming the p x p matrix, reducing per-iteration cost from\nO(Lp^2) to O(LBp). Columns of \\code{X} are standardized\ninternally.}\n\n\\item{L}{Maximum number of non-zero effects in the model. If L is larger than\nthe number of covariates, p, L is set to p.}\n\n\\item{lambda}{Regularization parameter for the RSS-lambda likelihood.\nMust be supplied. \\code{lambda = \"estimate\"} estimates lambda from\nthe null-space residual.}\n\n\\item{maf}{A p-vector of minor allele frequencies; to be used along with\n\\code{maf_thresh} to filter input summary statistics.}\n\n\\item{maf_thresh}{Variants with MAF smaller than this threshold are not used.}\n\n\\item{prior_variance}{Prior variance for each non-zero effect on the\nz-score scale. Replaces \\code{scaled_prior_variance} from\n\\code{\\link{susie_rss}}. Default \\code{50}.}\n\n\\item{residual_variance}{Variance of the residual. If\n\\code{estimate_residual_variance = TRUE}, this value provides the\ninitial estimate of the residual variance. By default, it is set to\n\\code{var(y)} in \\code{susie} and \\code{(1/(n-1))yty} in\n\\code{susie_ss}.}\n\n\\item{prior_weights}{A vector of length p, in which each entry\ngives the prior probability that corresponding column of X has a\nnonzero effect on the outcome, y. The weights are internally\nnormalized to sum to 1. When \\code{NULL} (the default), uniform\nprior weights are used (each variable is assigned probability\n\\code{1/p}).}\n\n\\item{null_weight}{Prior probability of no effect (a number between 0 and 1,\nand cannot be exactly 1).}\n\n\\item{intercept_value}{Intercept used by the RSS-lambda likelihood.\nDefault \\code{0}.}\n\n\\item{estimate_residual_variance}{The default is FALSE, the\nresidual variance is fixed to 1 or variance of y. If the in-sample\nR matrix is provided, we recommend setting\n\\code{estimate_residual_variance = TRUE}.}\n\n\\item{estimate_residual_method}{Variance-component estimator. The\nRSS-lambda path supports \\code{\"MLE\"} only; any other value errors.}\n\n\\item{estimate_prior_variance}{If \\code{estimate_prior_variance = TRUE},\nthe prior variance is estimated (a separate parameter for each of\nthe L effects). When \\code{TRUE}, \\code{prior_variance} provides the\ninitial value; when \\code{FALSE}, it is held fixed.}\n\n\\item{estimate_prior_method}{The method used for estimating prior\nvariance. When \\code{estimate_prior_method = \"simple\"} is used, the\nlikelihood at the specified prior variance is compared to the\nlikelihood at a variance of zero, and the setting with the larger\nlikelihood is retained. When \\code{prior_variance_grid} is provided,\nthis is automatically set to \\code{\"fixed_mixture\"}.}\n\n\\item{prior_variance_grid}{Numeric vector of K prior variances defining\na mixture-of-normals prior on effect sizes. When provided, the SER\nevaluates Bayes factors at each grid point and forms a mixture BF\nweighted by \\code{mixture_weights}. This bypasses the scalar prior\nvariance optimization. Default is \\code{NULL} (standard scalar V path).}\n\n\\item{mixture_weights}{Numeric vector of K non-negative weights summing\nto 1, giving the mixture proportions for the variance grid. Default is\n\\code{NULL}, which uses uniform weights when \\code{prior_variance_grid}\nis provided.}\n\n\\item{check_null_threshold}{When the prior variance is estimated,\ncompare its likelihood to the likelihood at zero and use zero\nunless the larger value exceeds it by at least\n\\code{check_null_threshold}. \\code{0} (default) takes the larger\nlikelihood at face value.}\n\n\\item{prior_tol}{When the prior variance is estimated, compare the\nestimated value to \\code{prior_tol} at the end of the computation,\nand exclude a single effect from PIP computation if the estimated\nprior variance is smaller than this tolerance value.}\n\n\\item{residual_variance_lowerbound}{Lower limit on the estimated\nresidual variance. It is only relevant when\n\\code{estimate_residual_variance = TRUE}.}\n\n\\item{model_init}{A previous susie fit with which to initialize.}\n\n\\item{coverage}{A number between 0 and 1 specifying the\n\\dQuote{coverage} of the estimated confidence sets.}\n\n\\item{min_abs_corr}{Minimum absolute correlation allowed in a\ncredible set. The default, 0.5, corresponds to a squared\ncorrelation of 0.25, which is a commonly used threshold for\ngenotype data in genetic studies. This \"purity\" filter is\napplied to the CSs reported in the fit object, so the CS list\nreturned here may be a subset of the one produced by calling\n\\code{\\link{susie_get_cs}} on the same fit without passing\n\\code{X} or \\code{Xcorr} (in which case the purity filter is\nskipped).}\n\n\\item{max_iter}{Maximum number of IBSS iterations to perform.}\n\n\\item{L_greedy}{Integer or \\code{NULL}. When non-\\code{NULL}, run a\ngreedy outer loop that grows the number of effects from\n\\code{L_greedy} up to \\code{L} in linear steps until the fit\nsaturates. The default \\code{NULL} runs the usual fixed-\\code{L}\nfit.}\n\n\\item{greedy_lbf_cutoff}{Numeric saturation threshold for the\n\\code{L_greedy} outer loop. Default is 0.1.}\n\n\\item{tol}{tol A small, non-negative number specifying the convergence\ntolerance for the IBSS fitting procedure.}\n\n\\item{convergence_method}{When \\code{converge_method = \"elbo\"} the fitting\nprocedure halts when the difference in the variational lower bound, or\n\\dQuote{ELBO} (the objective function to be maximized), is\nless than \\code{tol}. When \\code{converge_method = \"pip\"} the fitting\nprocedure halts when the maximum absolute difference in \\code{alpha} is less\nthan \\code{tol}.}\n\n\\item{verbose}{If \\code{verbose = TRUE}, the algorithm's progress,\na summary of the optimization settings, and refinement progress (if\n\\code{refine = TRUE}) are printed to the console.}\n\n\\item{track_fit}{If \\code{track_fit = TRUE}, \\code{trace}\nis also returned containing detailed information about the\nestimates at each iteration of the IBSS fitting procedure.}\n\n\\item{check_prior}{If \\code{check_prior = TRUE}, it checks if the\nestimated prior variance becomes unreasonably large (comparing with\n10 * max(abs(z))^2).}\n\n\\item{check_R}{If TRUE, verify that \\code{R} is positive semidefinite.}\n\n\\item{check_z}{If TRUE, verify that \\code{z} lies in the column space\nof \\code{R}.}\n\n\\item{n_purity}{Passed as argument \\code{n_purity} to\n\\code{\\link{susie_get_cs}}.}\n\n\\item{r_tol}{Tolerance level for eigenvalue check of positive semidefinite\nmatrix \\code{XtX}.}\n\n\\item{refine}{If \\code{refine = TRUE}, then an additional\niterative refinement procedure is used, after the IBSS algorithm,\nto check and escape from local optima (see details).}\n\n\\item{init_only}{Logical. If \\code{TRUE}, return a list with\n\\code{data} and \\code{params} objects without running the IBSS\nalgorithm. Default is \\code{FALSE}.}\n\n\\item{slot_prior}{Optional slot activity prior created by\n\\code{\\link{slot_prior_betabinom}} or \\code{\\link{slot_prior_poisson}}.\nUse \\code{slot_prior_betabinom(a_beta, b_beta)} for the usual\nsingle-locus setting; it places a Beta-Binomial prior on the\nnumber of active effects and gives an adaptive multiplicity\ncorrection. Use \\code{slot_prior_poisson(C, nu)} when you want a\nGamma-Poisson prior centered on an expected number \\code{C} of\nactive effects. When supplied, each single-effect slot has an\nestimated activity probability \\code{c_hat}; fitted values and\nPIPs are weighted by these activity probabilities, and convergence\nis checked using \\code{convergence_method = \"pip\"}.}\n}\n\\value{\nA \\code{\"susie\"} fit (or, with \\code{init_only = TRUE}, the\n constructed data and params objects).\n}\n\\description{\nSpecialized interface for the regularized eigendecomposition\nRSS likelihood of Zou et al. (2022). This path accepts a single reference\nmatrix or a single factor matrix and does not support multi-panel mixture,\nfinite-reference inflation, or R-bias correction.\n}\n" }, { "path": "man/susie_ss.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie.R\n\\name{susie_ss}\n\\alias{susie_ss}\n\\title{SuSiE using Sufficient Statistics}\n\\usage{\nsusie_ss(\n XtX,\n Xty,\n yty,\n n,\n L = min(10, ncol(XtX)),\n X_colmeans = NA,\n y_mean = NA,\n maf = NULL,\n maf_thresh = 0,\n check_input = FALSE,\n r_tol = 1e-08,\n standardize = TRUE,\n scaled_prior_variance = 0.2,\n residual_variance = NULL,\n prior_weights = NULL,\n null_weight = 0,\n model_init = NULL,\n s_init = NULL,\n estimate_residual_variance = TRUE,\n estimate_residual_method = c(\"MoM\", \"MLE\", \"NIG\"),\n residual_variance_lowerbound = 0,\n residual_variance_upperbound = Inf,\n estimate_prior_variance = TRUE,\n estimate_prior_method = c(\"optim\", \"EM\", \"simple\"),\n prior_variance_grid = NULL,\n mixture_weights = NULL,\n unmappable_effects = c(\"none\", \"inf\", \"ash\", \"ash_filter_archived\"),\n check_null_threshold = 0,\n prior_tol = 1e-09,\n max_iter = 100,\n L_greedy = NULL,\n greedy_lbf_cutoff = 0.1,\n tol = 1e-04,\n convergence_method = c(\"elbo\", \"pip\"),\n coverage = 0.95,\n min_abs_corr = 0.5,\n n_purity = 100,\n verbose = FALSE,\n track_fit = FALSE,\n check_prior = FALSE,\n refine = FALSE,\n alpha0 = 1/sqrt(n),\n beta0 = 1/sqrt(n),\n slot_prior = NULL\n)\n}\n\\arguments{\n\\item{XtX}{A p by p matrix, X'X, with columns of X centered to have mean zero.}\n\n\\item{Xty}{A p-vector, X'y, with y and columns of X centered to have mean zero.}\n\n\\item{yty}{A scalar, y'y, with y centered to have mean zero.}\n\n\\item{n}{The sample size.}\n\n\\item{L}{Maximum number of non-zero effects in the model. If L is larger than\nthe number of covariates, p, L is set to p.}\n\n\\item{X_colmeans}{A p-vector of column means of \\code{X}. If both\n\\code{X_colmeans} and \\code{y_mean} are provided, the intercept\nis estimated; otherwise, the intercept is NA.}\n\n\\item{y_mean}{A scalar containing the mean of \\code{y}. If both\n\\code{X_colmeans} and \\code{y_mean} are provided, the intercept\nis estimated; otherwise, the intercept is NA.}\n\n\\item{maf}{A p-vector of minor allele frequencies; to be used along with\n\\code{maf_thresh} to filter input summary statistics.}\n\n\\item{maf_thresh}{Variants with MAF smaller than this threshold are not used.}\n\n\\item{check_input}{If \\code{check_input = TRUE}, \\code{susie_ss} performs\nadditional checks on \\code{XtX} and \\code{Xty}. The checks are:\n(1) check that \\code{XtX} is positive semidefinite; (2) check that\n\\code{Xty} is in the space spanned by the non-zero eigenvectors of \\code{XtX}.}\n\n\\item{r_tol}{Tolerance level for eigenvalue check of positive semidefinite\nmatrix \\code{XtX}.}\n\n\\item{standardize}{If \\code{standardize = TRUE}, standardize the\ncolumns of X to unit variance prior to fitting (or equivalently\nstandardize XtX and Xty to have the same effect). Note that\n\\code{scaled_prior_variance} specifies the prior on the\ncoefficients of X \\emph{after} standardization (if it is\nperformed). If you do not standardize, you may need to think more\ncarefully about specifying \\code{scaled_prior_variance}. Whatever\nyour choice, the coefficients returned by \\code{coef} are given for\n\\code{X} on the original input scale. Any column of \\code{X} that\nhas zero variance is not standardized.}\n\n\\item{scaled_prior_variance}{The prior variance, divided by\n\\code{var(y)} (or by \\code{(1/(n-1))yty} for\n\\code{susie_ss}); that is, the prior variance of each\nnon-zero element of b is \\code{var(y) * scaled_prior_variance}. The\nvalue provided should be either a scalar or a vector of length\n\\code{L}. If \\code{estimate_prior_variance = TRUE}, this provides\ninitial estimates of the prior variances.}\n\n\\item{residual_variance}{Variance of the residual. If\n\\code{estimate_residual_variance = TRUE}, this value provides the\ninitial estimate of the residual variance. By default, it is set to\n\\code{var(y)} in \\code{susie} and \\code{(1/(n-1))yty} in\n\\code{susie_ss}.}\n\n\\item{prior_weights}{A vector of length p, in which each entry\ngives the prior probability that corresponding column of X has a\nnonzero effect on the outcome, y. The weights are internally\nnormalized to sum to 1. When \\code{NULL} (the default), uniform\nprior weights are used (each variable is assigned probability\n\\code{1/p}).}\n\n\\item{null_weight}{Prior probability of no effect (a number between 0 and 1,\nand cannot be exactly 1).}\n\n\\item{model_init}{A previous susie fit with which to initialize.}\n\n\\item{s_init}{Deprecated alias for \\code{model_init}.}\n\n\\item{estimate_residual_variance}{If\n\\code{estimate_residual_variance = TRUE}, the residual variance is\nestimated, using \\code{residual_variance} as an initial value. If\n\\code{estimate_residual_variance = FALSE}, the residual variance is\nfixed to the value supplied by \\code{residual_variance}.}\n\n\\item{estimate_residual_method}{The method used for estimating residual variance.\nFor the original SuSiE model, \"MLE\" and \"MoM\" estimation is equivalent, but for\nthe infinitesimal model, \"MoM\" is more stable. We recommend using \"NIG\"\nwhen n < 80 for improved coverage, although it is currently only implemented\nfor individual-level data.}\n\n\\item{residual_variance_lowerbound}{Lower limit on the estimated\nresidual variance. It is only relevant when\n\\code{estimate_residual_variance = TRUE}.}\n\n\\item{residual_variance_upperbound}{Upper limit on the estimated\nresidual variance. It is only relevant when\n\\code{estimate_residual_variance = TRUE}.}\n\n\\item{estimate_prior_variance}{If \\code{estimate_prior_variance =\nTRUE}, the prior variance is estimated (this is a separate\nparameter for each of the L effects). If provided,\n\\code{scaled_prior_variance} is then used as an initial value for\nthe optimization. When \\code{estimate_prior_variance = FALSE}, the\nprior variance for each of the L effects is determined by the\nvalue supplied to \\code{scaled_prior_variance}.}\n\n\\item{estimate_prior_method}{The method used for estimating prior\nvariance. When \\code{estimate_prior_method = \"simple\"} is used, the\nlikelihood at the specified prior variance is compared to the\nlikelihood at a variance of zero, and the setting with the larger\nlikelihood is retained. When \\code{prior_variance_grid} is provided,\nthis is automatically set to \\code{\"fixed_mixture\"}.}\n\n\\item{prior_variance_grid}{Numeric vector of K prior variances defining\na mixture-of-normals prior on effect sizes. When provided, the SER\nevaluates Bayes factors at each grid point and forms a mixture BF\nweighted by \\code{mixture_weights}. This bypasses the scalar prior\nvariance optimization. Default is \\code{NULL} (standard scalar V path).}\n\n\\item{mixture_weights}{Numeric vector of K non-negative weights summing\nto 1, giving the mixture proportions for the variance grid. Default is\n\\code{NULL}, which uses uniform weights when \\code{prior_variance_grid}\nis provided.}\n\n\\item{unmappable_effects}{The method for modeling unmappable effects:\n\"none\", \"inf\", \"ash\".}\n\n\\item{check_null_threshold}{When the prior variance is estimated,\ncompare the estimate with the null, and set the prior variance to\nzero unless the log-likelihood using the estimate is larger by this\nthreshold amount. For example, if you set\n\\code{check_null_threshold = 0.1}, this will \"nudge\" the estimate\ntowards zero when the difference in log-likelihoods is small. A\nnote of caution that setting this to a value greater than zero may\nlead the IBSS fitting procedure to occasionally decrease the ELBO. This\nsetting is disabled when using \\code{unmappable_effects = \"inf\"} or\n\\code{unmappable_effects = \"ash\"}.}\n\n\\item{prior_tol}{When the prior variance is estimated, compare the\nestimated value to \\code{prior_tol} at the end of the computation,\nand exclude a single effect from PIP computation if the estimated\nprior variance is smaller than this tolerance value.}\n\n\\item{max_iter}{Maximum number of IBSS iterations to perform.}\n\n\\item{L_greedy}{Integer or \\code{NULL}. When non-\\code{NULL}, run a\ngreedy outer loop that grows the number of effects from\n\\code{L_greedy} up to \\code{L} in linear steps until the fit\nsaturates. The default \\code{NULL} runs the usual fixed-\\code{L}\nfit.}\n\n\\item{greedy_lbf_cutoff}{Numeric saturation threshold for the\n\\code{L_greedy} outer loop. Default is 0.1.}\n\n\\item{tol}{tol A small, non-negative number specifying the convergence\ntolerance for the IBSS fitting procedure.}\n\n\\item{convergence_method}{When \\code{converge_method = \"elbo\"} the fitting\nprocedure halts when the difference in the variational lower bound, or\n\\dQuote{ELBO} (the objective function to be maximized), is\nless than \\code{tol}. When \\code{converge_method = \"pip\"} the fitting\nprocedure halts when the maximum absolute difference in \\code{alpha} is less\nthan \\code{tol}.}\n\n\\item{coverage}{A number between 0 and 1 specifying the\n\\dQuote{coverage} of the estimated confidence sets.}\n\n\\item{min_abs_corr}{Minimum absolute correlation allowed in a\ncredible set. The default, 0.5, corresponds to a squared\ncorrelation of 0.25, which is a commonly used threshold for\ngenotype data in genetic studies. This \"purity\" filter is\napplied to the CSs reported in the fit object, so the CS list\nreturned here may be a subset of the one produced by calling\n\\code{\\link{susie_get_cs}} on the same fit without passing\n\\code{X} or \\code{Xcorr} (in which case the purity filter is\nskipped).}\n\n\\item{n_purity}{Passed as argument \\code{n_purity} to\n\\code{\\link{susie_get_cs}}.}\n\n\\item{verbose}{If \\code{verbose = TRUE}, the algorithm's progress,\na summary of the optimization settings, and refinement progress (if\n\\code{refine = TRUE}) are printed to the console.}\n\n\\item{track_fit}{If \\code{track_fit = TRUE}, \\code{trace}\nis also returned containing detailed information about the\nestimates at each iteration of the IBSS fitting procedure.}\n\n\\item{check_prior}{If \\code{check_prior = TRUE}, it checks if the\nestimated prior variance becomes unreasonably large (comparing with\n10 * max(abs(z))^2).}\n\n\\item{refine}{If \\code{refine = TRUE}, then an additional\niterative refinement procedure is used, after the IBSS algorithm,\nto check and escape from local optima (see details).}\n\n\\item{alpha0}{Numerical parameter for the NIG prior when using\n\\code{estimate_residual_method = \"NIG\"}. Defaults to\n\\code{1/sqrt(n)}, where \\code{n} is the sample size. When calling\n\\code{susie_rss} with NIG, \\code{n} must be supplied; otherwise\nvalidation errors.}\n\n\\item{beta0}{Numerical parameter for the NIG prior when using\n\\code{estimate_residual_method = \"NIG\"}. Defaults to\n\\code{1/sqrt(n)}, where \\code{n} is the sample size. When calling\n\\code{susie_rss} with NIG, \\code{n} must be supplied; otherwise\nvalidation errors.}\n\n\\item{slot_prior}{Optional slot activity prior created by\n\\code{\\link{slot_prior_betabinom}} or \\code{\\link{slot_prior_poisson}}.\nUse \\code{slot_prior_betabinom(a_beta, b_beta)} for the usual\nsingle-locus setting; it places a Beta-Binomial prior on the\nnumber of active effects and gives an adaptive multiplicity\ncorrection. Use \\code{slot_prior_poisson(C, nu)} when you want a\nGamma-Poisson prior centered on an expected number \\code{C} of\nactive effects. When supplied, each single-effect slot has an\nestimated activity probability \\code{c_hat}; fitted values and\nPIPs are weighted by these activity probabilities, and convergence\nis checked using \\code{convergence_method = \"pip\"}.}\n}\n\\description{\nPerforms SuSiE regression using sufficient statistics (XtX, Xty,\nyty, n) instead of individual-level data (X, y).\n}\n" }, { "path": "man/susie_trendfilter.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_trendfilter.R\n\\name{susie_trendfilter}\n\\alias{susie_trendfilter}\n\\title{Apply susie to trend filtering (especially changepoint\n problems), a type of non-parametric regression.}\n\\usage{\nsusie_trendfilter(y, order = 0, standardize = FALSE, use_mad = TRUE, ...)\n}\n\\arguments{\n\\item{y}{An n-vector of observations ordered in time or space\n(assumed to be equally spaced).}\n\n\\item{order}{An integer specifying the order of trend filtering.\nThe default, \\code{order = 0}, corresponds to \"changepoint\"\nproblems (\\emph{i.e.}, piecewise constant \\eqn{mu}). Although\n\\code{order > 0} is implemented, we do not recommend its use; in\npractice, we have found problems with convergence of the algorithm\nto poor local optima, producing unreliable inferences.}\n\n\\item{standardize}{Logical indicating whether to standardize the X\nvariables (\"basis functions\"); \\code{standardize = FALSE} is\nrecommended as these basis functions already have a natural scale.}\n\n\\item{use_mad}{Logical indicating whether to use the \"median\nabsolute deviation\" (MAD) method to the estimate residual\nvariance. If \\code{use_mad = TRUE}, susie is run twice, first by\nfixing the residual variance to the MAD value, then a second time,\ninitialized to the first fit, but with residual variance estimated\nthe usual way (by maximizing the ELBO). We have found this strategy\ntypically improves reliability of the results by reducing a\ntendency to converge to poor local optima of the ELBO.}\n\n\\item{...}{Other arguments passed to \\code{\\link{susie}}.}\n}\n\\value{\nA \"susie\" fit; see \\code{\\link{susie}} for details.\n}\n\\description{\nFits the non-parametric Gaussian regression model\n \\eqn{y = mu + e}, where the mean \\eqn{mu} is modelled as \\eqn{mu =\n Xb}, X is a matrix with columns containing an appropriate basis,\n and b is vector with a (sparse) SuSiE prior. In particular, when\n \\code{order = 0}, the jth column of X is a vector with the first j\n elements equal to zero, and the remaining elements equal to 1, so\n that \\eqn{b_j} corresponds to the change in the mean of y between\n indices j and j+1. For background on trend filtering, see\n Tibshirani (2014). See also the \"Trend filtering\" vignette,\n \\code{vignette(\"trend_filtering\")}.\n}\n\\details{\nThis implementation exploits the special structure of X,\n which means that the matrix-vector product \\eqn{X^Ty} is fast to\n compute; in particular, the computation time is \\eqn{O(n)} rather\n than \\eqn{O(n^2)} if \\code{X} were formed explicitly. For\n implementation details, see the \"Implementation of SuSiE trend\n filtering\" vignette by running\n \\code{vignette(\"trendfiltering_derivations\")}.\n}\n\\examples{\nset.seed(1)\nmu <- c(rep(0, 50), rep(1, 50), rep(3, 50), rep(-2, 50), rep(0, 200))\ny <- mu + rnorm(400)\ns <- susie_trendfilter(y)\nplot(y)\nlines(mu, col = 1, lwd = 3)\nlines(predict(s), col = 2, lwd = 2)\n\n# Calculate credible sets (indices of y that occur just before\n# changepoints).\nsusie_get_cs(s)\n\n# Plot with credible sets for changepoints.\nsusie_plot_changepoint(s, y)\n\n}\n\\references{\nR. J. Tibshirani (2014). Adaptive piecewise polynomial\n estimation via trend filtering. \\emph{Annals of Statistics}\n \\bold{42}, 285-323.\n}\n" }, { "path": "man/susie_workhorse.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/susie_workhorse.R\n\\name{susie_workhorse}\n\\alias{susie_workhorse}\n\\title{SuSiE workhorse function}\n\\usage{\nsusie_workhorse(data, params)\n}\n\\arguments{\n\\item{data}{Data object (individual, ss, or rss_lambda).}\n\n\\item{params}{Validated params object.}\n}\n\\value{\nComplete fitted SuSiE model.\n}\n\\description{\nMain orchestration for the IBSS algorithm. When `params$L_greedy`\nis non-NULL, runs a greedy outer loop that grows `L` in linear\nsteps of `params$L_greedy` until the fit has at least one empty\nslot (`min(lbf) < params$greedy_lbf_cutoff`, default `0.1`) or `L` reaches\n`params$L`. With `params$L_greedy = NULL` (default), runs a\nsingle fixed-`L` IBSS, output bit-identical to prior susieR.\n}\n\\keyword{internal}\n" }, { "path": "man/univar.order.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/univariate_regression.R\n\\name{univar.order}\n\\alias{univar.order}\n\\title{Ordering of Predictors from Univariate Regression}\n\\usage{\nunivar.order(X, y)\n}\n\\arguments{\n\\item{X}{An input design matrix. This may be centered and/or\nstandardized prior to calling function.}\n\n\\item{y}{A vector of response variables.}\n}\n\\value{\nAn ordering of the predictors.\n}\n\\description{\nThis function extracts the ordering of the predictors\n according to the coefficients estimated in a basic univariate\n regression; in particular, the predictors are ordered in decreasing\n order by magnitude of the univariate regression coefficient\n estimate.\n}\n\\examples{\n### generate synthetic data\nset.seed(1)\nn = 200\np = 300\nX = matrix(rnorm(n*p),n,p)\nbeta = double(p)\nbeta[1:10] = 1:10\ny = X \\%*\\% beta + rnorm(n)\n\nuniv.order = univar.order(X,y)\n\n}\n" }, { "path": "man/univariate_regression.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/univariate_regression.R\n\\name{univariate_regression}\n\\alias{univariate_regression}\n\\alias{calc_z}\n\\title{Perform Univariate Linear Regression Separately for Columns of X}\n\\usage{\nunivariate_regression(\n X,\n y,\n Z = NULL,\n center = TRUE,\n scale = FALSE,\n return_residuals = FALSE,\n method = c(\"lmfit\", \"sumstats\")\n)\n\ncalc_z(X, Y, center = FALSE, scale = FALSE)\n}\n\\arguments{\n\\item{X}{n by p matrix of regressors.}\n\n\\item{y}{n-vector of response variables.}\n\n\\item{Z}{Optional n by k matrix of covariates to be included in all\nregresions. If Z is not \\code{NULL}, the linear effects of\ncovariates are removed from y first, and the resulting residuals\nare used in place of y.}\n\n\\item{center}{If \\code{center = TRUE}, center X, y and Z.}\n\n\\item{scale}{If \\code{scale = TRUE}, scale X, y and Z.}\n\n\\item{return_residuals}{Whether or not to output the residuals if Z\nis not \\code{NULL}.}\n\n\\item{method}{Either \\dQuote{sumstats} (faster implementation) or\n\\dQuote{lmfit} (uses \\code{\\link[stats]{.lm.fit}}).}\n}\n\\value{\nA list with two vectors containing the least-squares\n estimates of the coefficients (\\code{betahat}) and their standard\n errors (\\code{sebetahat}). Optionally, and only when a matrix of\n covariates \\code{Z} is provided, a third vector \\code{residuals}\n containing the residuals is returned.\n}\n\\description{\nThis function performs the univariate linear\n regression y ~ x separately for each column x of X. The estimated effect size\n and stardard error for each variable are outputted.\n}\n\\examples{\nset.seed(1)\nn = 1000\np = 1000\nbeta = rep(0,p)\nbeta[1:4] = 1\nX = matrix(rnorm(n*p),nrow = n,ncol = p)\nX = scale(X,center = TRUE,scale = TRUE)\ny = drop(X \\%*\\% beta + rnorm(n))\nres = univariate_regression(X,y)\nplot(res$betahat/res$sebetahat)\n\n}\n" }, { "path": "man/unmappable_data.Rd", "content": "% Generated by roxygen2: do not edit by hand\n% Please edit documentation in R/example_dataset.R\n\\docType{data}\n\\name{unmappable_data}\n\\alias{unmappable_data}\n\\title{Simulated Fine-mapping Data with Sparse, Oligogenic and Polygenic Effects.}\n\\format{\n\\code{unmappable_data} is a list with the following elements:\n\n\\describe{\n\n \\item{X}{Centered and scaled genotype matrix.}\n\n \\item{y}{Simulated response.}\n\n \\item{beta}{Simulated effect sizes.}\n\n \\item{h2g}{Total proportion of variance in the response explained\n by the simulated effects.}}\n}\n\\description{\nA simulated data set with 1,000 individuals and 5,000\n variants, combining 3 sparse, 5 oligogenic and 15 polygenic\n non-zero effects. The response is generated under a linear\n regression model. This data set illustrates fine-mapping with\n SuSiE-ash and SuSiE-inf.\n}\n\\examples{\ndata(unmappable_data)\n}\n\\seealso{\nThe \\dQuote{Fine-mapping with SuSiE-ash and SuSiE-inf}\n vignette.\n}\n\\keyword{data}\n" }, { "path": "pixi.toml", "content": "[workspace]\nname = \"r-susier\"\nchannels = [\"dnachun\", \"conda-forge\", \"bioconda\"]\nplatforms = [\"linux-64\", \"osx-arm64\"]\n\n[system-requirements]\nlibc = { family=\"glibc\", version=\"2.17\" }\n\n[tasks]\ndevtools_document = \"cd $GITHUB_WORKSPACE; R -e 'devtools::document()'\"\ndevtools_test = \"cd $GITHUB_WORKSPACE; R -e 'devtools::test()'\"\ncodecov = \"cd $GITHUB_WORKSPACE; R -e 'covr::codecov(quiet = FALSE)'\"\nbuild = \"cd $GITHUB_WORKSPACE; R -e 'devtools::build(vignettes = TRUE)'\"\nrcmdcheck = \"cd $GITHUB_WORKSPACE; R -e 'pkg <- list.files(\\\"..\\\", pattern = \\\".tar.gz\\\", full.names = TRUE); rcmdcheck::rcmdcheck(path = pkg[1], args = c(\\\"--as-cran\\\", \\\"--no-manual\\\"))'\"\nuse_major_version = \"cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \\\"major\\\", push = FALSE)'\"\nuse_minor_version = \"cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \\\"minor\\\", push = FALSE)'\"\nuse_patch_version = \"cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \\\"patch\\\", push = FALSE)'\"\npkgdown_build = \"cd $GITHUB_WORKSPACE; R -e 'pkgdown::build_site_github_pages(new_process = FALSE, install = TRUE)'\"\n\n[feature.r44]\ndependencies = {\"r-base\" = \"4.4.*\"}\n\n[feature.r45]\ndependencies = {\"r-base\" = \"4.5.*\"}\n\n[environments]\nr44 = {features = [\"r44\"]}\nr45 = {features = [\"r45\"]}\n\n[target.linux-64.dependencies]\n\"gcc\" = \"*\"\n\n[dependencies]\n# Core dependencies (from Imports / LinkingTo)\n\"r-cpp11\" = \"*\"\n\"r-cpp11armadillo\" = \"*\"\n\"r-matrix\" = \"*\"\n\"r-matrixstats\" = \"*\"\n\"r-mixsqp\" = \"*\"\n\"r-reshape\" = \"*\"\n\"r-crayon\" = \"*\"\n\"r-ggplot2\" = \"*\"\n\"r-l0learn\" = \"*\"\n\"r-survival\" = \"*\"\n\n# Suggested dependencies (for testing and documentation)\n\"r-curl\" = \"*\"\n\"r-testthat\" = \"*\"\n\"r-microbenchmark\" = \"*\"\n\"r-knitr\" = \"*\"\n\"r-rmarkdown\" = \"*\"\n\"r-rfast\" = \"*\"\n\"r-cowplot\" = \"*\"\n\n# Development tools (optional, but useful for package development)\n\"r-devtools\" = \"*\"\n\"r-covr\" = \"*\"\n\"r-rcmdcheck\" = \"*\"\n\"r-pkgdown\" = \"*\"\n\"r-decor\" = \"*\" # required by cpp11::cpp_register() during devtools::document()\n\"qpdf\" = \"*\"\n" }, { "path": "src/Makevars", "content": "PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS)\nPKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)\n" }, { "path": "src/Makevars.win", "content": "PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) \nPKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)\n" }, { "path": "src/caisa.cpp", "content": "#include \n#include \n#include \"mr_ash.h\"\n\nusing namespace cpp11;\nusing namespace arma;\n\n// Random permutation index vector of length p * numiter (0-based).\n[[cpp11::register]]\nintegers random_order(int p, int numiter) {\n return as_integers(random_order_impl(p, numiter));\n}\n\n// Mr.ASH coordinate-ascent in sufficient-statistic form.\n[[cpp11::register]]\nwritable::list caisa_cpp(const doubles_matrix<>& X,\n const doubles& w, const doubles& sa2,\n const doubles& pi_init, const doubles& beta_init,\n const doubles& r_init, double sigma2,\n const integers& o_r,\n int maxiter, int miniter,\n double convtol, double epstol, std::string method_q,\n bool updatepi, bool updatesigma,\n bool verbose) {\n\n // cpp11 inputs -> Armadillo. pi, beta, r are mutated -> own their memory.\n const mat X_mat = as_Mat(X);\n const vec w_vec = as_Col(w);\n const vec sa2_vec = as_Col(sa2);\n const uvec o = as_uvec(o_r);\n vec pi = conv_to::from(as_Col(pi_init));\n vec beta = conv_to::from(as_Col(beta_init));\n vec r = conv_to::from(as_Col(r_init));\n\n const int n = X_mat.n_rows;\n const int p = X_mat.n_cols;\n const int K = sa2_vec.n_elem;\n\n // Per-iter per-coordinate prior weights (mixture precision + X*X'/sigma2).\n mat S2inv = 1.0 / outerAddition(1.0 / sa2_vec, w_vec);\n S2inv.row(0).fill(epstol);\n\n vec varobj(maxiter);\n vec piold, betaold;\n int iter = 0;\n int i = 0;\n\n for (iter = 0; iter < maxiter; iter++) {\n double a1 = 0.0, a2 = 0.0;\n piold = pi;\n betaold = beta;\n pi.fill(0);\n\n // Coordinate-ascent sweep (random order given by o)\n for (int j = 0; j < p; j++) {\n updatebetaj(X_mat.col(o(i)), w_vec(o(i)), beta(o(i)), r, piold, pi,\n sigma2, sa2_vec, S2inv.col(o(i)), a1, a2, o(i), p, epstol);\n i++;\n }\n\n // Variational objective (first term)\n varobj(iter) = dot(r, r) - dot(square(beta), w_vec) + a1;\n\n // Optionally update sigma2\n if (updatesigma) {\n if (method_q == \"sigma_indep_q\") {\n sigma2 = (varobj(iter) + p * (1.0 - pi(0)) * sigma2)\n / (n + p * (1.0 - pi(0)));\n } else if (method_q == \"sigma_dep_q\") {\n sigma2 = varobj(iter) / n;\n }\n }\n\n // Freeze piold for objective computation when updating pi\n if (updatepi) piold = pi;\n\n // Variational objective (full expression)\n varobj(iter) = varobj(iter) / sigma2 / 2.0\n + log(2.0 * M_PI * sigma2) / 2.0 * n\n - dot(pi, log(piold + epstol)) * p + a2;\n for (int j = 1; j < K; j++) {\n varobj(iter) += pi(j) * log(sa2_vec(j)) * p / 2.0;\n }\n\n // Restore pi if we are not updating it\n if (!updatepi) pi = piold;\n\n // Convergence: beta change small, or objective non-decreasing\n if (iter >= miniter - 1) {\n double beta_norm = norm(beta, 2);\n if (norm(betaold - beta, 2) < convtol * std::max(1.0, beta_norm)) {\n iter++;\n break;\n }\n if (iter > 0 && varobj(iter) > varobj(iter - 1)) break;\n }\n }\n\n if (verbose) {\n Rprintf(\"Mr.ASH terminated at iteration %d: max|beta|=%.4e, sigma2=%.4e, pi0=%.4f\\n\",\n iter, max(abs(beta)), sigma2, pi(0));\n }\n\n using namespace cpp11::literals;\n return writable::list({\n \"beta\"_nm = as_doubles(beta),\n \"sigma2\"_nm = as_sexp(sigma2),\n \"pi\"_nm = as_doubles(pi),\n \"iter\"_nm = as_sexp(iter),\n \"varobj\"_nm = as_doubles(vec(varobj.subvec(0, iter - 1)))\n });\n}\n" }, { "path": "src/cpp11.cpp", "content": "// Generated by cpp11: do not edit by hand\n// clang-format off\n\n\n#include \"cpp11/declarations.hpp\"\n#include \n\n// caisa.cpp\nintegers random_order(int p, int numiter);\nextern \"C\" SEXP _susieR_random_order(SEXP p, SEXP numiter) {\n BEGIN_CPP11\n return cpp11::as_sexp(random_order(cpp11::as_cpp>(p), cpp11::as_cpp>(numiter)));\n END_CPP11\n}\n// caisa.cpp\nwritable::list caisa_cpp(const doubles_matrix<>& X, const doubles& w, const doubles& sa2, const doubles& pi_init, const doubles& beta_init, const doubles& r_init, double sigma2, const integers& o_r, int maxiter, int miniter, double convtol, double epstol, std::string method_q, bool updatepi, bool updatesigma, bool verbose);\nextern \"C\" SEXP _susieR_caisa_cpp(SEXP X, SEXP w, SEXP sa2, SEXP pi_init, SEXP beta_init, SEXP r_init, SEXP sigma2, SEXP o_r, SEXP maxiter, SEXP miniter, SEXP convtol, SEXP epstol, SEXP method_q, SEXP updatepi, SEXP updatesigma, SEXP verbose) {\n BEGIN_CPP11\n return cpp11::as_sexp(caisa_cpp(cpp11::as_cpp&>>(X), cpp11::as_cpp>(w), cpp11::as_cpp>(sa2), cpp11::as_cpp>(pi_init), cpp11::as_cpp>(beta_init), cpp11::as_cpp>(r_init), cpp11::as_cpp>(sigma2), cpp11::as_cpp>(o_r), cpp11::as_cpp>(maxiter), cpp11::as_cpp>(miniter), cpp11::as_cpp>(convtol), cpp11::as_cpp>(epstol), cpp11::as_cpp>(method_q), cpp11::as_cpp>(updatepi), cpp11::as_cpp>(updatesigma), cpp11::as_cpp>(verbose)));\n END_CPP11\n}\n// mr_ash_rss.cpp\nwritable::list mr_ash_rss_cpp(const doubles& bhat, const doubles& shat, const doubles& z, const doubles_matrix<>& R, double var_y, int n, double sigma2_e, const doubles& s0, const doubles& w0, const doubles& mu1_init, double tol, int max_iter, bool update_w0, bool update_sigma, bool compute_ELBO, bool standardize);\nextern \"C\" SEXP _susieR_mr_ash_rss_cpp(SEXP bhat, SEXP shat, SEXP z, SEXP R, SEXP var_y, SEXP n, SEXP sigma2_e, SEXP s0, SEXP w0, SEXP mu1_init, SEXP tol, SEXP max_iter, SEXP update_w0, SEXP update_sigma, SEXP compute_ELBO, SEXP standardize) {\n BEGIN_CPP11\n return cpp11::as_sexp(mr_ash_rss_cpp(cpp11::as_cpp>(bhat), cpp11::as_cpp>(shat), cpp11::as_cpp>(z), cpp11::as_cpp&>>(R), cpp11::as_cpp>(var_y), cpp11::as_cpp>(n), cpp11::as_cpp>(sigma2_e), cpp11::as_cpp>(s0), cpp11::as_cpp>(w0), cpp11::as_cpp>(mu1_init), cpp11::as_cpp>(tol), cpp11::as_cpp>(max_iter), cpp11::as_cpp>(update_w0), cpp11::as_cpp>(update_sigma), cpp11::as_cpp>(compute_ELBO), cpp11::as_cpp>(standardize)));\n END_CPP11\n}\n\nextern \"C\" {\nstatic const R_CallMethodDef CallEntries[] = {\n {\"_susieR_caisa_cpp\", (DL_FUNC) &_susieR_caisa_cpp, 16},\n {\"_susieR_mr_ash_rss_cpp\", (DL_FUNC) &_susieR_mr_ash_rss_cpp, 16},\n {\"_susieR_random_order\", (DL_FUNC) &_susieR_random_order, 2},\n {NULL, NULL, 0}\n};\n}\n\nextern \"C\" attribute_visible void R_init_susieR(DllInfo* dll){\n R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);\n R_useDynamicSymbols(dll, FALSE);\n R_forceSymbols(dll, TRUE);\n}\n" }, { "path": "src/mr_ash.h", "content": "\n#ifndef MR_ASH_H\n#define MR_ASH_H\n#include \n#include \n\n// Helper: build a random permutation vector of length p * numiter.\n// Wrapped by a registered entry point in caisa.cpp.\ninline arma::uvec random_order_impl(int p, int numiter) {\n arma::uvec o(p * numiter);\n for (int i = 0 ; i < numiter; i++) {\n o.subvec(i * p, (i+1) * p - 1) = arma::randperm(p);\n }\n return o;\n}\n\ninline arma::mat outerAddition(const arma::vec& a, const arma::vec& b) {\n arma::mat A(a.n_elem, b.n_elem);\n A.fill(0);\n A.each_row() += b.t();\n A.each_col() += a;\n return A;\n}\n\ninline void updatebetaj(const arma::vec& xj, double wj,\n double& betaj, arma::vec& r,\n arma::vec& piold, arma::vec& pi,\n double sigma2, const arma::vec& sa2,\n const arma::vec& s2inv,\n double& a1, double& a2,\n int j, int p,\n double epstol) {\n\n // calculate b\n double bjwj = dot(r, xj) + betaj * wj;\n\n // update r first step\n r += xj * betaj;\n\n // calculate muj\n arma::vec muj = bjwj * s2inv;\n muj(0) = 0;\n\n // calculate phij\n arma::vec phij = log(piold + epstol) - log(1 + sa2 * wj)/2 + muj * (bjwj / 2 / sigma2);\n phij = exp(phij - max(phij));\n phij = phij / sum(phij);\n\n // pinew\n pi += phij / p;\n\n // update betaj\n betaj = dot(phij, muj);\n\n // update r second step\n r += -xj * betaj;\n\n // precalculate for M-step\n a1 += bjwj * betaj;\n a2 += dot(phij, log(phij + epstol));\n phij(0) = 0;\n a2 += -dot(phij, log(s2inv)) / 2;\n\n return;\n}\n\n#endif\n" }, { "path": "src/mr_ash_rss.cpp", "content": "#include \n#include \n#include \"mr_ash_rss.h\"\n\nusing namespace cpp11;\nusing namespace arma;\nusing namespace std;\n\n[[cpp11::register]]\nwritable::list mr_ash_rss_cpp(const doubles& bhat, const doubles& shat, const doubles& z,\n const doubles_matrix<>& R, double var_y, int n, double sigma2_e,\n const doubles& s0, const doubles& w0, const doubles& mu1_init,\n double tol = 1e-8, int max_iter = 1e5,\n bool update_w0 = true, bool update_sigma = true,\n bool compute_ELBO = true, bool standardize = false) {\n\n\t// Convert input types\n\tvec bhat_vec = as_Col(bhat);\n\tvec shat_vec = as_Col(shat);\n\tvec z_vec = as_Col(z);\n\tmat R_mat = as_Mat(R);\n\tvec s0_vec = as_Col(s0);\n\tvec w0_vec = as_Col(w0);\n\tvec mu1_init_vec = as_Col(mu1_init);\n\n\t// Call the C++ function\n\tunordered_map result = mr_ash_rss(bhat_vec, shat_vec, z_vec, R_mat, var_y, n, sigma2_e, s0_vec, w0_vec,\n\t mu1_init_vec, tol, max_iter, update_w0, update_sigma, compute_ELBO,\n\t standardize);\n\n\t// Convert the result to a named list (matrices returned as doubles_matrix).\n\t// The unordered_map iteration does not preserve insertion order.\n\twritable::list ret;\n\tfor (const auto& item : result) {\n\t\tcpp11::named_arg na(item.first.c_str());\n\t\tna = as_doubles_matrix(item.second);\n\t\tret.push_back(na);\n\t}\n\n\treturn ret;\n}\n" }, { "path": "src/mr_ash_rss.h", "content": "#ifndef MR_ASH_RSS_H\n#define MR_ASH_RSS_H\n\n#include \n#include \n#include \n#include \n#include \n#include \n\nusing namespace arma;\nusing namespace std;\n\n/**\n * Softmax function\n *\n * @param x Input vector\n * @return Softmax output vector\n */\ninline vec softmax_rss(const vec& x) {\n\tvec y = exp(x - max(x));\n\treturn y / sum(y);\n}\n\n/**\n * Bayesian regression with Normal prior from sufficient statistics\n *\n * @param xTx X'X (scalar)\n * @param xTy X'y (scalar)\n * @param sigma2_e Error variance\n * @param sigma2_0 Prior variance\n * @return An unordered_map containing the least-squares estimate (bhat, s2), the posterior mean and standard deviation (mu1, sigma2_1), and the log-Bayes factor (logbf)\n */\ninline unordered_map bayes_ridge_sufficient(double xTx, double xTy, double sigma2_e, double sigma2_0) {\n\t// Compute the least-squares estimate and its variance\n\tdouble bhat = xTy / xTx;\n\tdouble s2 = sigma2_e / xTx;\n\n\t// Compute the posterior mean and variance assuming a normal prior with zero mean and variance sigma2_0\n\tdouble sigma2_1 = 1 / (1 / s2 + 1 / sigma2_0);\n\tdouble mu1 = sigma2_1 / s2 * bhat;\n\n\t// Compute the log-Bayes factor\n\tdouble logbf = log(s2 / (sigma2_0 + s2)) / 2 + (pow(bhat, 2) / s2 - pow(bhat, 2) / (sigma2_0 + s2)) / 2;\n\n\t// Return the least-squares estimate (bhat, s2), the posterior mean and standard deviation (mu1, sigma2_1), and the log-Bayes factor (logbf)\n\treturn {{\"bhat\", bhat}, {\"s2\", s2}, {\"mu1\", mu1}, {\"sigma2_1\", sigma2_1}, {\"logbf\", logbf}};\n}\n\n/**\n * Bayesian regression with mixture-of-normals prior from sufficient statistics\n *\n * @param xTx X'X (scalar)\n * @param xTy X'y (scalar)\n * @param sigma2_e Error variance\n * @param w0 Mixture weights\n * @param sigma2_0 Mixture variances\n * @return An unordered_map containing the log-Bayes factor (logbf), the posterior assignment probabilities (w1), the posterior mean (mu1) and variance (sigma2_1) of the coefficients, and the posterior mean (mu1_k) and variance (sigma2_1_k) for each mixture component\n */\ninline unordered_map bayes_mix_sufficient(double xTx, double xTy, double sigma2_e, const vec& w0, const vec& sigma2_0) {\n\t// Get the number of mixture components (K)\n\tint K = sigma2_0.n_elem;\n\n\t// Compute the Bayes factors and posterior statistics separately for each mixture component\n\t// Note: sigma2_0[i] is the prior variance scale parameter (like sa2 in mr.ash).\n\t// The actual prior variance is sigma2_e * sigma2_0[i], matching mr.ash's model:\n\t// beta_j ~ sum_k pi_k * N(0, sigma2 * sa2[k])\n\tmat out(K, 5);\n\tfor (int i = 0; i < K; i++) {\n\t\tunordered_map ridge_out = bayes_ridge_sufficient(xTx, xTy, sigma2_e, sigma2_e * sigma2_0[i]);\n\t\tout(i, 0) = ridge_out[\"bhat\"];\n\t\tout(i, 1) = ridge_out[\"s2\"];\n\t\tout(i, 2) = ridge_out[\"mu1\"];\n\t\tout(i, 3) = ridge_out[\"sigma2_1\"];\n\t\tout(i, 4) = ridge_out[\"logbf\"];\n\t}\n\n\t// Compute the posterior assignment probabilities for the latent indicator variable\n\tvec w1 = softmax_rss(out.col(4) + log(w0));\n\n\t// Compute the posterior mean (mu1) and variance (sigma2_1) of the regression coefficients\n\tvec mu1_k_vec = out.col(2);\n\tvec sigma2_1_k_vec = out.col(3);\n\n\tdouble mu1 = sum(w1 % mu1_k_vec);\n\tdouble sigma2_1 = sum(w1 % (square(mu1_k_vec) + sigma2_1_k_vec)) - pow(mu1, 2);\n\n\t// Compute the log-Bayes factor as a linear combination of the individual BFs for each mixture component\n\tdouble u = max(out.col(4));\n\tdouble logbf = u + log(sum(w0 % exp(out.col(4) - u)));\n\n\t// Return the posterior assignment probabilities (w1), the posterior mean (mu1) and variance (sigma2_1) of the coefficients,\n\t// and the posterior mean (mu1_k) and variance (sigma2_1_k) for each mixture component, and the log-Bayes factor (logbf)\n\treturn {{\"w1\", w1}, {\"mu1\", vec(1, fill::value(mu1))}, {\"sigma2_1\", vec(1, fill::value(sigma2_1))},\n\t\t{\"mu1_k\", mu1_k_vec}, {\"sigma2_1_k\", sigma2_1_k_vec}, {\"logbf\", vec(1, fill::value(logbf))}};\n}\n\n/**\n * Bayesian multiple regression with mixture-of-normals prior from sufficient statistics\n *\n * @param XTy X'y vector\n * @param XTX X'X matrix\n * @param yTy y'y scalar\n * @param n Sample size\n * @param sigma2_e Error variance\n * @param sigma2_0 Mixture variances\n * @param w0 Mixture weights\n * @param mu1_init Initial value for mu1\n * @param tol Convergence tolerance\n * @param max_iter Maximum number of iterations\n * @param update_w0 Whether to update w0\n * @param update_sigma Whether to update sigma2_e\n * @param compute_ELBO Whether to compute the Evidence Lower Bound (ELBO)\n * @return An unordered_map containing the posterior assignment probabilities (w1), the posterior mean (mu1) and variance (sigma2_1) of the coefficients, the error variance (sigma2_e), the mixture weights (w0), and optionally the ELBO\n */\ninline unordered_map mr_ash_sufficient(const vec& XTy, const mat& XTX, double yTy, int n, double& sigma2_e,\n const vec& sigma2_0, vec& w0, const vec& mu1_init, double tol = 1e-8,\n int max_iter = 1e5, bool update_w0 = true, bool update_sigma = true,\n bool compute_ELBO = true) {\n\n\t// Initialize parameters\n\tint p = XTX.n_cols;\n\tint K = sigma2_0.n_elem;\n\tvec mu1_t = mu1_init;\n\tvec sigma2_1_t(p, fill::zeros);\n\tmat w1_t(p, K, fill::zeros);\n\tmat mu1_k_t(p, K, fill::zeros);\n\tmat sigma2_1_k_t(p, K, fill::zeros);\n\tint t = 0;\n\tdouble ELBO = 0;\n\tvec varobj_vec(max_iter, fill::zeros);\n\tbool converged = false;\n\n\t// Iterate until convergence\n\twhile (!converged) {\n\t\tdouble var_part_ERSS = 0;\n\t\tdouble neg_KL = 0;\n\n\t\t// Update iterator\n\t\tt++;\n\n\t\t// Exit loop if maximum number of iterations is reached\n\t\tif (t > max_iter) {\n\t\t\tt = max_iter; // Clamp to valid index range\n\t\t\tcerr << \"Max number of iterations reached. Try increasing max_iter.\" << endl;\n\t\t\tbreak;\n\t\t}\n\n\t\t// Save current estimates\n\t\tvec mu1_tminus1 = mu1_t;\n\n\t\tvec XTrbar = XTy - XTX * mu1_t;\n\n\t\t// Loop through the variables\n\t\tfor (int j = 0; j < p; j++) {\n\t\t\t// Remove j-th effect from expected residuals\n\t\t\tvec XTrbar_j = XTrbar + XTX.col(j) * mu1_t[j];\n\n\t\t\tdouble xTrbar_j = XTrbar_j[j];\n\t\t\tdouble xTx = XTX(j, j);\n\n\t\t\t// Run Bayesian SLR\n\t\t\tunordered_map bfit = bayes_mix_sufficient(xTx, xTrbar_j, sigma2_e, w0, sigma2_0);\n\n\t\t\t// Update variational parameters\n\t\t\tmu1_t[j] = bfit[\"mu1\"][0];\n\t\t\tsigma2_1_t[j] = bfit[\"sigma2_1\"][0];\n\t\t\tw1_t.row(j) = bfit[\"w1\"].t();\n\t\t\tmu1_k_t.row(j) = bfit[\"mu1_k\"].t();\n\t\t\tsigma2_1_k_t.row(j) = bfit[\"sigma2_1_k\"].t();\n\n\t\t\t// Compute ELBO parameters\n\t\t\tif (compute_ELBO) {\n\t\t\t\tvar_part_ERSS += sigma2_1_t[j] * xTx;\n\t\t\t\tneg_KL += bfit[\"logbf\"][0] + (1 / (2 * sigma2_e)) * (-2 * xTrbar_j * mu1_t[j] + (xTx * (sigma2_1_t[j] + pow(mu1_t[j], 2))));\n\t\t\t}\n\n\t\t\t// Update expected residuals\n\t\t\tXTrbar = XTrbar_j - XTX.col(j) * mu1_t[j];\n\t\t}\n\n\t\t// Update w0 if requested\n\t\tif (update_w0) {\n\t\t\tw0 = sum(w1_t, 0).t() / p;\n\t\t}\n\n\t\t// Compute convergence using relative L2 norm (matching mr.ash)\n\t\tdouble beta_diff = norm(mu1_t - mu1_tminus1, 2);\n\t\tdouble beta_norm = norm(mu1_t, 2);\n\n\t\t// Compute ERSS and ELBO\n\t\tdouble ERSS = yTy - 2 * dot(XTy, mu1_t) + as_scalar(mu1_t.t() * XTX * mu1_t) + var_part_ERSS;\n\t\tif (compute_ELBO) {\n\t\t\tELBO = -0.5 * log(n) - 0.5 * n * log(2 * datum::pi * sigma2_e) - (1 / (2 * sigma2_e)) * ERSS + neg_KL;\n\t\t}\n\t\tvarobj_vec[t - 1] = ELBO;\n\n\t\t// Update residual variance using mr.ash's sigma_dep_q formula:\n\t\t// sigma2 = (y'y - beta'X'y) / n\n\t\tif (update_sigma) {\n\t\t\tsigma2_e = (yTy - dot(XTy, mu1_t)) / n;\n\t\t}\n\n\t\t// Check convergence (matching mr.ash's relative L2 criterion)\n\t\tif (t >= 2 && beta_diff < tol * max(1.0, beta_norm)) {\n\t\t\tconverged = true;\n\t\t}\n\t}\n\n\t// Return results including iteration count and ELBO trajectory\n\treturn {{\"mu1\", mat(mu1_t)}, {\"sigma2_1\", mat(sigma2_1_t)}, {\"w1\", w1_t},\n\t\t{\"sigma2_e\", mat(1, 1, fill::value(sigma2_e))}, {\"w0\", mat(w0)},\n\t\t{\"ELBO\", mat(1, 1, fill::value(ELBO))},\n\t\t{\"iter\", mat(1, 1, fill::value((double)t))},\n\t\t{\"varobj\", mat(varobj_vec.subvec(0, t - 1))}};\n}\n\n/**\n * Rescale posterior mean and covariance\n *\n * @param mu1 Posterior mean vector\n * @param sigma2_1 Posterior covariance matrix\n * @param sx Scaling vector\n * @return An unordered_map containing the rescaled posterior mean (mu1_orig) and covariance (sigma2_1_orig)\n */\ninline unordered_map rescale_post_mean_covar(const vec& mu1, const mat& sigma2_1, const vec& sx) {\n\tvec mu1_orig = mu1 / sx;\n\tmat sigma2_1_orig = diagmat(1 / sx) * sigma2_1 * diagmat(1 / sx);\n\treturn {{\"mu1_orig\", mat(mu1_orig)}, {\"sigma2_1_orig\", sigma2_1_orig}};\n}\n\n/**\n * Bayesian multiple regression with mixture-of-normals prior\n *\n * @param bhat Observed effect sizes (standardized)\n * @param shat Standard errors of effect sizes\n * @param z Z-scores\n * @param R Correlation matrix\n * @param var_y Variance of the outcome\n * @param n Sample size\n * @param sigma2_e Error variance\n * @param s0 Prior variances for the mixture components\n * @param w0 Prior weights for the mixture components\n * @param mu1_init Initial value for the posterior mean of the coefficients\n * @param tol Convergence tolerance\n * @param max_iter Maximum number of iterations\n * @param update_w0 Whether to update the mixture weights\n * @param update_sigma Whether to update the error variance\n * @param compute_ELBO Whether to compute the Evidence Lower Bound (ELBO)\n * @param standardize Whether to standardize the input data\n * @return An unordered_map containing the posterior mean (mu1) and covariance (sigma2_1) of the coefficients, the posterior assignment probabilities (w1), the error variance (sigma2_e), the mixture weights (w0), and optionally the ELBO\n */\ninline unordered_map mr_ash_rss(const vec& bhat, const vec& shat, const vec& z, const mat& R, double var_y, int n,\n double sigma2_e, const vec& s0, vec& w0, const vec& mu1_init, double tol = 1e-8,\n int max_iter = 1e5, bool update_w0 = true, bool update_sigma = true, bool compute_ELBO = true,\n bool standardize = false) {\n\t// Get number of variables\n\tint p = z.n_elem;\n\n\t// Initialize regression coefficients to 0 if not provided\n\tvec mu1_init_use = mu1_init;\n\tif (mu1_init.is_empty()) {\n\t\tmu1_init_use = vec(p, fill::zeros);\n\t}\n\n\t// Compute Z-scores if not provided\n\tvec z_use = z;\n\tif (z.is_empty()) {\n\t\tz_use = bhat / shat;\n\t}\n\n\t// Compute PVE-adjusted Z-scores if sample size is provided\n\tvec adj(p, fill::ones);\n\tif (std::isfinite(n)) {\n\t\tadj = (n - 1) / (square(z_use) + n - 2);\n\t\tz_use %= sqrt(adj);\n\t}\n\t// Compute X'X and X'y\n\tmat XtX;\n\tvec Xty;\n\tif (std::isfinite(var_y) && !shat.is_empty()) {\n\t\tvec XtXdiag = var_y * adj / square(shat);\n\t\tXtX = diagmat(sqrt(XtXdiag)) * R * diagmat(sqrt(XtXdiag));\n\t\tXtX = 0.5 * (XtX + XtX.t());\n\t\tXty = z_use % sqrt(adj) % (var_y / shat);\n\t} else {\n\t\t// The effects are on the standardized X, y scale\n\t\tXtX = (n - 1) * R;\n\t\tXty = z_use * sqrt(n - 1);\n\t\tvar_y = 1.0;\n\t}\n\n\t// Adjust X'X and X'y if X is standardized\n\tvec sx(p, fill::ones);\n\tif (standardize) {\n\t\tvec dXtX = XtX.diag();\n\t\tsx = sqrt(dXtX / (n - 1));\n\t\tsx.replace(0, 1);\n\t\tXtX = diagmat(1 / sx) * XtX * diagmat(1 / sx);\n\t\tXty /= sx;\n\t\tmu1_init_use %= sx;\n\t}\n\n\t// Run variational inference\n\tunordered_map result = mr_ash_sufficient(Xty, XtX, var_y * (n - 1), n, sigma2_e, s0, w0, mu1_init_use,\n\t tol, max_iter, update_w0, update_sigma, compute_ELBO);\n\n\t// Rescale posterior mean and covariance if X was standardized\n\tif (standardize) {\n\t\tunordered_map out_adj = rescale_post_mean_covar(vectorise(result[\"mu1\"]), result[\"sigma2_1\"], sx);\n\t\tresult[\"mu1\"] = out_adj[\"mu1_orig\"];\n\t\tresult[\"sigma2_1\"] = out_adj[\"sigma2_1_orig\"];\n\t}\n\n\treturn {{\"mu1\", result[\"mu1\"]}, {\"sigma2_1\", result[\"sigma2_1\"]}, {\"w1\", result[\"w1\"]},\n\t\t{\"sigma2_e\", result[\"sigma2_e\"]}, {\"w0\", result[\"w0\"]}, {\"ELBO\", result[\"ELBO\"]},\n\t\t{\"iter\", result[\"iter\"]}, {\"varobj\", result[\"varobj\"]}};\n};\n\n#endif\n" }, { "path": "tests/README.md", "content": "# susieR Testing Framework\n\nThis directory contains the comprehensive test suite for the susieR 2.0 package, with **>1,000 total tests** ensuring code correctness, stability, and consistency with the reference implementation.\n\n## File Organization\n\n- `testthat/`: Directory containing test files\n - `helper_*.R`: Helper functions used in testing for simulating data, assigning attributes, and more\n - `test_*.R`: Unit tests validating correctness and stability for all functions in susieR 2.0\n - `reference/`: Reference tests ensuring consistency with original susieR 1.0 implementation\n" }, { "path": "tests/testthat/helper_nig_reference.R", "content": "# =============================================================================\n# HELPER FUNCTIONS FOR NIG REFERENCE COMPARISON\n# =============================================================================\n#\n# These functions compare the local susieR implementation of\n# estimate_residual_method = \"NIG\" against the reference\n# implementation on stephenslab/susieR@fix-susie-small-sigma-update\n# (commit a999d44), where the equivalent feature is small = TRUE.\n#\n# This helper parallels helper_reference.R but targets a different\n# reference commit and maps between the two parameter interfaces.\n#\nlibrary(pkgload)\nlibrary(rprojroot)\n\n# Reference package details for the NIG comparison\n.nig_ref_repo <- \"stephenslab/susieR\"\n.nig_ref_commit <- \"a999d44\"\n\n# Cached environments (separate from helper_reference.R's globals)\n.nig_ref_env <- NULL\n.nig_dev_env <- NULL\n.nig_ref_source_path <- NULL\n\n# Get reference source for the fix-susie-small-sigma-update branch\nget_nig_reference_source <- function() {\n if (!is.null(.nig_ref_source_path) && dir.exists(.nig_ref_source_path)) {\n return(.nig_ref_source_path)\n }\n\n ref_source <- file.path(tempdir(), \"susieR_nig_reference_source\")\n\n if (!dir.exists(ref_source)) {\n message(\"Downloading NIG reference source from GitHub...\")\n\n result <- system(sprintf(\"git clone -q https://github.com/%s.git %s 2>&1\",\n .nig_ref_repo, ref_source),\n intern = FALSE)\n\n if (result != 0) {\n stop(\"Failed to clone reference package\")\n }\n\n result <- system(sprintf(\"cd %s && git checkout -q %s 2>&1\",\n ref_source, .nig_ref_commit),\n intern = FALSE)\n\n if (result != 0) {\n stop(\"Failed to checkout commit \", .nig_ref_commit)\n }\n\n message(\"\\u2713 NIG reference source downloaded\")\n }\n\n .nig_ref_source_path <<- ref_source\n return(ref_source)\n}\n\n# Load the fix-susie-small-sigma-update reference using pkgload\nload_nig_reference_env <- function() {\n if (!is.null(.nig_ref_env)) {\n return(.nig_ref_env)\n }\n\n if (!requireNamespace(\"pkgload\", quietly = TRUE)) {\n stop(\"Package 'pkgload' is required. Install with: install.packages('pkgload')\")\n }\n\n ref_source <- get_nig_reference_source()\n\n message(\"Loading NIG reference package with pkgload...\")\n env <- pkgload::load_all(ref_source, export_all = FALSE, quiet = TRUE)\n\n .nig_ref_env <<- env\n return(env)\n}\n\n# Load development package using pkgload\nload_nig_development_env <- function() {\n if (!is.null(.nig_dev_env)) {\n return(.nig_dev_env)\n }\n\n if (!requireNamespace(\"pkgload\", quietly = TRUE)) {\n stop(\"Package 'pkgload' is required. Install with: install.packages('pkgload')\")\n }\n\n dev_source <- tryCatch({\n rprojroot::find_root(rprojroot::is_r_package)\n }, error = function(e) {\n normalizePath(file.path(getwd(), \"../..\"))\n })\n\n message(\"Loading development package with pkgload...\")\n env <- pkgload::load_all(dev_source, export_all = FALSE, quiet = TRUE)\n\n .nig_dev_env <<- env\n return(env)\n}\n\n# Skip test if reference not available\nskip_if_no_nig_reference <- function() {\n tryCatch({\n load_nig_reference_env()\n load_nig_development_env()\n }, error = function(e) {\n skip(paste(\"NIG reference comparison not available:\", e$message))\n })\n}\n\n# -----------------------------------------------------------------------\n# compare_NIG_to_reference\n#\n# Runs susie() with estimate_residual_method = \"NIG\" on the\n# development package and susie() with small = TRUE on the reference\n# branch, then compares all output fields.\n#\n# Parameters:\n# dev_args - named list of arguments for the development susie() call\n# (must include X and y; estimate_residual_method is set\n# automatically to \"NIG\")\n# ref_args - (optional) named list of arguments for the reference\n# susie() call. If NULL, derived from dev_args by mapping\n# estimate_residual_method -> small = TRUE and\n# tol -> tol_small.\n# tolerance - numeric tolerance for expect_equal comparisons\n# -----------------------------------------------------------------------\ncompare_NIG_to_reference <- function(dev_args,\n ref_args = NULL,\n tolerance = 1e-5) {\n skip_if_no_nig_reference()\n\n ref_env <- load_nig_reference_env()\n dev_env <- load_nig_development_env()\n\n # Ensure the dev call uses NIG\n dev_args$estimate_residual_method <- \"NIG\"\n\n # Match reference behavior: disable V null threshold check and use\n # the same convergence tolerance as the reference (tol_small = 1e-4)\n if (is.null(dev_args$check_null_threshold))\n dev_args$check_null_threshold <- -Inf\n if (is.null(dev_args$tol))\n dev_args$tol <- 1e-4\n\n # Match reference NIG hyperparameter defaults. Dev defaults changed in\n # commit b0b0c40 (\"new defaults\") from alpha0 = beta0 = 0.1 to\n # alpha0 = beta0 = 1/sqrt(n), a weakly-informative scaling. The reference\n # (stephenslab/susieR@a999d44, small = TRUE) still uses 0.1. Force 0.1\n # on the dev side when the caller hasn't set these so the two runs use\n # the same prior; the change to 1/sqrt(n) is a deliberate design choice\n # unrelated to mathematical parity with the reference.\n if (is.null(dev_args$alpha0))\n dev_args$alpha0 <- 0.1\n if (is.null(dev_args$beta0))\n dev_args$beta0 <- 0.1\n\n # Build reference args by mapping interface differences\n if (is.null(ref_args)) {\n ref_args <- dev_args\n\n # Map estimate_residual_method -> small\n ref_args$estimate_residual_method <- NULL\n ref_args$small <- TRUE\n\n # Map tol -> tol_small (reference replaces tol with tol_small when small=TRUE)\n if (!is.null(ref_args$tol)) {\n ref_args$tol_small <- ref_args$tol\n ref_args$tol <- NULL\n }\n\n # Remove parameters that don't exist in the reference interface\n ref_args$convergence_method <- NULL\n\n # The reference uses s_init instead of model_init\n if (!is.null(ref_args$model_init)) {\n ref_args$s_init <- ref_args$model_init\n ref_args$model_init <- NULL\n }\n }\n\n ref_func <- ref_env$env[[\"susie\"]]\n dev_func <- dev_env$env[[\"susie\"]]\n\n if (is.null(ref_func)) stop(\"susie() not found in reference package\")\n if (is.null(dev_func)) stop(\"susie() not found in development package\")\n\n # Suppress known warnings (method override messages)\n dev_result <- suppressWarnings(do.call(dev_func, dev_args))\n ref_result <- suppressWarnings(do.call(ref_func, ref_args))\n\n # Return both results for custom assertions\n invisible(list(dev = dev_result, ref = ref_result))\n}\n\n# -----------------------------------------------------------------------\n# expect_equal_NIG_objects\n#\n# Deep comparison of susie objects produced under the NIG /\n# small = TRUE prior. Compares the standard fields (alpha, mu, mu2, V,\n# sigma2, elbo, fitted, intercept, pip, sets) plus the NIG-specific\n# rv field.\n# -----------------------------------------------------------------------\nexpect_equal_NIG_objects <- function(dev_obj, ref_obj,\n tolerance = 1e-5) {\n\n # --- Core posterior quantities ---\n expect_equal(dev_obj$alpha, ref_obj$alpha, tolerance = tolerance,\n info = \"alpha (posterior inclusion probabilities) differ\")\n\n expect_equal(dev_obj$mu, ref_obj$mu, tolerance = tolerance,\n info = \"mu (posterior means) differ\")\n\n expect_equal(dev_obj$mu2, ref_obj$mu2, tolerance = tolerance,\n info = \"mu2 (posterior second moments) differ\")\n\n # --- Variance parameters ---\n expect_equal(dev_obj$V, ref_obj$V, tolerance = tolerance,\n info = \"V (prior variance, after rv scaling) differs\")\n\n expect_equal(dev_obj$sigma2, ref_obj$sigma2, tolerance = tolerance,\n info = \"sigma2 (residual variance) differs\")\n\n # --- Residual variance per effect (NIG-specific) ---\n if (!is.null(dev_obj$rv) && !is.null(ref_obj$rv)) {\n expect_equal(dev_obj$rv, ref_obj$rv, tolerance = tolerance,\n info = \"rv (per-effect residual variance) differs\")\n }\n\n # --- ELBO / convergence ---\n # For L = 1 the dev package intentionally uses ELBO convergence while\n # the reference uses PIP convergence, so niter and elbo may differ.\n # Only compare these for L > 1.\n L <- nrow(dev_obj$alpha)\n if (L > 1) {\n expect_equal(dev_obj$niter, ref_obj$niter,\n info = \"Number of iterations differs\")\n\n expect_equal(dev_obj$converged, ref_obj$converged,\n info = \"Convergence status differs\")\n }\n\n # For L = 1 the ELBO (loglik) is well-defined; compare if both present\n # and the iteration counts match (they may differ due to convergence method)\n if (!is.null(dev_obj$elbo) && !is.null(ref_obj$elbo) &&\n !all(is.na(dev_obj$elbo)) && !all(is.na(ref_obj$elbo)) &&\n length(dev_obj$elbo) == length(ref_obj$elbo)) {\n expect_equal(dev_obj$elbo, ref_obj$elbo, tolerance = tolerance,\n info = \"ELBO values differ\")\n }\n\n # --- Fitted values and intercept ---\n if (!is.null(dev_obj$fitted) && !is.null(ref_obj$fitted)) {\n expect_equal(dev_obj$fitted, ref_obj$fitted, tolerance = tolerance,\n info = \"Fitted values differ\")\n }\n\n expect_equal(dev_obj$intercept, ref_obj$intercept, tolerance = tolerance,\n info = \"Intercept differs\")\n\n # --- PIPs ---\n if (!is.null(dev_obj$pip) && !is.null(ref_obj$pip)) {\n expect_equal(dev_obj$pip, ref_obj$pip, tolerance = tolerance,\n info = \"PIPs differ\")\n }\n\n # --- Credible sets ---\n if (!is.null(dev_obj$sets) && !is.null(ref_obj$sets)) {\n expect_equal(dev_obj$sets$cs, ref_obj$sets$cs,\n info = \"Credible sets differ\")\n if (!is.null(dev_obj$sets$purity) && !is.null(ref_obj$sets$purity)) {\n expect_equal(dev_obj$sets$purity, ref_obj$sets$purity,\n tolerance = tolerance, info = \"CS purity differs\")\n }\n expect_equal(dev_obj$sets$coverage, ref_obj$sets$coverage,\n tolerance = tolerance, info = \"CS coverage differs\")\n }\n\n invisible(TRUE)\n}\n\n# -----------------------------------------------------------------------\n# run_ss_and_individual_NIG\n#\n# Given X, y, and extra arguments (L, standardize, intercept, alpha0,\n# beta0, etc.), runs both susie() and susie_ss() with\n# estimate_residual_method = \"NIG\", ensuring that the\n# sufficient statistics are computed to match susie()'s internal\n# preprocessing.\n#\n# Returns list(ind = ..., ss = ...) with both results.\n# -----------------------------------------------------------------------\nrun_ss_and_individual_NIG <- function(X, y, extra_args = list()) {\n n <- nrow(X)\n p <- ncol(X)\n\n # Extract preprocessing settings (defaults match susie)\n intercept <- if (!is.null(extra_args$intercept)) extra_args$intercept else TRUE\n standardize <- if (!is.null(extra_args$standardize)) extra_args$standardize else TRUE\n\n # Preprocess exactly as susie() does internally\n y_mean <- mean(y)\n X_colmeans <- colMeans(X)\n\n if (intercept) {\n y_c <- y - y_mean\n X_c <- scale(X, center = TRUE, scale = FALSE)\n } else {\n y_c <- y\n X_c <- X\n }\n\n if (standardize) {\n csd <- apply(X, 2, sd)\n csd[csd == 0] <- 1\n X_cs <- t(t(X_c) / csd)\n } else {\n X_cs <- X_c\n }\n\n # Compute sufficient statistics from preprocessed data\n XtX <- crossprod(X_cs)\n Xty <- drop(t(X_cs) %*% y_c)\n yty <- sum(y_c^2)\n\n # Run individual-level susie\n ind_args <- c(list(X = X, y = y,\n estimate_residual_method = \"NIG\"),\n extra_args)\n res_ind <- suppressWarnings(do.call(susie, ind_args))\n\n # Build SS arguments: remove individual-only params, add SS-specific ones\n ss_extra <- extra_args\n ss_extra$intercept <- NULL\n ss_extra$standardize <- NULL\n\n ss_args <- c(list(XtX = XtX, Xty = Xty, yty = yty, n = n,\n estimate_residual_method = \"NIG\",\n standardize = FALSE,\n X_colmeans = if (intercept) X_colmeans else NA,\n y_mean = if (intercept) y_mean else NA),\n ss_extra)\n res_ss <- suppressWarnings(do.call(susie_ss, ss_args))\n\n list(ind = res_ind, ss = res_ss)\n}\n\n# -----------------------------------------------------------------------\n# run_rss_and_individual_NIG\n#\n# Given X, y, and extra arguments (L, standardize, intercept, alpha0,\n# beta0, etc.), runs both susie() and susie_rss() with\n# estimate_residual_method = \"NIG\", ensuring that the\n# summary statistics (bhat, shat, R, var_y) are computed to match\n# susie()'s internal preprocessing.\n#\n# Uses the bhat/shat/var_y input path of susie_rss(), which recovers\n# exact sufficient statistics (XtX, Xty, yty) from summary statistics.\n# This is necessary because the NIG prior's alpha0/beta0 break scale\n# invariance, so the z-score-only path would not match.\n#\n# Returns list(ind = ..., rss = ...) with both results.\n# -----------------------------------------------------------------------\nrun_rss_and_individual_NIG <- function(X, y, extra_args = list()) {\n n <- nrow(X)\n p <- ncol(X)\n\n # Extract preprocessing settings (defaults match susie)\n intercept <- if (!is.null(extra_args$intercept)) extra_args$intercept else TRUE\n standardize <- if (!is.null(extra_args$standardize)) extra_args$standardize else TRUE\n\n # Preprocess exactly as susie() does internally\n if (intercept) {\n y_c <- y - mean(y)\n X_c <- scale(X, center = TRUE, scale = FALSE)\n } else {\n y_c <- y\n X_c <- X\n }\n\n if (standardize) {\n csd <- apply(X, 2, sd)\n csd[csd == 0] <- 1\n X_cs <- t(t(X_c) / csd)\n } else {\n X_cs <- X_c\n }\n\n # Compute correlation matrix from preprocessed data\n R <- cor(X_cs)\n R <- (R + t(R)) / 2 # ensure symmetry\n\n # Compute bhat/shat via univariate regression on preprocessed data\n # center=FALSE because we already centered\n ss <- univariate_regression(X_cs, y_c, center = FALSE)\n\n # Compute var_y\n var_y <- sum(y_c^2) / (n - 1)\n\n # Run individual-level susie\n ind_args <- c(list(X = X, y = y,\n estimate_residual_method = \"NIG\"),\n extra_args)\n res_ind <- suppressWarnings(do.call(susie, ind_args))\n\n # Build RSS arguments: remove individual-only params, add RSS-specific ones\n rss_extra <- extra_args\n rss_extra$intercept <- NULL\n rss_extra$standardize <- NULL\n\n rss_args <- c(list(bhat = ss$betahat, shat = ss$sebetahat,\n R = R, n = n, var_y = var_y,\n estimate_residual_method = \"NIG\",\n standardize = FALSE),\n rss_extra)\n res_rss <- suppressWarnings(do.call(susie_rss, rss_args))\n\n list(ind = res_ind, rss = res_rss)\n}\n\n# -----------------------------------------------------------------------\n# expect_rss_matches_individual_ss\n#\n# Deep comparison of susie objects produced by the individual-level and\n# RSS interfaces under NIG. Delegates to\n# expect_ss_matches_individual_ss by mapping rss -> ss.\n# -----------------------------------------------------------------------\nexpect_rss_matches_individual_ss <- function(res, tolerance = 1e-6) {\n expect_ss_matches_individual_ss(\n list(ind = res$ind, ss = res$rss),\n tolerance = tolerance\n )\n}\n\n# -----------------------------------------------------------------------\n# expect_ss_matches_individual_ss\n#\n# Deep comparison of susie objects produced by the individual-level and\n# sufficient-statistics interfaces under NIG.\n# -----------------------------------------------------------------------\nexpect_ss_matches_individual_ss <- function(res, tolerance = 1e-6) {\n ind <- res$ind\n ss <- res$ss\n\n # Core posterior quantities\n expect_equal(ind$alpha, ss$alpha, tolerance = tolerance,\n info = \"alpha differs between susie and susie_ss\")\n expect_equal(ind$mu, ss$mu, tolerance = tolerance,\n info = \"mu differs between susie and susie_ss\")\n expect_equal(ind$mu2, ss$mu2, tolerance = tolerance,\n info = \"mu2 differs between susie and susie_ss\")\n expect_equal(ind$V, ss$V, tolerance = tolerance,\n info = \"V differs between susie and susie_ss\")\n expect_equal(ind$sigma2, ss$sigma2, tolerance = tolerance,\n info = \"sigma2 differs between susie and susie_ss\")\n expect_equal(ind$pip, ss$pip, tolerance = tolerance,\n info = \"pip differs between susie and susie_ss\")\n\n # Convergence\n expect_equal(ind$niter, ss$niter,\n info = \"niter differs between susie and susie_ss\")\n expect_equal(ind$converged, ss$converged,\n info = \"converged differs between susie and susie_ss\")\n\n # NIG-specific: per-effect residual variance\n if (!is.null(ind$rv) && !is.null(ss$rv)) {\n expect_equal(ind$rv, ss$rv, tolerance = tolerance,\n info = \"rv differs between susie and susie_ss\")\n }\n\n # Credible sets\n if (!is.null(ind$sets) && !is.null(ss$sets)) {\n expect_equal(ind$sets$cs, ss$sets$cs,\n info = \"Credible sets differ between susie and susie_ss\")\n if (!is.null(ind$sets$purity) && !is.null(ss$sets$purity)) {\n expect_equal(ind$sets$purity, ss$sets$purity,\n tolerance = tolerance,\n info = \"CS purity differs between susie and susie_ss\")\n }\n }\n\n invisible(TRUE)\n}\n" }, { "path": "tests/testthat/helper_reference.R", "content": "# =============================================================================\n# HELPER FUNCTIONS FOR REFERENCE PACKAGE COMPARISON (PKGLOAD APPROACH)\n# =============================================================================\n#\n# These functions compare the new susieR implementation against the reference\n# package (stephenslab/susieR@1f9166c) to ensure results are identical.\n#\n# Strategy: Use pkgload to load both packages into separate environments\nlibrary(pkgload)\nlibrary(rprojroot)\n\n# Reference package details\n.ref_repo <- \"stephenslab/susieR\"\n.ref_commit <- \"1f9166c\"\n\n# Cached environments\n.ref_env <- NULL\n.dev_env <- NULL\n.ref_source_path <- NULL\n\n# Get reference package source (download once, cache path)\nget_reference_source <- function() {\n if (!is.null(.ref_source_path) && dir.exists(.ref_source_path)) {\n return(.ref_source_path)\n }\n\n # Download to temp directory\n ref_source <- file.path(tempdir(), \"susieR_reference_source\")\n\n if (!dir.exists(ref_source)) {\n message(\"Downloading reference package source from GitHub...\")\n\n result <- system(sprintf(\"git clone -q https://github.com/%s.git %s 2>&1\",\n .ref_repo, ref_source),\n intern = FALSE)\n\n if (result != 0) {\n stop(\"Failed to clone reference package\")\n }\n\n result <- system(sprintf(\"cd %s && git checkout -q %s 2>&1\",\n ref_source, .ref_commit),\n intern = FALSE)\n\n if (result != 0) {\n stop(\"Failed to checkout commit \", .ref_commit)\n }\n\n message(\"✓ Reference source downloaded\")\n }\n\n .ref_source_path <<- ref_source\n return(ref_source)\n}\n\n# Load reference package using pkgload\nload_reference_env <- function() {\n if (!is.null(.ref_env)) {\n return(.ref_env)\n }\n\n if (!requireNamespace(\"pkgload\", quietly = TRUE)) {\n stop(\"Package 'pkgload' is required. Install with: install.packages('pkgload')\")\n }\n\n ref_source <- get_reference_source()\n\n message(\"Loading reference package with pkgload...\")\n env <- pkgload::load_all(ref_source, export_all = FALSE, quiet = TRUE)\n\n .ref_env <<- env\n return(env)\n}\n\n# Load development package using pkgload\nload_development_env <- function() {\n if (!is.null(.dev_env)) {\n return(.dev_env)\n }\n\n if (!requireNamespace(\"pkgload\", quietly = TRUE)) {\n stop(\"Package 'pkgload' is required. Install with: install.packages('pkgload')\")\n }\n\n # Get path to development package (current package being tested)\n # Use rprojroot to find package root\n dev_source <- tryCatch({\n rprojroot::find_root(rprojroot::is_r_package)\n }, error = function(e) {\n # Fallback: assume we're in tests/testthat\n normalizePath(file.path(getwd(), \"../..\"))\n })\n\n message(\"Loading development package with pkgload...\")\n env <- pkgload::load_all(dev_source, export_all = FALSE, quiet = TRUE)\n\n .dev_env <<- env\n return(env)\n}\n\n# Skip test if reference not available\nskip_if_no_reference <- function() {\n tryCatch({\n load_reference_env()\n load_development_env()\n }, error = function(e) {\n skip(paste(\"Reference comparison not available:\", e$message))\n })\n}\n\n# Compare new implementation to reference\ncompare_to_reference <- function(func_name, args, tolerance = 1e-8, ref_func_name = NULL, ref_args = NULL) {\n skip_if_no_reference()\n\n # Load both environments\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n # If ref_func_name not specified, use same name as dev function\n if (is.null(ref_func_name)) {\n ref_func_name <- func_name\n }\n\n # If ref_args not specified, use same args as dev function\n if (is.null(ref_args)) {\n ref_args <- args\n }\n\n # Dev skips the null-likelihood V-zeroing step for EM (intentional: avoids\n # an inconsistent (q, V) pair that can decrease the ELBO; null effects are\n # instead removed by trim_null_effects() post-convergence). The reference\n # always runs the check. Setting check_null_threshold = -Inf disables the\n # check on the reference side without affecting dev, making the two paths\n # comparable. Only injected when the caller hasn't set it explicitly.\n uses_em <- identical(args$estimate_prior_method, \"EM\") ||\n identical(ref_args$estimate_prior_method, \"EM\")\n if (uses_em) {\n if (is.null(args$check_null_threshold))\n args$check_null_threshold <- -Inf\n if (is.null(ref_args$check_null_threshold))\n ref_args$check_null_threshold <- -Inf\n }\n\n # Get functions from each environment\n ref_func <- ref_env$env[[ref_func_name]]\n dev_func <- dev_env$env[[func_name]]\n\n if (is.null(ref_func)) {\n stop(\"Function '\", ref_func_name, \"' not found in reference package\")\n }\n\n if (is.null(dev_func)) {\n stop(\"Function '\", func_name, \"' not found in development package\")\n }\n\n # Call both implementations (potentially with different arguments)\n dev_result <- do.call(dev_func, args)\n ref_result <- do.call(ref_func, ref_args)\n\n # Deep comparison of all fields\n expect_equal_susie_objects(dev_result, ref_result, tolerance)\n\n invisible(list(dev = dev_result, ref = ref_result))\n}\n\n# Inject check_null_threshold = -Inf when estimate_prior_method = \"EM\" and\n# the caller hasn't explicitly set a threshold. Needed because dev skips the\n# null-likelihood V-zeroing step for EM while the reference always runs it;\n# -Inf disables the check on the reference side. Safe for dev (the branch is\n# not executed). Used by direct do.call sites in tests that don't go through\n# compare_to_reference().\n#' @keywords internal\ninject_em_null_check <- function(args) {\n if (identical(args$estimate_prior_method, \"EM\") &&\n is.null(args$check_null_threshold)) {\n args$check_null_threshold <- -Inf\n }\n args\n}\n\n# Deep comparison of susie objects\nexpect_equal_susie_objects <- function(dev_obj, ref_obj, tolerance = 1e-8) {\n\n # Core posterior quantities\n expect_equal(dev_obj$alpha, ref_obj$alpha, tolerance = tolerance,\n info = \"alpha (posterior inclusion probabilities) differ\")\n\n expect_equal(dev_obj$mu, ref_obj$mu, tolerance = tolerance,\n info = \"mu (posterior means) differ\")\n\n expect_equal(dev_obj$mu2, ref_obj$mu2, tolerance = tolerance,\n info = \"mu2 (posterior second moments) differ\")\n\n # Variance parameters\n expect_equal(dev_obj$V, ref_obj$V, tolerance = tolerance,\n info = \"V (prior variance) differs\")\n\n expect_equal(dev_obj$sigma2, ref_obj$sigma2, tolerance = tolerance,\n info = \"sigma2 (residual variance) differs\")\n\n # ELBO and convergence\n expect_equal(dev_obj$elbo, ref_obj$elbo, tolerance = tolerance,\n info = \"ELBO values differ\")\n\n expect_equal(dev_obj$niter, ref_obj$niter,\n info = \"Number of iterations differs\")\n\n expect_equal(dev_obj$converged, ref_obj$converged,\n info = \"Convergence status differs\")\n\n # Fitted values and intercept\n if (!is.null(dev_obj$fitted) && !is.null(ref_obj$fitted)) {\n expect_equal(dev_obj$fitted, ref_obj$fitted, tolerance = tolerance,\n info = \"Fitted values differ\")\n }\n\n expect_equal(dev_obj$intercept, ref_obj$intercept, tolerance = tolerance,\n info = \"Intercept differs\")\n\n # PIPs (if present)\n if (!is.null(dev_obj$pip) && !is.null(ref_obj$pip)) {\n expect_equal(dev_obj$pip, ref_obj$pip, tolerance = tolerance,\n info = \"PIPs differ\")\n }\n\n # Credible sets (if present)\n if (!is.null(dev_obj$sets) && !is.null(ref_obj$sets)) {\n expect_equal(dev_obj$sets$cs, ref_obj$sets$cs,\n info = \"Credible sets differ\")\n if (!is.null(dev_obj$sets$purity) && !is.null(ref_obj$sets$purity)) {\n expect_equal(dev_obj$sets$purity, ref_obj$sets$purity, tolerance = tolerance,\n info = \"CS purity differs\")\n }\n expect_equal(dev_obj$sets$coverage, ref_obj$sets$coverage, tolerance = tolerance,\n info = \"CS coverage differs\")\n }\n\n invisible(TRUE)\n}\n\n# Compare susie_ss objects\nexpect_equal_susie_ss_objects <- function(dev_obj, ref_obj, tolerance = 1e-8) {\n\n # Use the same comparisons as susie objects\n expect_equal_susie_objects(dev_obj, ref_obj, tolerance)\n\n # Additional checks specific to sufficient statistics\n if (!is.null(dev_obj$XtXr) && !is.null(ref_obj$XtXr)) {\n expect_equal(dev_obj$XtXr, ref_obj$XtXr, tolerance = tolerance,\n info = \"XtXr differs\")\n }\n\n invisible(TRUE)\n}\n\n# Compare susie_rss objects\nexpect_equal_susie_rss_objects <- function(dev_obj, ref_obj, tolerance = 1e-8) {\n\n # Use the same comparisons as susie objects\n expect_equal_susie_objects(dev_obj, ref_obj, tolerance)\n\n # Additional checks specific to RSS\n if (!is.null(dev_obj$Rz) && !is.null(ref_obj$Rz)) {\n expect_equal(dev_obj$Rz, ref_obj$Rz, tolerance = tolerance,\n info = \"Rz differs\")\n }\n\n invisible(TRUE)\n}\n" }, { "path": "tests/testthat/helper_testthat.R", "content": "# =============================================================================\n# HELPER FUNCTIONS FOR UNIT TESTS\n# =============================================================================\n#\n# This file provides helper functions for testing the susieR package. These\n# functions are automatically loaded by testthat when running tests.\n#\n# CONTENTS:\n#\n# 1. DATA SIMULATION FUNCTIONS\n# - simulate() : Legacy simulation (sparse/dense matrices)\n# - simulate_tf() : Simulate trend filtering data\n# - simulate_regression() : Simulate linear regression with causal effects\n#\n# 2. DATA SETUP FUNCTIONS (Constructor-based)\n# - setup_individual_data() : Create 'individual' class test data\n# - setup_ss_data() : Create 'ss' class test data\n# - setup_rss_lambda_data() : Create 'rss_lambda' class test data\n#\n# 3. CUSTOM EXPECTATION FUNCTIONS\n# - expect_equal_susie_*() : Compare susie objects (individual/ss/rss)\n# - expect_equal_SER_*() : Compare single effect regression results\n#\n# 4. UTILITY FUNCTIONS\n# - set_X_attributes() : Set standardization attributes on X matrix\n# - compute_summary_stats() : Compute XtX, Xty, yty from X, y\n# - create_sparsity_mat() : Create sparse matrix with given sparsity\n#\n# USAGE NOTES:\n#\n# - All simulation functions use set.seed() internally for reproducibility\n# - Setup functions return list(data, params, model) ready for testing\n# - Custom expectation functions handle tolerance and class-specific fields\n# - For new tests, prefer simulate_regression() over legacy simulate()\n# - Setup functions use actual constructors to ensure correct initialization\n#\n# =============================================================================\n\n# -----------------------------------------------------------------------------\n# UTILITY FUNCTIONS\n# -----------------------------------------------------------------------------\n\n#' Set standardization attributes on matrix X\n#'\n#' Sets three attributes on the input matrix: `scaled:center` (column means),\n#' `scaled:scale` (column standard deviations), and `d` (column sums of\n#' squared standardized values). These attributes are used by SuSiE algorithm\n#' to efficiently handle standardized data.\n#'\n#' @param X An n by p data matrix (dense, sparse, or trend filtering matrix)\n#' @param center Logical; if TRUE, center by column means\n#' @param scale Logical; if TRUE, scale by column standard deviations\n#' @return X with three attributes set: `scaled:center`, `scaled:scale`, and `d`\n#' @keywords internal\n#' @importFrom Matrix rowSums\n#' @importFrom Matrix colMeans\nset_X_attributes <- function(X, center = TRUE, scale = TRUE) {\n \n # if X is a trend filtering matrix\n if (!is.null(attr(X,\"matrix.type\"))) {\n order = attr(X,\"order\")\n n = ncol(X)\n \n # Set three attributes for X.\n attr(X,\"scaled:center\") = compute_tf_cm(order,n)\n attr(X,\"scaled:scale\") = compute_tf_csd(order,n)\n attr(X,\"d\") = compute_tf_d(order,n,attr(X,\"scaled:center\"),\n attr(X,\"scaled:scale\"),scale,center)\n if (!center)\n attr(X,\"scaled:center\") = rep(0,n)\n if (!scale)\n attr(X,\"scaled:scale\") = rep(1,n)\n } else {\n \n # If X is either a dense or sparse ordinary matrix.\n # Get column means.\n cm = colMeans(X,na.rm = TRUE)\n \n # Get column standard deviations.\n csd = compute_colSds(X)\n \n # Set sd = 1 when the column has variance 0.\n csd[csd == 0] = 1\n if (!center)\n cm = rep(0,length = length(cm))\n if (!scale) \n csd = rep(1,length = length(cm))\n\n # Ah, this code is very inefficient because the matrix becomes\n # dense!\n # \n # X.std = as.matrix(X)\n # X.std = (t(X.std) - cm)/csd\n # attr(X,\"d\") = rowSums(X.std * X.std)\n #\n # Set three attributes for X.\n n = nrow(X)\n d = n*colMeans(X)^2 + (n-1)*compute_colSds(X)^2\n d = (d - n*cm^2)/csd^2\n attr(X,\"d\") = d\n attr(X,\"scaled:center\") = cm\n attr(X,\"scaled:scale\") = csd\n }\n return(X)\n}\n\n#' Create sparse matrix with specified sparsity level\n#'\n#' Generates a binary matrix with a specified proportion of non-zero entries.\n#' Used for testing sparse matrix operations.\n#'\n#' @param sparsity Proportion of zero entries (between 0 and 1)\n#' @param n Number of rows\n#' @param p Number of columns\n#' @return Binary matrix with (1-sparsity)*n*p non-zero entries\n#' @keywords internal\ncreate_sparsity_mat <- function(sparsity, n, p) {\n nonzero <- round(n * p * (1 - sparsity))\n nonzero.idx <- sample(n * p, nonzero)\n mat <- numeric(n * p)\n mat[nonzero.idx] <- 1\n mat <- matrix(mat, nrow = n, ncol = p)\n return(mat)\n}\n\n# -----------------------------------------------------------------------------\n# DATA SIMULATION FUNCTIONS\n# -----------------------------------------------------------------------------\n\n#' Simulate trend filtering data\n#'\n#' Generates synthetic data for testing trend filtering functionality.\n#' Creates piecewise constant (order=0), linear (order=1), or quadratic\n#' (order=2) signals with noise.\n#'\n#' @param order Trend filtering order (0, 1, or 2)\n#' @return List with X (trend filtering matrix) and y (response vector)\n#' @keywords internal\nsimulate_tf <- function(order) {\n suppressWarnings(RNGversion(\"3.5.0\"))\n set.seed(2)\n n = 50\n D = diag(-1, n)\n for (i in 1:(n-1)){\n D[i, i+1] = 1\n }\n if (order==0) {\n beta = c(rep(0,5),rep(1,5),rep(3,5),rep(-2,5),rep(0,30))\n y = beta + rnorm(n)\n X = solve(D)\n } else if (order==1) {\n beta = numeric(n)\n for (i in 1:n){\n if (i <= 5){\n beta[i] = 0.001*i + 2\n } else if (i <= 15){\n beta[i] = 5*0.001*i + 1.6\n } else{\n beta[i] = 6.1 - 10*0.001*i\n }\n }\n y = beta + rnorm(n)\n X = solve(D%*%D)\n } else if (order==2) {\n beta = numeric(n)\n for (i in 1:n){\n if (i <= 5){\n beta[i] = (0.001*i)^2\n } else if (i <= 35){\n beta[i] = -5*(0.001*i)^2 + 0.06\n } else{\n beta[i] = 3*(0.001*i)^2 - 3.86\n }\n }\n y = beta + rnorm(n)\n X = solve(D%*%D%*%D)\n }\n return(list(X=X, y=y))\n}\n\n# -----------------------------------------------------------------------------\n# CUSTOM EXPECTATION FUNCTIONS\n# -----------------------------------------------------------------------------\n\nexpect_equal_susie_update = function(new.res, original.res, tolerance = .Machine$double.eps^0.5){\n expect_equal(new.res$alpha, original.res$alpha, scale = 1, tolerance = tolerance)\n expect_equal(new.res$mu, original.res$mu, scale = 1, tolerance = tolerance)\n expect_equal(new.res$mu2, original.res$mu2, scale = 1, tolerance = tolerance)\n expect_equal(new.res$Xr, original.res$Xr, scale = 1, tolerance = tolerance)\n expect_equal(new.res$KL, original.res$KL, scale = 1, tolerance = tolerance)\n expect_equal(new.res$sigma2, original.res$sigma2, scale = 1, tolerance = tolerance)\n expect_equal(new.res$V, original.res$V, scale = 1, tolerance = tolerance)\n}\n\nexpect_equal_susie_suff_stat_update = function(new.res, original.res, tolerance = .Machine$double.eps^0.5){\n expect_equal(new.res$alpha, original.res$alpha, scale = 1, tolerance = tolerance)\n expect_equal(new.res$mu, original.res$mu, scale = 1, tolerance = tolerance)\n expect_equal(new.res$mu2, original.res$mu2, scale = 1, tolerance = tolerance)\n expect_equal(new.res$XtXr, original.res$XtXr, scale = 1, tolerance = tolerance)\n expect_equal(new.res$KL, original.res$KL, scale = 1, tolerance = tolerance)\n expect_equal(new.res$sigma2, original.res$sigma2, scale = 1, tolerance = tolerance)\n expect_equal(new.res$V, original.res$V, scale = 1, tolerance = tolerance)\n}\n\nexpect_equal_susie_rss_update = function(new.res, original.res, tolerance = .Machine$double.eps^0.5){\n expect_equal(new.res$alpha, original.res$alpha, scale = 1, tolerance = tolerance)\n expect_equal(new.res$mu, original.res$mu, scale = 1, tolerance = tolerance)\n expect_equal(new.res$mu2, original.res$mu2, scale = 1, tolerance = tolerance)\n expect_equal(new.res$Rz, original.res$Rz, scale = 1, tolerance = tolerance)\n expect_equal(new.res$KL, original.res$KL, scale = 1, tolerance = tolerance)\n expect_equal(new.res$sigma2, original.res$sigma2, scale = 1, tolerance = tolerance)\n expect_equal(new.res$V, original.res$V, scale = 1, tolerance = tolerance)\n}\n\nexpect_equal_SER = function(new.res, original.res){\n expect_equal(new.res$alpha, original.res$alpha)\n expect_equal(new.res$mu, original.res$mu)\n expect_equal(new.res$mu2, original.res$mu2)\n expect_equal(new.res$lbf, original.res$lbf)\n expect_equal(new.res$V, original.res$V)\n expect_equal(new.res$loglik, original.res$loglik)\n}\n\nexpect_equal_SER_suff_stat = function(new.res, original.res, tolerance = .Machine$double.eps^0.5){\n expect_equal(new.res$alpha, original.res$alpha, scale = 1, tolerance = tolerance)\n expect_equal(new.res$mu, original.res$mu, scale = 1, tolerance = tolerance)\n expect_equal(new.res$mu2, original.res$mu2, scale = 1, tolerance = tolerance)\n expect_equal(new.res$lbf, original.res$lbf, scale = 1, tolerance = tolerance)\n expect_equal(new.res$V, original.res$V, scale = 1, tolerance = tolerance)\n expect_equal(new.res$lbf_model, original.res$lbf_model, scale = 1, tolerance = tolerance)\n}\n\nexpect_equal_susie = function(new.res, original.res, tolerance = .Machine$double.eps^0.5){\n expect_equal_susie_update(new.res, original.res, tolerance = tolerance)\n expect_equal(new.res$elbo, original.res$elbo, scale = 1, tolerance = tolerance)\n expect_equal(new.res$niter, original.res$niter, scale = 1, tolerance = tolerance)\n expect_equal(new.res$intercept, original.res$intercept, scale = 1, tolerance = tolerance)\n expect_equal(new.res$fitted, original.res$fitted, scale = 1, tolerance = tolerance)\n expect_equal(new.res$X_column_scale_factors, original.res$X_column_scale_factors, scale = 1, tolerance = tolerance)\n}\n\nexpect_equal_susie_suff_stat = function(new.res, original.res, tolerance = .Machine$double.eps^0.5){\n expect_equal_susie_suff_stat_update(new.res, original.res, tolerance = tolerance)\n expect_equal(new.res$elbo, original.res$elbo, scale = 1, tolerance = tolerance)\n expect_equal(new.res$niter, original.res$niter, scale = 1, tolerance = tolerance)\n expect_equal(new.res$intercept, original.res$intercept, scale = 1, tolerance = tolerance)\n expect_equal(new.res$Xtfitted, original.res$Xtfitted, scale = 1, tolerance = tolerance)\n}\n\nexpect_equal_susie_rss = function(new.res, original.res, tolerance = .Machine$double.eps^0.5){\n expect_equal_susie_rss_update(new.res, original.res, scale = 1, tolerance = tolerance)\n expect_equal(new.res$elbo, original.res$elbo, scale = 1, tolerance = tolerance)\n expect_equal(new.res$niter, original.res$niter, scale = 1, tolerance = tolerance)\n expect_equal(new.res$intercept, original.res$intercept, scale = 1, tolerance = tolerance)\n expect_equal(new.res$Rz, original.res$Rz, scale = 1, tolerance = tolerance)\n}\n\n#' Unified dispatcher for comparing susie objects\n#'\n#' Automatically detects the type of susie object and calls the appropriate\n#' comparison function. This simplifies test code and ensures correct\n#' comparison based on object structure.\n#'\n#' @param new.res New susie result object\n#' @param original.res Original susie result object to compare against\n#' @param tolerance Numerical tolerance for comparisons (default: sqrt(.Machine$double.eps))\n#'\n#' @details\n#' Detects object type by checking for class-specific fields:\n#' - Individual data: has 'Xr' field\n#' - Sufficient stats: has 'XtXr' field\n#' - RSS/RSS lambda: has 'Rz' field\n#'\n#' @examples\n#' # Automatically handles all susie object types\n#' fit1 <- susie(X, y, L = 5)\n#' fit2 <- susie(X, y, L = 5)\n#' expect_equal_susie_objects(fit1, fit2)\n#'\nexpect_equal_susie_objects <- function(new.res, original.res,\n tolerance = .Machine$double.eps^0.5) {\n # Detect type based on class-specific fields\n if (!is.null(new.res$Xr) && !is.null(original.res$Xr)) {\n # Individual data (has Xr)\n expect_equal_susie(new.res, original.res, tolerance = tolerance)\n } else if (!is.null(new.res$XtXr) && !is.null(original.res$XtXr)) {\n # Sufficient stats (has XtXr)\n expect_equal_susie_suff_stat(new.res, original.res, tolerance = tolerance)\n } else if (!is.null(new.res$Rz) && !is.null(original.res$Rz)) {\n # RSS or RSS lambda (has Rz)\n expect_equal_susie_rss(new.res, original.res, tolerance = tolerance)\n } else {\n stop(\"Cannot determine susie object type. Unknown structure.\")\n }\n}\n\n#' Unified dispatcher for comparing SER results\n#'\n#' Automatically detects the type of single effect regression result and calls\n#' the appropriate comparison function.\n#'\n#' @param new.res New SER result object\n#' @param original.res Original SER result object to compare against\n#' @param tolerance Numerical tolerance for comparisons (default: sqrt(.Machine$double.eps))\n#'\n#' @details\n#' Detects result type by checking for 'lbf_model' field (sufficient stats only)\n#'\nexpect_equal_SER_objects <- function(new.res, original.res,\n tolerance = .Machine$double.eps^0.5) {\n # Detect type based on presence of lbf_model (sufficient stats specific)\n if (!is.null(new.res$lbf_model) && !is.null(original.res$lbf_model)) {\n # Sufficient stats SER\n expect_equal_SER_suff_stat(new.res, original.res, tolerance = tolerance)\n } else {\n # Individual data SER (default)\n expect_equal_SER(new.res, original.res)\n }\n}\n\n# -----------------------------------------------------------------------------\n# BASE HELPER FUNCTIONS (Internal - reduce duplication)\n# -----------------------------------------------------------------------------\n\n#' Generate base regression data for testing\n#'\n#' Creates random X matrix and y vector for use in test setup functions.\n#' This function encapsulates the common data generation pattern used across\n#' multiple setup functions to reduce code duplication.\n#'\n#' @param n Sample size\n#' @param p Number of variables\n#' @param k Number of causal variables (if 0, generates random y)\n#' @param signal_sd Standard deviation of effect sizes for causal variables\n#' @param seed Random seed (if NULL, no seed is set)\n#' @return List with X, y, and optionally beta and causal_idx\n#' @keywords internal\ngenerate_base_data <- function(n, p, k = 0, signal_sd = 1, seed = NULL) {\n if (!is.null(seed)) set.seed(seed)\n\n X <- matrix(rnorm(n * p), n, p)\n\n if (k > 0) {\n # Generate data with known causal structure\n beta <- rep(0, p)\n causal_idx <- sort(sample(1:p, k))\n beta[causal_idx] <- rnorm(k, mean = 0, sd = signal_sd)\n y <- as.vector(X %*% beta + rnorm(n))\n return(list(X = X, y = y, n = n, p = p, beta = beta, causal_idx = causal_idx))\n } else {\n # Generate random y (no causal structure)\n y <- rnorm(n)\n return(list(X = X, y = y, n = n, p = p))\n }\n}\n\n#' Create base model structure\n#'\n#' Creates the common model list structure used across all data types.\n#' This function encapsulates the shared model initialization pattern.\n#'\n#' @param L Number of single effects\n#' @param p Number of variables\n#' @param n Number of samples (for individual data, adds Xr field)\n#' @param X_attr Optional attributes from X (for predictor_weights)\n#' @return List with alpha, mu, mu2, V, sigma2, pi, lbf, lbf_variable, KL\n#' @keywords internal\ncreate_base_model <- function(L, p, n = NULL, X_attr = NULL) {\n model <- list(\n alpha = matrix(1 / p, L, p),\n mu = matrix(0, L, p),\n mu2 = matrix(0, L, p),\n V = rep(1, L),\n sigma2 = 1,\n pi = rep(1 / p, p),\n lbf = rep(0, L),\n lbf_variable = matrix(0, L, p),\n KL = rep(0, L),\n null_weight = 0\n )\n\n # Add class-specific fields\n if (!is.null(X_attr)) {\n model$predictor_weights <- X_attr\n }\n\n if (!is.null(n)) {\n model$Xr <- rep(0, n) # For individual data\n }\n\n return(model)\n}\n\n#' Create standard parameter list\n#'\n#' Creates the default params list used by setup functions. Provides consistent\n#' defaults that can be overridden by specific setup functions.\n#'\n#' @param L Number of single effects\n#' @param p Number of variables\n#' @param unmappable_effects One of \"none\", \"inf\", or \"ash\"\n#' @param additional_params Named list of additional/override parameters\n#' @return List of parameters for SuSiE fitting\n#' @keywords internal\ncreate_base_params <- function(L, p, unmappable_effects = \"none\",\n additional_params = list()) {\n params <- list(\n L = L,\n intercept = TRUE,\n standardize = TRUE,\n estimate_residual_variance = TRUE,\n estimate_prior_variance = TRUE,\n estimate_prior_method = \"optim\",\n unmappable_effects = unmappable_effects,\n use_NIG = FALSE,\n compute_univariate_zscore = TRUE,\n coverage = 0.95,\n min_abs_corr = 0.5,\n n_purity = 100,\n check_null_threshold = 0.1,\n scaled_prior_variance = 0.2,\n prior_weights = rep(1 / p, p),\n null_weight = 0,\n residual_variance = NULL,\n track_fit = FALSE,\n prior_tol = 1e-9,\n max_iter = 100,\n tol = 1e-3,\n convergence_method = \"elbo\",\n verbose = FALSE,\n refine = FALSE,\n model_init = NULL\n )\n\n # Override with additional params if provided\n if (length(additional_params) > 0) {\n params[names(additional_params)] <- additional_params\n }\n\n return(params)\n}\n\n# -----------------------------------------------------------------------------\n# DATA SETUP FUNCTIONS (Constructor-based)\n# -----------------------------------------------------------------------------\n\n#' Setup individual-level data for testing\n#'\n#' Creates a complete test setup with individual-level data (X, y matrices),\n#' parameters, and an initialized model. This is the primary setup function\n#' for testing individual data methods.\n#'\n#' @param n Sample size\n#' @param p Number of variables\n#' @param L Number of single effects\n#' @param seed Random seed for reproducibility\n#' @return List with data (class: individual), params, and model\n#' @keywords internal\n#' @examples\n#' # Internal use in tests\n#' setup <- setup_individual_data(n = 100, p = 50, L = 5)\n#' fit <- susie(setup$data$X, setup$data$y, L = setup$params$L)\nsetup_individual_data <- function(n = 100, p = 50, L = 5, seed = 42) {\n # Use base helper for data generation\n base_data <- generate_base_data(n, p, k = 0, seed = seed)\n X <- base_data$X\n y <- base_data$y\n\n X <- set_X_attributes(X, center = TRUE, scale = TRUE)\n mean_y <- mean(y)\n y <- y - mean_y\n\n data <- structure(\n list(\n X = X,\n y = y,\n n = n,\n p = p,\n mean_y = mean_y\n ),\n class = \"individual\"\n )\n\n # Use base helper for standard params\n params <- create_base_params(L, p, unmappable_effects = \"none\")\n\n # Use base helper for model, then add individual-specific fields\n model <- create_base_model(L, p, n = n, X_attr = attr(X, \"d\"))\n\n list(data = data, params = params, model = model)\n}\n\n#' Setup sufficient statistics data with unmappable_effects support\n#'\n#' Creates a complete test setup with sufficient statistics (XtX, Xty, yty),\n#' parameters, and an initialized model. Supports unmappable effects testing.\n#'\n#' @param n Number of samples\n#' @param p Number of variables\n#' @param L Number of single effects\n#' @param seed Random seed\n#' @param unmappable_effects One of \"none\" or \"inf\"\n#' @return List with data (class: ss), params, and model\n#' @keywords internal\nsetup_ss_data <- function(n = 100, p = 50, L = 5, seed = 42,\n unmappable_effects = \"none\") {\n # Use base helper for data generation\n base_data <- generate_base_data(n, p, k = 0, seed = seed)\n X <- base_data$X\n y <- base_data$y\n\n # Center and scale X like the constructor does\n X_colmeans <- colMeans(X)\n X <- sweep(X, 2, X_colmeans)\n y_mean <- mean(y)\n y <- y - y_mean\n\n # Compute sufficient statistics\n XtX <- crossprod(X)\n Xty <- as.vector(crossprod(X, y))\n yty <- sum(y^2)\n\n # Use the actual constructor like susie_ss does\n # This ensures proper setup including eigen decomposition for unmappable effects\n susie_objects <- sufficient_stats_constructor(\n XtX = XtX,\n Xty = Xty,\n yty = yty,\n n = n,\n L = L,\n X_colmeans = X_colmeans,\n y_mean = y_mean,\n standardize = TRUE,\n unmappable_effects = unmappable_effects,\n residual_variance = 1, # Set initial residual variance\n estimate_residual_method = if (unmappable_effects != \"none\") \"MoM\" else \"MLE\",\n convergence_method = if (unmappable_effects != \"none\") \"pip\" else \"elbo\",\n coverage = 0.95,\n min_abs_corr = 0.5,\n n_purity = 100,\n check_prior = FALSE,\n track_fit = FALSE\n )\n\n data <- susie_objects$data\n params <- susie_objects$params\n\n # Use base helper for model, add ss-specific fields\n model <- create_base_model(L, data$p, n = NULL, X_attr = attr(data$XtX, \"d\"))\n model$XtXr <- rep(0, data$p) # ss-specific field\n\n # Add unmappable components if needed\n if (unmappable_effects == \"inf\") {\n model$tau2 <- 0\n model$theta <- rep(0, data$p)\n }\n\n list(data = data, params = params, model = model)\n}\n\n#' Setup RSS lambda test data\n#'\n#' Creates a complete test setup for RSS with correlated residuals (lambda > 0).\n#' Generates data with known causal structure, computes z-scores and correlation\n#' matrix, and initializes model using the rss_lambda constructor.\n#'\n#' @param n Number of samples\n#' @param p Number of variables\n#' @param k Number of causal variables\n#' @param lambda Lambda parameter (residual correlation, between 0 and 1)\n#' @param signal_sd Standard deviation of causal effects\n#' @param seed Random seed\n#' @param L Number of single effects\n#' @return List with X, y, beta, causal_idx, z, R, n, p, k, lambda, data, params, model\n#' @keywords internal\nsetup_rss_lambda_data <- function(n = 500, p = 50, k = 3, lambda = 0.5,\n signal_sd = 0.5, seed = NULL, L = 5) {\n # Use base helper for data generation with causal structure\n base_data <- generate_base_data(n, p, k = k, signal_sd = signal_sd, seed = seed)\n X <- base_data$X\n y <- base_data$y\n beta <- base_data$beta\n causal_idx <- base_data$causal_idx\n\n # Compute sufficient statistics and z-scores\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Build data and params using constructor\n constructor_result <- rss_lambda_constructor(z = z, R = R, lambda = lambda, n = n, L = L)\n\n # Initialize model properly\n var_y <- get_var_y.rss_lambda(constructor_result$data)\n model <- initialize_susie_model.rss_lambda(constructor_result$data, constructor_result$params, var_y)\n\n list(\n X = X,\n y = y,\n beta = beta,\n causal_idx = causal_idx,\n z = z,\n R = R,\n n = n,\n p = p,\n k = k,\n lambda = lambda,\n data = constructor_result$data,\n params = constructor_result$params,\n model = model\n )\n}\n\n# -----------------------------------------------------------------------------\n# ADDITIONAL SIMULATION FUNCTIONS\n# -----------------------------------------------------------------------------\n\n#' Simulate simple regression data with known causal variables\n#'\n#' @param n Sample size\n#' @param p Number of variables\n#' @param k Number of causal variables\n#' @param signal_sd Standard deviation of effect sizes\n#' @param noise_sd Standard deviation of noise\n#' @param center Whether to center X and y\n#' @param scale Whether to scale X to unit variance\n#' @return List with X, y, beta, causal_idx\nsimulate_regression <- function(n = 100, p = 50, k = 3,\n signal_sd = 1, noise_sd = 1,\n center = TRUE, scale = TRUE) {\n # Generate independent X\n X <- matrix(rnorm(n * p), n, p)\n\n # Optionally standardize X\n if (center || scale) {\n X <- scale(X, center = center, scale = scale)\n }\n\n # Generate causal effects\n beta <- rep(0, p)\n causal_idx <- sort(sample(1:p, k))\n beta[causal_idx] <- rnorm(k, mean = 0, sd = signal_sd)\n\n # Generate y\n y <- drop(X %*% beta + rnorm(n, sd = noise_sd))\n\n # Optionally center y\n if (center) {\n y <- y - mean(y)\n }\n\n list(\n X = X,\n y = y,\n beta = beta,\n causal_idx = causal_idx,\n n = n,\n p = p,\n k = k\n )\n}\n\n#' Compute summary statistics (XtX, Xty, yty) from X and y\n#'\n#' @param X n x p matrix\n#' @param y n vector\n#' @return List with XtX, Xty, yty, n\ncompute_summary_stats <- function(X, y) {\n list(\n XtX = crossprod(X),\n Xty = drop(crossprod(X, y)),\n yty = sum(y^2),\n n = length(y)\n )\n}\n\n#' Create model with credible sets for refinement testing\n#'\n#' Generates synthetic data with known causal structure, fits SuSiE model,\n#' and returns both the model and the data/params objects needed for\n#' refinement testing. Used primarily by test_refinement.R.\n#'\n#' @param n Sample size\n#' @param p Number of variables\n#' @param L Number of single effects\n#' @param n_causal Number of causal variables to simulate\n#' @param seed Random seed for reproducibility\n#' @param run_susie Logical; if TRUE, runs susie and returns model, otherwise just returns data\n#' @return List with model, data, params, X, y, beta, causal_idx\n#' @keywords internal\ncreate_model_with_cs <- function(n = 100, p = 50, L = 5, n_causal = 3,\n seed = 42, run_susie = TRUE) {\n set.seed(seed)\n\n X <- matrix(rnorm(n * p), n, p)\n X <- scale(X, center = TRUE, scale = TRUE)\n\n beta <- rep(0, p)\n causal_idx <- sample(1:p, n_causal)\n beta[causal_idx] <- rnorm(n_causal, sd = 1)\n\n y <- as.vector(X %*% beta + rnorm(n, sd = 0.5))\n\n if (run_susie) {\n model <- susie(X, y, L = L, verbose = FALSE)\n\n constructor_result <- individual_data_constructor(\n X = X, y = y, L = L,\n standardize = TRUE, intercept = TRUE,\n estimate_residual_method = \"MLE\",\n convergence_method = \"elbo\",\n coverage = 0.95, min_abs_corr = 0.5,\n n_purity = 100,\n track_fit = FALSE\n )\n\n return(list(\n model = model,\n data = constructor_result$data,\n params = constructor_result$params,\n X = X,\n y = y,\n beta = beta,\n causal_idx = causal_idx\n ))\n } else {\n return(list(\n X = X,\n y = y,\n beta = beta,\n causal_idx = causal_idx\n ))\n }\n}\n" }, { "path": "tests/testthat/reference/test_susie_auto_reference.R", "content": "# Source helper functions\nsource(file.path(\"..\", \"helper_reference.R\"), local = TRUE)\n\ncontext(\"susie_auto reference comparison\")\n\n# =============================================================================\n# REFERENCE TESTS FOR susie_auto()\n# =============================================================================\n#\n# These tests compare the new susieR implementation against the reference\n# package (stephenslab/susieR@1f9166c) to ensure results are identical.\n#\n# =============================================================================\n# Part 1: Basic Tests with Default Parameters\n# =============================================================================\n\ntest_that(\"susie_auto() matches reference with default parameters\", {\n skip_if_no_reference()\n\n set.seed(1)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_auto() matches reference with L_init=2\", {\n skip_if_no_reference()\n\n set.seed(2)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L_init = 2)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_auto() matches reference with L_init=5, L_max=10\", {\n skip_if_no_reference()\n\n set.seed(3)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:3] <- c(2, -1.5, 1)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L_init = 5, L_max = 10)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 2: standardize Parameter\n# =============================================================================\n\ntest_that(\"susie_auto() matches reference with standardize=FALSE\", {\n skip_if_no_reference()\n\n set.seed(4)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, standardize = FALSE)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_auto() matches reference with standardize=TRUE\", {\n skip_if_no_reference()\n\n set.seed(5)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, standardize = TRUE)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 3: intercept Parameter\n# =============================================================================\n\ntest_that(\"susie_auto() matches reference with intercept=FALSE\", {\n skip_if_no_reference()\n\n set.seed(6)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, intercept = FALSE)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_auto() matches reference with intercept=TRUE\", {\n skip_if_no_reference()\n\n set.seed(7)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, intercept = TRUE)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 4: Tolerance Parameters\n# =============================================================================\n\ntest_that(\"susie_auto() matches reference with init_tol=0.1\", {\n skip_if_no_reference()\n\n set.seed(8)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, init_tol = 0.1)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_auto() matches reference with tol=1e-3\", {\n skip_if_no_reference()\n\n set.seed(9)\n n <- 100\n p <- 1000\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, tol = 1e-3)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 5: max_iter Parameter\n# =============================================================================\n\ntest_that(\"susie_auto() matches reference with max_iter=50\", {\n skip_if_no_reference()\n\n set.seed(10)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, max_iter = 50)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_auto() matches reference with max_iter=200\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, max_iter = 200)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 6: Combined Parameter Tests\n# =============================================================================\n\ntest_that(\"susie_auto() matches reference with standardize=FALSE, intercept=FALSE\", {\n skip_if_no_reference()\n\n set.seed(12)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, standardize = FALSE, intercept = FALSE)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_auto() matches reference with L_init=2, L_max=8, init_tol=0.5\", {\n skip_if_no_reference()\n\n set.seed(13)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L_init = 2, L_max = 8, init_tol = 0.5)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 7: Edge Cases\n# =============================================================================\n\ntest_that(\"susie_auto() matches reference with sparse signal\", {\n skip_if_no_reference()\n\n set.seed(14)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[5] <- 3 # Only one effect\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_auto() matches reference with dense signal\", {\n skip_if_no_reference()\n\n set.seed(15)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:10] <- rnorm(10) # Ten effects\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L_init = 5, L_max = 20)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_auto() matches reference with high noise\", {\n skip_if_no_reference()\n\n set.seed(16)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n, sd = 3)) # High noise\n\n args <- list(X = X, y = y)\n compare_to_reference(\"susie_auto\", args, tolerance = 1e-5)\n})\n" }, { "path": "tests/testthat/reference/test_susie_nig_reference.R", "content": "# Source helper functions for NIG reference comparison\nsource(file.path(\"..\", \"helper_nig_reference.R\"), local = TRUE)\n\ncontext(\"susie NIG reference comparison\")\n\n# =============================================================================\n# REFERENCE TESTS FOR susie(estimate_residual_method = \"NIG\")\n# =============================================================================\n#\n# These tests compare our implementation of the NIG\n# prior, invoked via estimate_residual_method = \"NIG\",\n# against the reference implementation on the fix-susie-small-sigma-update\n# branch of stephenslab/susieR (commit a999d44), where the equivalent\n# feature is invoked via small = TRUE.\n#\n# Parameter mapping between the two interfaces:\n# Dev: estimate_residual_method = \"NIG\" <-> Ref: small = TRUE\n# Dev: tol (convergence tolerance) <-> Ref: tol_small\n# Dev: convergence_method = \"pip\" (auto-set) <-> Ref: (hard-coded PIP convergence)\n# Dev: estimate_prior_method = \"EM\" (auto-set) <-> Ref: (forced to EM)\n# Dev: alpha0, beta0 <-> Ref: alpha0, beta0\n#\n# The helper function compare_NIG_to_reference() handles\n# this mapping automatically.\n\n# =============================================================================\n# Part 1: Default parameters (baseline match)\n# =============================================================================\n\ntest_that(\"NIG matches reference (small=TRUE) with defaults\", {\n skip_if_no_nig_reference()\n\n set.seed(1)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Dev: estimate_residual_method = \"NIG\" (set by helper)\n # Ref: small = TRUE (mapped by helper)\n # Reference defaults to alpha0 = beta0 = 0.1; dev's current default is\n # 1/sqrt(n). The helper forces 0.1 on the dev side when the caller\n # doesn't set these, so both runs use the same NIG hyperparameters.\n dev_args <- list(X = X, y = y, L = 10)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 2: L = 1 (single effect — ELBO is well-defined)\n# =============================================================================\n\ntest_that(\"NIG matches reference with L = 1\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n skip_if_no_nig_reference()\n\n set.seed(2)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[3] <- 3\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 1)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 3: standardize = FALSE\n# =============================================================================\n\ntest_that(\"NIG matches reference with standardize=FALSE\", {\n skip_if_no_nig_reference()\n\n set.seed(3)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10, standardize = FALSE)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 4: intercept = FALSE\n# =============================================================================\n\ntest_that(\"NIG matches reference with intercept=FALSE\", {\n skip_if_no_nig_reference()\n\n set.seed(4)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10, intercept = FALSE)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 5: Custom alpha0 and beta0\n# =============================================================================\n\ntest_that(\"NIG matches reference with custom alpha0/beta0\", {\n skip_if_no_nig_reference()\n\n set.seed(5)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10, alpha0 = 1.0, beta0 = 1.0)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\ntest_that(\"NIG matches reference with small alpha0/beta0\", {\n skip_if_no_nig_reference()\n\n set.seed(6)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10, alpha0 = 0.01, beta0 = 0.01)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 6: estimate_prior_variance = FALSE\n# =============================================================================\n\ntest_that(\"NIG matches reference with estimate_prior_variance=FALSE\", {\n skip_if_no_nig_reference()\n\n set.seed(7)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10, estimate_prior_variance = FALSE)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 7: Explicit convergence tolerance\n# =============================================================================\n\ntest_that(\"NIG matches reference with tol = 1e-4\", {\n skip_if_no_nig_reference()\n\n set.seed(8)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Dev uses tol; helper maps it to tol_small for reference\n dev_args <- list(X = X, y = y, L = 10, tol = 1e-4)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 8: max_iter boundary\n# =============================================================================\n\ntest_that(\"NIG matches reference with small max_iter\", {\n skip_if_no_nig_reference()\n\n set.seed(9)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Force early termination to test partial convergence path\n dev_args <- list(X = X, y = y, L = 10, max_iter = 5)\n results <- suppressWarnings(\n compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n )\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 9: Sparse signal (most effects zero)\n# =============================================================================\n\ntest_that(\"NIG matches reference with very sparse signal\", {\n skip_if_no_nig_reference()\n\n set.seed(10)\n n <- 100\n p <- 200\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1] <- 5 # single strong effect\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 5)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 10: Small sample size (n < 80, the regime NIG targets)\n# =============================================================================\n\ntest_that(\"NIG matches reference with small n\", {\n skip_if_no_nig_reference()\n\n set.seed(11)\n n <- 30\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:2] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 5)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 11: High noise (large residual variance)\n# =============================================================================\n\ntest_that(\"NIG matches reference with high noise\", {\n skip_if_no_nig_reference()\n\n set.seed(12)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n, sd = 10)) # high noise\n\n dev_args <- list(X = X, y = y, L = 10)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 12: Combined — standardize=FALSE, intercept=FALSE\n# =============================================================================\n\ntest_that(\"NIG matches reference with standardize=FALSE, intercept=FALSE\", {\n skip_if_no_nig_reference()\n\n set.seed(13)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10, standardize = FALSE, intercept = FALSE)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 13: Combined — custom alpha0/beta0 with standardize=FALSE\n# =============================================================================\n\ntest_that(\"NIG matches reference with custom priors and standardize=FALSE\", {\n skip_if_no_nig_reference()\n\n set.seed(14)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(\n X = X, y = y, L = 10,\n standardize = FALSE,\n alpha0 = 0.5,\n beta0 = 0.5\n )\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 14: Null signal (no true effects)\n# =============================================================================\n\ntest_that(\"NIG matches reference under null signal\", {\n skip_if_no_nig_reference()\n\n set.seed(15)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n) # pure noise\n\n dev_args <- list(X = X, y = y, L = 5)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 15: L = 1 with standardize = FALSE (ELBO well-defined, no scaling)\n# =============================================================================\n\ntest_that(\"NIG matches reference with L=1, standardize=FALSE\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n skip_if_no_nig_reference()\n\n set.seed(16)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[5] <- 4\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 1, standardize = FALSE)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 16: Small n with intercept = FALSE\n# =============================================================================\n\ntest_that(\"NIG matches reference with small n and intercept=FALSE\", {\n skip_if_no_nig_reference()\n\n set.seed(17)\n n <- 20\n p <- 30\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1] <- 5\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 3, intercept = FALSE)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 17: Diagnostic — field-by-field summary of discrepancies\n# =============================================================================\n#\n# This test does NOT use expect_equal; instead it generates a summary of\n# all numeric differences between dev and reference outputs. Useful for\n# diagnosing regressions without hard-failing CI.\n\ntest_that(\"NIG field-by-field difference summary\", {\n skip_if_no_nig_reference()\n\n set.seed(100)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n dev <- results$dev\n ref <- results$ref\n\n # Collect per-field max absolute differences\n fields <- c(\"alpha\", \"mu\", \"mu2\", \"V\", \"sigma2\", \"intercept\",\n \"fitted\", \"pip\")\n\n diffs <- vapply(fields, function(f) {\n d <- dev[[f]]\n r <- ref[[f]]\n if (is.null(d) || is.null(r)) return(NA_real_)\n max(abs(d - r), na.rm = TRUE)\n }, numeric(1))\n\n # Print a summary table\n message(\"\\n--- NIG vs reference: max |dev - ref| per field ---\")\n for (f in names(diffs)) {\n message(sprintf(\" %-12s: %s\", f, format(diffs[f], digits = 8)))\n }\n\n # Convergence & iteration metadata\n message(sprintf(\" niter (dev/ref): %d / %d\", dev$niter, ref$niter))\n message(sprintf(\" converged (dev/ref): %s / %s\", dev$converged, ref$converged))\n\n # Credible sets match\n if (!is.null(dev$sets$cs) && !is.null(ref$sets$cs)) {\n cs_match <- identical(dev$sets$cs, ref$sets$cs)\n message(sprintf(\" CS sets identical: %s\", cs_match))\n }\n\n # Hard assertion: all differences should be < tolerance\n expect_true(all(diffs[!is.na(diffs)] < 1e-5),\n info = paste(\"Some fields exceed tolerance:\",\n paste(names(which(diffs >= 1e-5)),\n collapse = \", \")))\n})\n\n# #############################################################################\n# EXPANDED EDGE-CASE TEST SUITE\n# #############################################################################\n\n# =============================================================================\n# Category A: Data dimensions\n# =============================================================================\n\n# Part 18: n >> p (overdetermined)\ntest_that(\"NIG matches reference with n >> p (overdetermined)\", {\n skip_if_no_nig_reference()\n\n set.seed(101)\n n <- 500\n p <- 20\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:3] <- c(2, -1.5, 3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 5)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 19: n << p (underdetermined, genetics regime)\ntest_that(\"NIG matches reference with n << p (underdetermined)\", {\n skip_if_no_nig_reference()\n\n set.seed(102)\n n <- 30\n p <- 200\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 50)] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 5)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 20: n = p (square)\ntest_that(\"NIG matches reference with n = p (square)\", {\n skip_if_no_nig_reference()\n\n set.seed(103)\n n <- 50\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:3] <- c(2, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 5)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 21: Very small n\ntest_that(\"NIG matches reference with very small n\", {\n skip_if_no_nig_reference()\n\n set.seed(104)\n n <- 10\n p <- 30\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1] <- 3\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 3)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Category B: Signal patterns\n# =============================================================================\n\n# Part 22: Weak signals (low SNR)\ntest_that(\"NIG matches reference with weak signals\", {\n skip_if_no_nig_reference()\n\n set.seed(105)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:3] <- c(0.3, -0.3, 0.2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 5)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 23: Very strong signals\ntest_that(\"NIG matches reference with very strong signals\", {\n skip_if_no_nig_reference()\n\n set.seed(106)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:3] <- c(10, -15, 20)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 5)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 24: Mixed strength signals\ntest_that(\"NIG matches reference with mixed strength signals\", {\n skip_if_no_nig_reference()\n\n set.seed(107)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(10, 0.5, -10, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 25: Many true effects\ntest_that(\"NIG matches reference with many true effects\", {\n skip_if_no_nig_reference()\n\n set.seed(108)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:10] <- c(2, -1.5, 3, -2, 1, -1, 2.5, -0.8, 1.2, -1.8)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Category C: L values\n# =============================================================================\n\n# Part 26: L = 2 (minimal multi-effect)\ntest_that(\"NIG matches reference with L = 2\", {\n skip_if_no_nig_reference()\n\n set.seed(109)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:2] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 2)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 27: L = 20 (more effects than default)\ntest_that(\"NIG matches reference with L = 20\", {\n skip_if_no_nig_reference()\n\n set.seed(110)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 20)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 28: L >> true effects (over-specified)\ntest_that(\"NIG matches reference with L >> true effects\", {\n skip_if_no_nig_reference()\n\n set.seed(111)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:2] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 15)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 29: L < true effects (under-specified)\ntest_that(\"NIG matches reference with L < true effects\", {\n skip_if_no_nig_reference()\n\n set.seed(112)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:5] <- c(3, -2, 4, -1.5, 2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 2)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Category D: Prior parameters alpha0/beta0\n# =============================================================================\n\n# Part 30: Informative priors\ntest_that(\"NIG matches reference with informative alpha0/beta0\", {\n skip_if_no_nig_reference()\n\n set.seed(113)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10, alpha0 = 10, beta0 = 10)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 31: Very diffuse priors\ntest_that(\"NIG matches reference with very diffuse alpha0/beta0\", {\n skip_if_no_nig_reference()\n\n set.seed(114)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10, alpha0 = 0.001, beta0 = 0.001)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 32: Asymmetric priors\ntest_that(\"NIG matches reference with asymmetric alpha0/beta0\", {\n skip_if_no_nig_reference()\n\n set.seed(115)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10, alpha0 = 0.1, beta0 = 1.0)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Category E: Predictor structure\n# =============================================================================\n\n# Part 33: AR(1) correlated predictors\ntest_that(\"NIG matches reference with AR(1) correlated X\", {\n skip_if_no_nig_reference()\n\n set.seed(116)\n n <- 100\n p <- 50\n rho <- 0.8\n\n # Generate AR(1) correlation structure\n Z <- matrix(rnorm(n * p), n, p)\n X <- Z\n for (j in 2:p) {\n X[, j] <- rho * X[, j - 1] + sqrt(1 - rho^2) * Z[, j]\n }\n\n beta <- rep(0, p)\n beta[c(1, 25)] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 5)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 34: Block-correlated predictors\ntest_that(\"NIG matches reference with block-correlated X\", {\n skip_if_no_nig_reference()\n\n set.seed(117)\n n <- 100\n p <- 50\n block_size <- 5\n n_blocks <- p / block_size\n\n # Generate block correlation structure\n X <- matrix(0, n, p)\n for (b in seq_len(n_blocks)) {\n cols <- ((b - 1) * block_size + 1):(b * block_size)\n common <- rnorm(n)\n for (j in cols) {\n X[, j] <- 0.8 * common + 0.6 * rnorm(n)\n }\n }\n\n beta <- rep(0, p)\n beta[c(1, 26)] <- c(3, -2) # one in first block, one in sixth block\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 5)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 35: Near-collinear predictors\ntest_that(\"NIG matches reference with near-collinear predictors\", {\n skip_if_no_nig_reference()\n\n set.seed(118)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n\n # Make columns 2 nearly identical to column 1 (r ~ 0.99)\n X[, 2] <- X[, 1] + rnorm(n, sd = 0.1)\n\n beta <- rep(0, p)\n beta[c(1, 2)] <- c(2, -1.5) # both collinear predictors active\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 5)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Category F: Convergence settings\n# =============================================================================\n\n# Part 36: max_iter = 1 (single iteration snapshot)\ntest_that(\"NIG matches reference with max_iter = 1\", {\n skip_if_no_nig_reference()\n\n set.seed(119)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10, max_iter = 1)\n results <- suppressWarnings(\n compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n )\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 37: max_iter = 2 (minimal convergence path)\ntest_that(\"NIG matches reference with max_iter = 2\", {\n skip_if_no_nig_reference()\n\n set.seed(120)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10, max_iter = 2)\n results <- suppressWarnings(\n compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n )\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 38: Tight convergence tolerance\ntest_that(\"NIG matches reference with tight tol = 1e-6\", {\n skip_if_no_nig_reference()\n\n set.seed(121)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10, tol = 1e-6)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Category G: null_weight and prior_weights\n# =============================================================================\n\n# Part 39: null_weight = 0.5 (strong null prior)\ntest_that(\"NIG matches reference with null_weight = 0.5\", {\n skip(\"null_weight + NIG triggers NA in loglik (dev-side bug)\")\n skip_if_no_nig_reference()\n\n set.seed(122)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10, null_weight = 0.5)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 40: Non-uniform prior_weights\ntest_that(\"NIG matches reference with non-uniform prior_weights\", {\n skip_if_no_nig_reference()\n\n set.seed(123)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Favor first 10 predictors\n pw <- rep(1, p)\n pw[1:10] <- 5\n pw <- pw / sum(pw)\n\n dev_args <- list(X = X, y = y, L = 10, prior_weights = pw)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Category H: Parameter combinations\n# =============================================================================\n\n# Part 41: Small n + weak signal\ntest_that(\"NIG matches reference with small n + weak signal\", {\n skip_if_no_nig_reference()\n\n set.seed(124)\n n <- 20\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:2] <- c(0.5, -0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 5)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 42: n << p + L large\ntest_that(\"NIG matches reference with n << p and large L\", {\n skip_if_no_nig_reference()\n\n set.seed(125)\n n <- 30\n p <- 200\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(10, 50, 100)] <- c(3, -2, 4)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 10)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 43: intercept=FALSE + small n\ntest_that(\"NIG matches reference with intercept=FALSE + small n\", {\n skip_if_no_nig_reference()\n\n set.seed(126)\n n <- 25\n p <- 40\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:3] <- c(2, -1.5, 3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 5, intercept = FALSE)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 44: standardize=FALSE + custom alpha0/beta0\ntest_that(\"NIG matches reference with standardize=FALSE + custom priors\", {\n skip_if_no_nig_reference()\n\n set.seed(127)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(\n X = X, y = y, L = 10,\n standardize = FALSE,\n alpha0 = 1.0, beta0 = 0.5\n )\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 45: estimate_prior_variance=FALSE + intercept=FALSE\ntest_that(\"NIG matches reference with estimate_prior_variance=FALSE + intercept=FALSE\", {\n skip_if_no_nig_reference()\n\n set.seed(128)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(\n X = X, y = y, L = 10,\n estimate_prior_variance = FALSE,\n intercept = FALSE\n )\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Category I: L = 1 variants\n# =============================================================================\n\n# Part 46: L=1 + high noise\ntest_that(\"NIG matches reference with L=1 + high noise\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n skip_if_no_nig_reference()\n\n set.seed(129)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1] <- 3\n y <- as.vector(X %*% beta + rnorm(n, sd = 10))\n\n dev_args <- list(X = X, y = y, L = 1)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 47: L=1 + very small n\ntest_that(\"NIG matches reference with L=1 + very small n\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n skip_if_no_nig_reference()\n\n set.seed(130)\n n <- 15\n p <- 30\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1] <- 4\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_args <- list(X = X, y = y, L = 1)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# Part 48: L=1 + null signal (no true effect)\ntest_that(\"NIG matches reference with L=1 + null signal\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n skip_if_no_nig_reference()\n\n set.seed(131)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n) # pure noise\n\n dev_args <- list(X = X, y = y, L = 1)\n results <- compare_NIG_to_reference(dev_args, tolerance = 1e-5)\n\n expect_equal_NIG_objects(results$dev, results$ref, tolerance = 1e-5)\n})\n\n# #############################################################################\n# SUFFICIENT STATISTICS VS INDIVIDUAL-LEVEL DATA COMPARISON\n# #############################################################################\n#\n# For each reference test scenario above, verify that susie_ss()\n# produces the same result as susie() with NIG.\n# These tests do NOT require the reference package.\n\n# =============================================================================\n# SS Part 1: Default parameters (baseline match)\n# =============================================================================\n\ntest_that(\"SS matches individual: defaults (Part 1)\", {\n set.seed(1)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 10))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 2: L = 1 (skipped — convergence method differs)\n# =============================================================================\n\ntest_that(\"SS matches individual: L = 1 (Part 2)\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n\n set.seed(2)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[3] <- 3\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 1))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 3: standardize = FALSE\n# =============================================================================\n\ntest_that(\"SS matches individual: standardize=FALSE (Part 3)\", {\n set.seed(3)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, standardize = FALSE))\n expect_ss_matches_individual_ss(res)\n})\n\n\n# =============================================================================\n# SS Part 4: Custom alpha0 and beta0\n# =============================================================================\n\ntest_that(\"SS matches individual: custom alpha0/beta0 (Part 4)\", {\n set.seed(5)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, alpha0 = 1.0, beta0 = 1.0))\n expect_ss_matches_individual_ss(res)\n})\n\ntest_that(\"SS matches individual: small alpha0/beta0 (Part 5)\", {\n set.seed(6)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, alpha0 = 0.01, beta0 = 0.01))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 6: estimate_prior_variance = FALSE\n# =============================================================================\n\ntest_that(\"SS matches individual: estimate_prior_variance=FALSE (Part 6)\", {\n set.seed(7)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, estimate_prior_variance = FALSE))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 7: Explicit convergence tolerance\n# =============================================================================\n\ntest_that(\"SS matches individual: tol = 1e-4 (Part 7)\", {\n set.seed(8)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, tol = 1e-4))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 8: max_iter boundary\n# =============================================================================\n\ntest_that(\"SS matches individual: small max_iter (Part 8)\", {\n set.seed(9)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, max_iter = 5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 9: Sparse signal\n# =============================================================================\n\ntest_that(\"SS matches individual: very sparse signal (Part 9)\", {\n set.seed(10)\n n <- 100; p <- 200\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1] <- 5\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 10: Small sample size\n# =============================================================================\n\ntest_that(\"SS matches individual: small n (Part 10)\", {\n set.seed(11)\n n <- 30; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:2] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 11: High noise\n# =============================================================================\n\ntest_that(\"SS matches individual: high noise (Part 11)\", {\n set.seed(12)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n, sd = 10))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 10))\n expect_ss_matches_individual_ss(res)\n})\n\n\n# =============================================================================\n# SS Part 12: Custom alpha0/beta0 with standardize=FALSE\n# =============================================================================\n\ntest_that(\"SS matches individual: custom priors + standardize=FALSE (Part 12)\", {\n set.seed(14)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, standardize = FALSE, alpha0 = 0.5, beta0 = 0.5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 13: Null signal\n# =============================================================================\n\ntest_that(\"SS matches individual: null signal (Part 13)\", {\n set.seed(15)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 14: L=1 with standardize=FALSE (skipped)\n# =============================================================================\n\ntest_that(\"SS matches individual: L=1, standardize=FALSE (Part 14)\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n\n set.seed(16)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[5] <- 4\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 1, standardize = FALSE))\n expect_ss_matches_individual_ss(res)\n})\n\n\n# =============================================================================\n# SS Part 15: n >> p (overdetermined)\n# =============================================================================\n\ntest_that(\"SS matches individual: n >> p (Part 15)\", {\n set.seed(101)\n n <- 500; p <- 20\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:3] <- c(2, -1.5, 3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 16: n << p (underdetermined)\n# =============================================================================\n\ntest_that(\"SS matches individual: n << p (Part 16)\", {\n set.seed(102)\n n <- 30; p <- 200\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[c(5, 50)] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 17: n = p (square)\n# =============================================================================\n\ntest_that(\"SS matches individual: n = p (Part 17)\", {\n set.seed(103)\n n <- 50; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:3] <- c(2, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 18: Very small n\n# =============================================================================\n\ntest_that(\"SS matches individual: very small n (Part 18)\", {\n set.seed(104)\n n <- 10; p <- 30\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1] <- 3\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 3))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 19: Weak signals\n# =============================================================================\n\ntest_that(\"SS matches individual: weak signals (Part 19)\", {\n set.seed(105)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:3] <- c(0.3, -0.3, 0.2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 20: Very strong signals\n# =============================================================================\n\ntest_that(\"SS matches individual: very strong signals (Part 20)\", {\n set.seed(106)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:3] <- c(10, -15, 20)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 21: Mixed strength signals\n# =============================================================================\n\ntest_that(\"SS matches individual: mixed strength signals (Part 21)\", {\n set.seed(107)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(10, 0.5, -10, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 10))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 22: Many true effects\n# =============================================================================\n\ntest_that(\"SS matches individual: many true effects (Part 22)\", {\n set.seed(108)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:10] <- c(2, -1.5, 3, -2, 1, -1, 2.5, -0.8, 1.2, -1.8)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 10))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 23: L = 2\n# =============================================================================\n\ntest_that(\"SS matches individual: L = 2 (Part 23)\", {\n set.seed(109)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:2] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 2))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 24: L = 20\n# =============================================================================\n\ntest_that(\"SS matches individual: L = 20 (Part 24)\", {\n set.seed(110)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 20))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 25: L >> true effects\n# =============================================================================\n\ntest_that(\"SS matches individual: L >> true effects (Part 25)\", {\n set.seed(111)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:2] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 15))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 26: L < true effects\n# =============================================================================\n\ntest_that(\"SS matches individual: L < true effects (Part 26)\", {\n set.seed(112)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:5] <- c(3, -2, 4, -1.5, 2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 2))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 27: Informative alpha0/beta0\n# =============================================================================\n\ntest_that(\"SS matches individual: informative alpha0/beta0 (Part 27)\", {\n set.seed(113)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, alpha0 = 10, beta0 = 10))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 28: Very diffuse alpha0/beta0\n# =============================================================================\n\ntest_that(\"SS matches individual: very diffuse alpha0/beta0 (Part 28)\", {\n set.seed(114)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, alpha0 = 0.001, beta0 = 0.001))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 29: Asymmetric alpha0/beta0\n# =============================================================================\n\ntest_that(\"SS matches individual: asymmetric alpha0/beta0 (Part 29)\", {\n set.seed(115)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, alpha0 = 0.1, beta0 = 1.0))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 30: AR(1) correlated predictors\n# =============================================================================\n\ntest_that(\"SS matches individual: AR(1) correlated X (Part 30)\", {\n set.seed(116)\n n <- 100; p <- 50; rho <- 0.8\n\n Z <- matrix(rnorm(n * p), n, p)\n X <- Z\n for (j in 2:p) {\n X[, j] <- rho * X[, j - 1] + sqrt(1 - rho^2) * Z[, j]\n }\n\n beta <- rep(0, p); beta[c(1, 25)] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 31: Block-correlated predictors\n# =============================================================================\n\ntest_that(\"SS matches individual: block-correlated X (Part 31)\", {\n set.seed(117)\n n <- 100; p <- 50; block_size <- 5\n n_blocks <- p / block_size\n\n X <- matrix(0, n, p)\n for (b in seq_len(n_blocks)) {\n cols <- ((b - 1) * block_size + 1):(b * block_size)\n common <- rnorm(n)\n for (j in cols) {\n X[, j] <- 0.8 * common + 0.6 * rnorm(n)\n }\n }\n\n beta <- rep(0, p); beta[c(1, 26)] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 32: Near-collinear predictors\n# =============================================================================\n\ntest_that(\"SS matches individual: near-collinear X (Part 32)\", {\n set.seed(118)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n X[, 2] <- X[, 1] + rnorm(n, sd = 0.1)\n\n beta <- rep(0, p); beta[c(1, 2)] <- c(2, -1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 33: max_iter = 1\n# =============================================================================\n\ntest_that(\"SS matches individual: max_iter = 1 (Part 33)\", {\n set.seed(119)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, max_iter = 1))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 34: max_iter = 2\n# =============================================================================\n\ntest_that(\"SS matches individual: max_iter = 2 (Part 34)\", {\n set.seed(120)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, max_iter = 2))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 35: Tight convergence tolerance\n# =============================================================================\n\ntest_that(\"SS matches individual: tight tol = 1e-6 (Part 35)\", {\n set.seed(121)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, tol = 1e-6))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 36: null_weight = 0.5 (skipped — known dev-side bug)\n# =============================================================================\n\ntest_that(\"SS matches individual: null_weight = 0.5 (Part 36)\", {\n skip(\"null_weight + NIG triggers NA in loglik (dev-side bug)\")\n\n set.seed(122)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, null_weight = 0.5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 37: Non-uniform prior_weights\n# =============================================================================\n\ntest_that(\"SS matches individual: non-uniform prior_weights (Part 37)\", {\n set.seed(123)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n pw <- rep(1, p); pw[1:10] <- 5; pw <- pw / sum(pw)\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, prior_weights = pw))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 38: Small n + weak signal\n# =============================================================================\n\ntest_that(\"SS matches individual: small n + weak signal (Part 38)\", {\n set.seed(124)\n n <- 20; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:2] <- c(0.5, -0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 5))\n expect_ss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# SS Part 39: n << p + L large\n# =============================================================================\n\ntest_that(\"SS matches individual: n << p + large L (Part 39)\", {\n set.seed(125)\n n <- 30; p <- 200\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[c(10, 50, 100)] <- c(3, -2, 4)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 10))\n expect_ss_matches_individual_ss(res)\n})\n\n\n# =============================================================================\n# SS Part 40: standardize=FALSE + custom alpha0/beta0\n# =============================================================================\n\ntest_that(\"SS matches individual: standardize=FALSE + custom priors (Part 40)\", {\n set.seed(127)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y,\n list(L = 10, standardize = FALSE, alpha0 = 1.0, beta0 = 0.5))\n expect_ss_matches_individual_ss(res)\n})\n\n\n# =============================================================================\n# SS Part 41-43: L = 1 variants (all skipped)\n# =============================================================================\n\ntest_that(\"SS matches individual: L=1 + high noise (Part 41)\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n\n set.seed(129)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1] <- 3\n y <- as.vector(X %*% beta + rnorm(n, sd = 10))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 1))\n expect_ss_matches_individual_ss(res)\n})\n\ntest_that(\"SS matches individual: L=1 + very small n (Part 42)\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n\n set.seed(130)\n n <- 15; p <- 30\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1] <- 4\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 1))\n expect_ss_matches_individual_ss(res)\n})\n\ntest_that(\"SS matches individual: L=1 + null signal (Part 43)\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n\n set.seed(131)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n\n res <- run_ss_and_individual_NIG(X, y, list(L = 1))\n expect_ss_matches_individual_ss(res)\n})\n\n# #############################################################################\n# RSS (SUMMARY STATISTICS) VS INDIVIDUAL-LEVEL DATA COMPARISON\n# #############################################################################\n#\n# For each reference test scenario above, verify that susie_rss()\n# (via the bhat/shat/var_y path) produces the same result as susie()\n# with NIG.\n# These tests do NOT require the reference package.\n\n# =============================================================================\n# RSS Part 1: Default parameters (baseline match)\n# =============================================================================\n\ntest_that(\"RSS matches individual: defaults (Part 1)\", {\n set.seed(1)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 10))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 2: L = 1 (skipped — convergence method differs)\n# =============================================================================\n\ntest_that(\"RSS matches individual: L = 1 (Part 2)\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n\n set.seed(2)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[3] <- 3\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 1))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 3: standardize = FALSE\n# =============================================================================\n\ntest_that(\"RSS matches individual: standardize=FALSE (Part 3)\", {\n set.seed(3)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, standardize = FALSE))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 4: Custom alpha0 and beta0\n# =============================================================================\n\ntest_that(\"RSS matches individual: custom alpha0/beta0 (Part 4)\", {\n set.seed(5)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, alpha0 = 1.0, beta0 = 1.0))\n expect_rss_matches_individual_ss(res)\n})\n\ntest_that(\"RSS matches individual: small alpha0/beta0 (Part 5)\", {\n set.seed(6)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, alpha0 = 0.01, beta0 = 0.01))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 6: estimate_prior_variance = FALSE\n# =============================================================================\n\ntest_that(\"RSS matches individual: estimate_prior_variance=FALSE (Part 6)\", {\n set.seed(7)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, estimate_prior_variance = FALSE))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 7: Explicit convergence tolerance\n# =============================================================================\n\ntest_that(\"RSS matches individual: tol = 1e-4 (Part 7)\", {\n set.seed(8)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, tol = 1e-4))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 8: max_iter boundary\n# =============================================================================\n\ntest_that(\"RSS matches individual: small max_iter (Part 8)\", {\n set.seed(9)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, max_iter = 5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 9: Sparse signal\n# =============================================================================\n\ntest_that(\"RSS matches individual: very sparse signal (Part 9)\", {\n set.seed(10)\n n <- 100; p <- 200\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1] <- 5\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 10: Small sample size\n# =============================================================================\n\ntest_that(\"RSS matches individual: small n (Part 10)\", {\n set.seed(11)\n n <- 30; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:2] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 11: High noise\n# =============================================================================\n\ntest_that(\"RSS matches individual: high noise (Part 11)\", {\n set.seed(12)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n, sd = 10))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 10))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 12: Custom alpha0/beta0 with standardize=FALSE\n# =============================================================================\n\ntest_that(\"RSS matches individual: custom priors + standardize=FALSE (Part 12)\", {\n set.seed(14)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, standardize = FALSE, alpha0 = 0.5, beta0 = 0.5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 13: Null signal\n# =============================================================================\n\ntest_that(\"RSS matches individual: null signal (Part 13)\", {\n set.seed(15)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 14: L=1 with standardize=FALSE (skipped)\n# =============================================================================\n\ntest_that(\"RSS matches individual: L=1, standardize=FALSE (Part 14)\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n\n set.seed(16)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[5] <- 4\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 1, standardize = FALSE))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 15: n >> p (overdetermined)\n# =============================================================================\n\ntest_that(\"RSS matches individual: n >> p (Part 15)\", {\n set.seed(101)\n n <- 500; p <- 20\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:3] <- c(2, -1.5, 3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 16: n << p (underdetermined)\n# =============================================================================\n\ntest_that(\"RSS matches individual: n << p (Part 16)\", {\n set.seed(102)\n n <- 30; p <- 200\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[c(5, 50)] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 17: n = p (square)\n# =============================================================================\n\ntest_that(\"RSS matches individual: n = p (Part 17)\", {\n set.seed(103)\n n <- 50; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:3] <- c(2, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 18: Very small n\n# =============================================================================\n\ntest_that(\"RSS matches individual: very small n (Part 18)\", {\n set.seed(104)\n n <- 10; p <- 30\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1] <- 3\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 3))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 19: Weak signals\n# =============================================================================\n\ntest_that(\"RSS matches individual: weak signals (Part 19)\", {\n set.seed(105)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:3] <- c(0.3, -0.3, 0.2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 20: Very strong signals\n# =============================================================================\n\ntest_that(\"RSS matches individual: very strong signals (Part 20)\", {\n set.seed(106)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:3] <- c(10, -15, 20)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 21: Mixed strength signals\n# =============================================================================\n\ntest_that(\"RSS matches individual: mixed strength signals (Part 21)\", {\n set.seed(107)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(10, 0.5, -10, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 10))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 22: Many true effects\n# =============================================================================\n\ntest_that(\"RSS matches individual: many true effects (Part 22)\", {\n set.seed(108)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:10] <- c(2, -1.5, 3, -2, 1, -1, 2.5, -0.8, 1.2, -1.8)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 10))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 23: L = 2\n# =============================================================================\n\ntest_that(\"RSS matches individual: L = 2 (Part 23)\", {\n set.seed(109)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:2] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 2))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 24: L = 20\n# =============================================================================\n\ntest_that(\"RSS matches individual: L = 20 (Part 24)\", {\n set.seed(110)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 20))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 25: L >> true effects\n# =============================================================================\n\ntest_that(\"RSS matches individual: L >> true effects (Part 25)\", {\n set.seed(111)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:2] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 15))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 26: L < true effects\n# =============================================================================\n\ntest_that(\"RSS matches individual: L < true effects (Part 26)\", {\n set.seed(112)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:5] <- c(3, -2, 4, -1.5, 2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 2))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 27: Informative alpha0/beta0\n# =============================================================================\n\ntest_that(\"RSS matches individual: informative alpha0/beta0 (Part 27)\", {\n set.seed(113)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, alpha0 = 10, beta0 = 10))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 28: Very diffuse alpha0/beta0\n# =============================================================================\n\ntest_that(\"RSS matches individual: very diffuse alpha0/beta0 (Part 28)\", {\n set.seed(114)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, alpha0 = 0.001, beta0 = 0.001))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 29: Asymmetric alpha0/beta0\n# =============================================================================\n\ntest_that(\"RSS matches individual: asymmetric alpha0/beta0 (Part 29)\", {\n set.seed(115)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, alpha0 = 0.1, beta0 = 1.0))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 30: AR(1) correlated predictors\n# =============================================================================\n\ntest_that(\"RSS matches individual: AR(1) correlated X (Part 30)\", {\n set.seed(116)\n n <- 100; p <- 50; rho <- 0.8\n\n Z <- matrix(rnorm(n * p), n, p)\n X <- Z\n for (j in 2:p) {\n X[, j] <- rho * X[, j - 1] + sqrt(1 - rho^2) * Z[, j]\n }\n\n beta <- rep(0, p); beta[c(1, 25)] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 31: Block-correlated predictors\n# =============================================================================\n\ntest_that(\"RSS matches individual: block-correlated X (Part 31)\", {\n set.seed(117)\n n <- 100; p <- 50; block_size <- 5\n n_blocks <- p / block_size\n\n X <- matrix(0, n, p)\n for (b in seq_len(n_blocks)) {\n cols <- ((b - 1) * block_size + 1):(b * block_size)\n common <- rnorm(n)\n for (j in cols) {\n X[, j] <- 0.8 * common + 0.6 * rnorm(n)\n }\n }\n\n beta <- rep(0, p); beta[c(1, 26)] <- c(3, -2)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 32: Near-collinear predictors\n# =============================================================================\n\ntest_that(\"RSS matches individual: near-collinear X (Part 32)\", {\n set.seed(118)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n X[, 2] <- X[, 1] + rnorm(n, sd = 0.1)\n\n beta <- rep(0, p); beta[c(1, 2)] <- c(2, -1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 33: max_iter = 1\n# =============================================================================\n\ntest_that(\"RSS matches individual: max_iter = 1 (Part 33)\", {\n set.seed(119)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, max_iter = 1))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 34: max_iter = 2\n# =============================================================================\n\ntest_that(\"RSS matches individual: max_iter = 2 (Part 34)\", {\n set.seed(120)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, max_iter = 2))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 35: Tight convergence tolerance\n# =============================================================================\n\ntest_that(\"RSS matches individual: tight tol = 1e-6 (Part 35)\", {\n set.seed(121)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, tol = 1e-6))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 36: null_weight = 0.5 (skipped — known dev-side bug)\n# =============================================================================\n\ntest_that(\"RSS matches individual: null_weight = 0.5 (Part 36)\", {\n skip(\"null_weight + NIG triggers NA in loglik (dev-side bug)\")\n\n set.seed(122)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, null_weight = 0.5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 37: Non-uniform prior_weights\n# =============================================================================\n\ntest_that(\"RSS matches individual: non-uniform prior_weights (Part 37)\", {\n set.seed(123)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n pw <- rep(1, p); pw[1:10] <- 5; pw <- pw / sum(pw)\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, prior_weights = pw))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 38: Small n + weak signal\n# =============================================================================\n\ntest_that(\"RSS matches individual: small n + weak signal (Part 38)\", {\n set.seed(124)\n n <- 20; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:2] <- c(0.5, -0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 39: n << p + L large\n# =============================================================================\n\ntest_that(\"RSS matches individual: n << p + large L (Part 39)\", {\n set.seed(125)\n n <- 30; p <- 200\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[c(10, 50, 100)] <- c(3, -2, 4)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 10))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 40: standardize=FALSE + custom alpha0/beta0\n# =============================================================================\n\ntest_that(\"RSS matches individual: standardize=FALSE + custom priors (Part 40)\", {\n set.seed(127)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y,\n list(L = 10, standardize = FALSE, alpha0 = 1.0, beta0 = 0.5))\n expect_rss_matches_individual_ss(res)\n})\n\n# =============================================================================\n# RSS Part 41-43: L = 1 variants (all skipped)\n# =============================================================================\n\ntest_that(\"RSS matches individual: L=1 + high noise (Part 41)\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n\n set.seed(129)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1] <- 3\n y <- as.vector(X %*% beta + rnorm(n, sd = 10))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 1))\n expect_rss_matches_individual_ss(res)\n})\n\ntest_that(\"RSS matches individual: L=1 + very small n (Part 42)\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n\n set.seed(130)\n n <- 15; p <- 30\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[1] <- 4\n y <- as.vector(X %*% beta + rnorm(n))\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 1))\n expect_rss_matches_individual_ss(res)\n})\n\ntest_that(\"RSS matches individual: L=1 + null signal (Part 43)\", {\n skip(\"L=1 uses different convergence methods between dev and ref\")\n\n set.seed(131)\n n <- 100; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n\n res <- run_rss_and_individual_NIG(X, y, list(L = 1))\n expect_rss_matches_individual_ss(res)\n})\n" }, { "path": "tests/testthat/reference/test_susie_reference.R", "content": "# Source helper functions\nsource(file.path(\"..\", \"helper_reference.R\"), local = TRUE)\n\ncontext(\"susie reference comparison\")\n\n# =============================================================================\n# REFERENCE TESTS FOR susie()\n# =============================================================================\n#\n# These functions compare the new susieR implementation against the reference\n# package (stephenslab/susieR@1f9166c) to ensure results are identical.\n#\n# Tests cover all major parameters and their combinations with all three\n# prior variance optimization methods: \"optim\", \"EM\", \"simple\"\n\n# =============================================================================\n# Part 1: Basic Parameter Tests\n# =============================================================================\n\ntest_that(\"susie() matches reference with default parameters - optim\", {\n skip_if_no_reference()\n\n set.seed(1)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with default parameters - EM\", {\n skip_if_no_reference()\n\n set.seed(1)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with default parameters - simple\", {\n skip_if_no_reference()\n\n set.seed(1)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 2: standardize parameter\n# =============================================================================\n\ntest_that(\"susie() matches reference with standardize=FALSE - optim\", {\n skip_if_no_reference()\n\n set.seed(2)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, standardize = FALSE, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with standardize=FALSE - EM\", {\n skip_if_no_reference()\n\n set.seed(2)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, standardize = FALSE, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with standardize=FALSE - simple\", {\n skip_if_no_reference()\n\n set.seed(2)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, standardize = FALSE, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 3: intercept parameter\n# =============================================================================\n\ntest_that(\"susie() matches reference with intercept=FALSE - optim\", {\n skip_if_no_reference()\n\n set.seed(3)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, intercept = FALSE, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with intercept=FALSE - EM\", {\n skip_if_no_reference()\n\n set.seed(3)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, intercept = FALSE, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with intercept=FALSE - simple\", {\n skip_if_no_reference()\n\n set.seed(3)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, intercept = FALSE, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 4: estimate_prior_variance=FALSE\n# =============================================================================\n\ntest_that(\"susie() matches reference with estimate_prior_variance=FALSE\", {\n skip_if_no_reference()\n\n set.seed(4)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # When estimate_prior_variance=FALSE, the method doesn't matter\n args <- list(X = X, y = y, L = 10, estimate_prior_variance = FALSE)\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 5: estimate_residual_variance parameter\n# =============================================================================\n\ntest_that(\"susie() matches reference with estimate_residual_variance=FALSE - optim\", {\n skip_if_no_reference()\n\n set.seed(5)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(\n X = X, y = y, L = 10,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with estimate_residual_variance=FALSE - EM\", {\n skip_if_no_reference()\n\n set.seed(5)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(\n X = X, y = y, L = 10,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with estimate_residual_variance=FALSE - simple\", {\n skip_if_no_reference()\n\n set.seed(5)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(\n X = X, y = y, L = 10,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 6: Sparse matrix input\n# =============================================================================\n\ntest_that(\"susie() matches reference with sparse matrix input - optim\", {\n skip_if_no_reference()\n\n set.seed(6)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n X_sparse <- Matrix::Matrix(X, sparse = TRUE)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X_sparse, y = y, L = 10, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with sparse matrix input - EM\", {\n skip_if_no_reference()\n\n set.seed(6)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n X_sparse <- Matrix::Matrix(X, sparse = TRUE)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X_sparse, y = y, L = 10, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with sparse matrix input - simple\", {\n skip_if_no_reference()\n\n set.seed(6)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n X_sparse <- Matrix::Matrix(X, sparse = TRUE)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X_sparse, y = y, L = 10, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 7: Different L values\n# =============================================================================\n\ntest_that(\"susie() matches reference with different L values - optim\", {\n skip_if_no_reference()\n\n set.seed(7)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Test L=1\n args1 <- list(X = X, y = y, L = 1, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args1, tolerance = 1e-5)\n\n # Test L=5\n args5 <- list(X = X, y = y, L = 5, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args5, tolerance = 1e-5)\n\n # Test L=20\n args20 <- list(X = X, y = y, L = 20, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args20, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with different L values - EM\", {\n skip_if_no_reference()\n\n set.seed(7)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Test L=1\n args1 <- list(X = X, y = y, L = 1, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie\", args1, tolerance = 1e-5)\n\n # Test L=5\n args5 <- list(X = X, y = y, L = 5, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie\", args5, tolerance = 1e-5)\n\n # Test L=20\n args20 <- list(X = X, y = y, L = 20, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie\", args20, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with different L values - simple\", {\n skip_if_no_reference()\n\n set.seed(7)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Test L=1\n args1 <- list(X = X, y = y, L = 1, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie\", args1, tolerance = 1e-5)\n\n # Test L=5\n args5 <- list(X = X, y = y, L = 5, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie\", args5, tolerance = 1e-5)\n\n # Test L=20\n args20 <- list(X = X, y = y, L = 20, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie\", args20, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 8: prior_weights\n# =============================================================================\n\ntest_that(\"susie() matches reference with prior_weights - optim\", {\n skip_if_no_reference()\n\n set.seed(8)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Use non-uniform prior weights\n prior_weights <- runif(p)\n prior_weights <- prior_weights / sum(prior_weights)\n args <- list(X = X, y = y, L = 10, prior_weights = prior_weights, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with prior_weights - EM\", {\n skip_if_no_reference()\n\n set.seed(8)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Use non-uniform prior weights\n prior_weights <- runif(p)\n prior_weights <- prior_weights / sum(prior_weights)\n args <- list(X = X, y = y, L = 10, prior_weights = prior_weights, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with prior_weights - simple\", {\n skip_if_no_reference()\n\n set.seed(8)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Use non-uniform prior weights\n prior_weights <- runif(p)\n prior_weights <- prior_weights / sum(prior_weights)\n args <- list(X = X, y = y, L = 10, prior_weights = prior_weights, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 9: scaled_prior_variance\n# =============================================================================\n\ntest_that(\"susie() matches reference with scaled_prior_variance - optim\", {\n skip_if_no_reference()\n\n set.seed(9)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, scaled_prior_variance = 0.5, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with scaled_prior_variance - EM\", {\n skip_if_no_reference()\n\n set.seed(9)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, scaled_prior_variance = 0.5, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with scaled_prior_variance - simple\", {\n skip_if_no_reference()\n\n set.seed(9)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, scaled_prior_variance = 0.5, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 10: coverage and min_abs_corr\n# =============================================================================\n\ntest_that(\"susie() matches reference with coverage=0.99 - optim\", {\n skip_if_no_reference()\n\n set.seed(10)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, coverage = 0.99, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with coverage=0.99 - EM\", {\n skip_if_no_reference()\n\n set.seed(10)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, coverage = 0.99, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with coverage=0.99 - simple\", {\n skip_if_no_reference()\n\n set.seed(10)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, coverage = 0.99, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with min_abs_corr=0.7 - optim\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, min_abs_corr = 0.7, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with min_abs_corr=0.7 - EM\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, min_abs_corr = 0.7, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with min_abs_corr=0.7 - simple\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(X = X, y = y, L = 10, min_abs_corr = 0.7, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 11: Combined parameter variations\n# =============================================================================\n\ntest_that(\"susie() matches reference with combined parameters - optim\", {\n skip_if_no_reference()\n\n set.seed(13)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Test combination: standardize=FALSE, intercept=FALSE\n args1 <- list(X = X, y = y, L = 10, standardize = FALSE, intercept = FALSE, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args1, tolerance = 1e-5)\n\n # Test combination: estimate_prior_variance=FALSE, estimate_residual_variance=FALSE\n args2 <- list(\n X = X, y = y, L = 10,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie\", args2, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with combined parameters - EM\", {\n skip_if_no_reference()\n\n set.seed(13)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Test combination: standardize=FALSE, intercept=FALSE\n args1 <- list(X = X, y = y, L = 10, standardize = FALSE, intercept = FALSE, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie\", args1, tolerance = 1e-5)\n\n # Test combination: estimate_prior_variance=FALSE, estimate_residual_variance=FALSE\n args2 <- list(\n X = X, y = y, L = 10,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie\", args2, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with combined parameters - simple\", {\n skip_if_no_reference()\n\n set.seed(13)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Test combination: standardize=FALSE, intercept=FALSE\n args1 <- list(X = X, y = y, L = 10, standardize = FALSE, intercept = FALSE, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie\", args1, tolerance = 1e-5)\n\n # Test combination: estimate_prior_variance=FALSE, estimate_residual_variance=FALSE\n args2 <- list(\n X = X, y = y, L = 10,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie\", args2, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 12: prior_tol parameter\n# =============================================================================\n\ntest_that(\"susie() matches reference with prior_tol=0.1 - optim\", {\n skip_if_no_reference()\n\n set.seed(14)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(\n X = X, y = y, L = 10,\n prior_tol = 0.1,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with prior_tol=0.1 - EM\", {\n skip(\"Intentional change: susieR2.0 adds a post-convergence trim_null_effects() pass that zeros model$V entries where V < prior_tol. The reference uses prior_tol only to filter PIPs in susie_get_pip(); it never zeros V. Any prior_tol value large enough to trigger the trim on dev but not the ref produces a divergence in the final V / alpha / mu that exceeds the 1e-5 tolerance.\")\n skip_if_no_reference()\n\n set.seed(14)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(\n X = X, y = y, L = 10,\n prior_tol = 0.1,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with prior_tol=0.1 - simple\", {\n skip_if_no_reference()\n\n set.seed(14)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(\n X = X, y = y, L = 10,\n prior_tol = 0.1,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 13: check_null_threshold parameter\n# =============================================================================\n\ntest_that(\"susie() matches reference with check_null_threshold=0.1 - optim\", {\n skip_if_no_reference()\n\n set.seed(15)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(\n X = X, y = y, L = 10,\n check_null_threshold = 0.1,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with check_null_threshold=0.1 - EM\", {\n skip(\"Not a bug: susieR2.0 intentionally skips the check_null_threshold V-zeroing step for EM (see R/single_effect_regression.R:169 and stephenslab/mvsusieR#26). The check would zero V without recomputing the posterior, creating an inconsistent (q, V) pair that can decrease the ELBO. Null effects are instead removed by trim_null_effects() after convergence. Since dev ignores check_null_threshold for EM, this test cannot match a reference that always applies the check.\")\n skip_if_no_reference()\n\n set.seed(15)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(\n X = X, y = y, L = 10,\n check_null_threshold = 0.1,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with check_null_threshold=0.1 - simple\", {\n skip_if_no_reference()\n\n set.seed(15)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(\n X = X, y = y, L = 10,\n check_null_threshold = 0.1,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with check_null_threshold=0.5 - optim\", {\n skip_if_no_reference()\n\n set.seed(16)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(\n X = X, y = y, L = 10,\n check_null_threshold = 0.5,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with check_null_threshold=0.5 - EM\", {\n skip(\"Not a bug: susieR2.0 intentionally skips the check_null_threshold V-zeroing step for EM (see R/single_effect_regression.R:169 and stephenslab/mvsusieR#26). The check would zero V without recomputing the posterior, creating an inconsistent (q, V) pair that can decrease the ELBO. Since dev ignores check_null_threshold for EM, this test cannot match a reference that always applies the check.\")\n skip_if_no_reference()\n\n set.seed(16)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(\n X = X, y = y, L = 10,\n check_null_threshold = 0.5,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with check_null_threshold=0.5 - simple\", {\n skip_if_no_reference()\n\n set.seed(16)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n args <- list(\n X = X, y = y, L = 10,\n check_null_threshold = 0.5,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 14: residual_variance bounds\n# =============================================================================\n\ntest_that(\"susie() matches reference with residual_variance_upperbound - optim\", {\n skip_if_no_reference()\n\n set.seed(17)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Set upperbound lower than natural variance (~1.07) to ensure it's binding\n args <- list(\n X = X, y = y, L = 10,\n residual_variance_upperbound = 0.8,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with residual_variance_upperbound - EM\", {\n skip_if_no_reference()\n\n set.seed(17)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Set upperbound lower than natural variance (~1.07) to ensure it's binding\n args <- list(\n X = X, y = y, L = 10,\n residual_variance_upperbound = 0.8,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with residual_variance_upperbound - simple\", {\n skip(\"Intentional improvement: reference declares convergence on any ELBO change below tol (including negative), so it stops at iter 2 after the ELBO drops by ~25 (because the binding upperbound=0.8 forces sigma2 away from the MLE). susieR2.0 requires 0 <= ELBO_diff < tol (see R/model_methods.R:229-233), correctly continues iterating, and lands at a slightly better ELBO with different mu. Posterior alpha, V, and sigma2 match to ~1e-17; only mu differs (up to 0.5) because the reference returned a mid-drop snapshot.\")\n skip_if_no_reference()\n\n set.seed(17)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Set upperbound lower than natural variance (~1.07) to ensure it's binding\n args <- list(\n X = X, y = y, L = 10,\n residual_variance_upperbound = 0.8,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with residual_variance_lowerbound - optim\", {\n skip_if_no_reference()\n\n set.seed(18)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Set lowerbound higher than natural variance (~1.07) to ensure it's binding\n args <- list(\n X = X, y = y, L = 10,\n residual_variance_lowerbound = 1.5,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with residual_variance_lowerbound - EM\", {\n skip_if_no_reference()\n\n set.seed(18)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Set lowerbound higher than natural variance (~1.07) to ensure it's binding\n args <- list(\n X = X, y = y, L = 10,\n residual_variance_lowerbound = 1.5,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with residual_variance_lowerbound - simple\", {\n skip_if_no_reference()\n\n set.seed(18)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Set lowerbound higher than natural variance (~1.07) to ensure it's binding\n args <- list(\n X = X, y = y, L = 10,\n residual_variance_lowerbound = 1.5,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 15: na.rm parameter\n# =============================================================================\n\ntest_that(\"susie() matches reference with na.rm=TRUE - optim\", {\n skip_if_no_reference()\n\n set.seed(19)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Introduce NA values\n y[c(1, 25, 50)] <- NA\n\n args <- list(X = X, y = y, L = 10, na.rm = TRUE, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with na.rm=TRUE - EM\", {\n skip_if_no_reference()\n\n set.seed(19)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Introduce NA values\n y[c(1, 25, 50)] <- NA\n\n args <- list(X = X, y = y, L = 10, na.rm = TRUE, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with na.rm=TRUE - simple\", {\n skip_if_no_reference()\n\n set.seed(19)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Introduce NA values\n y[c(1, 25, 50)] <- NA\n\n args <- list(X = X, y = y, L = 10, na.rm = TRUE, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with na.rm=TRUE and single NA - optim\", {\n skip_if_no_reference()\n\n set.seed(20)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Single NA (the bug report case)\n y[1] <- NA\n\n args <- list(X = X, y = y, L = 10, na.rm = TRUE, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with na.rm=TRUE and standardize=FALSE\", {\n skip_if_no_reference()\n\n set.seed(21)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Introduce NA values\n y[c(5, 10, 15)] <- NA\n\n args <- list(X = X, y = y, L = 10, na.rm = TRUE, standardize = FALSE,\n estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with na.rm=TRUE and intercept=FALSE\", {\n skip_if_no_reference()\n\n set.seed(22)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Introduce NA values\n y[c(10, 20, 30)] <- NA\n\n args <- list(X = X, y = y, L = 10, na.rm = TRUE, intercept = FALSE,\n estimate_prior_method = \"optim\")\n compare_to_reference(\"susie\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 16: model_init parameter (dev) vs s_init (reference)\n# =============================================================================\n#\n# These tests verify that our model_init parameter produces identical results\n# to the reference package's s_init parameter. Each test runs an initial susie\n# fit on both packages, then passes the result as model_init/s_init to a\n# second call and compares outputs.\n\ntest_that(\"susie() matches reference with model_init - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(23)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Run initial fit on both packages (short run to get a non-trivial init)\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n # Run with model_init (dev) / s_init (ref)\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n estimate_prior_method = \"optim\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init - EM\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(23)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n estimate_prior_method = \"EM\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n estimate_prior_method = \"EM\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n estimate_prior_method = \"EM\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(23)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n estimate_prior_method = \"simple\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# model_init with estimate_residual_variance=FALSE\ntest_that(\"susie() matches reference with model_init and estimate_residual_variance=FALSE - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(24)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n estimate_residual_variance = FALSE, residual_variance = 1.0,\n estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n estimate_residual_variance = FALSE, residual_variance = 1.0,\n estimate_prior_method = \"optim\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init and estimate_residual_variance=FALSE - EM\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(24)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n estimate_prior_method = \"EM\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n estimate_residual_variance = FALSE, residual_variance = 1.0,\n estimate_prior_method = \"EM\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n estimate_residual_variance = FALSE, residual_variance = 1.0,\n estimate_prior_method = \"EM\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init and estimate_residual_variance=FALSE - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(24)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n estimate_residual_variance = FALSE, residual_variance = 1.0,\n estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n estimate_residual_variance = FALSE, residual_variance = 1.0,\n estimate_prior_method = \"simple\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# model_init with estimate_prior_variance=FALSE\ntest_that(\"susie() matches reference with model_init and estimate_prior_variance=FALSE\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(25)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n estimate_prior_variance = FALSE)\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n estimate_prior_variance = FALSE)\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n estimate_prior_variance = FALSE)\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# model_init with standardize=FALSE\ntest_that(\"susie() matches reference with model_init and standardize=FALSE - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(26)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n standardize = FALSE, estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n standardize = FALSE, estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n standardize = FALSE, estimate_prior_method = \"optim\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init and standardize=FALSE - EM\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(26)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n standardize = FALSE, estimate_prior_method = \"EM\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n standardize = FALSE, estimate_prior_method = \"EM\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n standardize = FALSE, estimate_prior_method = \"EM\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init and standardize=FALSE - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(26)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n standardize = FALSE, estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n standardize = FALSE, estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n standardize = FALSE, estimate_prior_method = \"simple\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# model_init with intercept=FALSE\ntest_that(\"susie() matches reference with model_init and intercept=FALSE - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(27)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n intercept = FALSE, estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n intercept = FALSE, estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n intercept = FALSE, estimate_prior_method = \"optim\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init and intercept=FALSE - EM\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(27)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n intercept = FALSE, estimate_prior_method = \"EM\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n intercept = FALSE, estimate_prior_method = \"EM\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n intercept = FALSE, estimate_prior_method = \"EM\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init and intercept=FALSE - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(27)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n intercept = FALSE, estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n intercept = FALSE, estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n intercept = FALSE, estimate_prior_method = \"simple\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# model_init with L expansion (second call requests more effects than init)\ntest_that(\"susie() matches reference with model_init and L expansion - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(28)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Initial fit with L=3\n init_args <- list(X = X, y = y, L = 3, max_iter = 3,\n estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n # Second fit with L=10 (expansion)\n dev_args <- list(X = X, y = y, L = 10, model_init = dev_init,\n estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 10, s_init = ref_init,\n estimate_prior_method = \"optim\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init and L expansion - EM\", {\n skip(\"Intentional improvement: susieR2.0 preserves fitted V during L expansion; reference resets all V to default. EM updates V incrementally so intermediate ELBOs differ, but final posteriors converge.\")\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(28)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 3, max_iter = 3,\n estimate_prior_method = \"EM\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 10, model_init = dev_init,\n estimate_prior_method = \"EM\")\n ref_args <- list(X = X, y = y, L = 10, s_init = ref_init,\n estimate_prior_method = \"EM\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init and L expansion - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(28)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 3, max_iter = 3,\n estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 10, model_init = dev_init,\n estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 10, s_init = ref_init,\n estimate_prior_method = \"simple\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# model_init with combined standardize=FALSE and intercept=FALSE\ntest_that(\"susie() matches reference with model_init, standardize=FALSE, intercept=FALSE - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(29)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n standardize = FALSE, intercept = FALSE,\n estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n standardize = FALSE, intercept = FALSE,\n estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n standardize = FALSE, intercept = FALSE,\n estimate_prior_method = \"optim\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 17: model_init with L expansion - deeper probing for differences\n# =============================================================================\n#\n# These tests specifically target L expansion (model_init has fewer effects\n# than the requested L) with various parameter combinations to find behavioral\n# differences between model_init (dev) and s_init (ref).\n\n# L expansion with estimate_prior_variance=FALSE\n# When V is never re-estimated, any difference in V initialization should\n# propagate through all iterations and affect final posteriors.\ntest_that(\"susie() matches reference with model_init, L expansion, estimate_prior_variance=FALSE - optim\", {\n skip(\"Intentional improvement: susieR2.0 preserves fitted V during L expansion; reference resets all V to default. With estimate_prior_variance=FALSE, the V difference persists in final posteriors.\")\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(30)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Initial fit with L=3\n init_args <- list(X = X, y = y, L = 3, max_iter = 5,\n estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n # Second fit with L=8, estimate_prior_variance=FALSE\n dev_args <- list(X = X, y = y, L = 8, model_init = dev_init,\n estimate_prior_variance = FALSE,\n estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 8, s_init = ref_init,\n estimate_prior_variance = FALSE,\n estimate_prior_method = \"optim\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init, L expansion, estimate_prior_variance=FALSE - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(30)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 3, max_iter = 5,\n estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 8, model_init = dev_init,\n estimate_prior_variance = FALSE,\n estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 8, s_init = ref_init,\n estimate_prior_variance = FALSE,\n estimate_prior_method = \"simple\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# L expansion with BOTH estimate_prior_variance=FALSE AND estimate_residual_variance=FALSE\n# Fully constrained variances - any V initialization difference is permanent.\ntest_that(\"susie() matches reference with model_init, L expansion, both variances fixed - optim\", {\n skip(\"Intentional improvement: susieR2.0 preserves fitted V during L expansion; reference resets all V to default. With both variances fixed, the V difference persists in final posteriors.\")\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(31)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 3, max_iter = 5,\n estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 8, model_init = dev_init,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 8, s_init = ref_init,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"optim\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init, L expansion, both variances fixed - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(31)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 3, max_iter = 5,\n estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 8, model_init = dev_init,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 8, s_init = ref_init,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"simple\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# L expansion with standardize=FALSE\ntest_that(\"susie() matches reference with model_init, L expansion, standardize=FALSE - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(32)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 3, max_iter = 3,\n standardize = FALSE, estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 10, model_init = dev_init,\n standardize = FALSE, estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 10, s_init = ref_init,\n standardize = FALSE, estimate_prior_method = \"optim\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init, L expansion, standardize=FALSE - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(32)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 3, max_iter = 3,\n standardize = FALSE, estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 10, model_init = dev_init,\n standardize = FALSE, estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 10, s_init = ref_init,\n standardize = FALSE, estimate_prior_method = \"simple\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# L expansion with intercept=FALSE\ntest_that(\"susie() matches reference with model_init, L expansion, intercept=FALSE - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(33)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 3, max_iter = 3,\n intercept = FALSE, estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 10, model_init = dev_init,\n intercept = FALSE, estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 10, s_init = ref_init,\n intercept = FALSE, estimate_prior_method = \"optim\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init, L expansion, intercept=FALSE - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(33)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 3, max_iter = 3,\n intercept = FALSE, estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 10, model_init = dev_init,\n intercept = FALSE, estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 10, s_init = ref_init,\n intercept = FALSE, estimate_prior_method = \"simple\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# L expansion with non-default scaled_prior_variance\ntest_that(\"susie() matches reference with model_init, L expansion, scaled_prior_variance=0.5 - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(34)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 3, max_iter = 3,\n scaled_prior_variance = 0.5,\n estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 10, model_init = dev_init,\n scaled_prior_variance = 0.5,\n estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 10, s_init = ref_init,\n scaled_prior_variance = 0.5,\n estimate_prior_method = \"optim\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 18: model_init with L contraction (model_init has more effects than L)\n# =============================================================================\n\ntest_that(\"susie() matches reference with model_init, L contraction - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(35)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Initial fit with L=10\n init_args <- list(X = X, y = y, L = 10, max_iter = 5,\n estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n # Second fit with L=5 (contraction - model_init has more effects)\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n estimate_prior_method = \"optim\")\n\n dev_result <- suppressWarnings(suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))))\n ref_result <- suppressWarnings(suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init, L contraction - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(35)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 10, max_iter = 5,\n estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n estimate_prior_method = \"simple\")\n\n dev_result <- suppressWarnings(suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))))\n ref_result <- suppressWarnings(suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 19: model_init with susie_init_coef\n# =============================================================================\n\ntest_that(\"susie() matches reference with susie_init_coef as model_init - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(36)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Create init from known coefficients\n dev_coef_init <- dev_env$env[[\"susie_init_coef\"]](1:4, c(2, 3, -2, 1.5), p)\n ref_coef_init <- ref_env$env[[\"susie_init_coef\"]](1:4, c(2, 3, -2, 1.5), p)\n\n dev_args <- list(X = X, y = y, L = 10, model_init = dev_coef_init,\n estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 10, s_init = ref_coef_init,\n estimate_prior_method = \"optim\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with susie_init_coef as model_init - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(36)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_coef_init <- dev_env$env[[\"susie_init_coef\"]](1:4, c(2, 3, -2, 1.5), p)\n ref_coef_init <- ref_env$env[[\"susie_init_coef\"]](1:4, c(2, 3, -2, 1.5), p)\n\n dev_args <- list(X = X, y = y, L = 10, model_init = dev_coef_init,\n estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 10, s_init = ref_coef_init,\n estimate_prior_method = \"simple\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# susie_init_coef with same L (no expansion)\ntest_that(\"susie() matches reference with susie_init_coef as model_init, matching L - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(37)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n dev_coef_init <- dev_env$env[[\"susie_init_coef\"]](1:4, c(2, 3, -2, 1.5), p)\n ref_coef_init <- ref_env$env[[\"susie_init_coef\"]](1:4, c(2, 3, -2, 1.5), p)\n\n dev_args <- list(X = X, y = y, L = 4, model_init = dev_coef_init,\n estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 4, s_init = ref_coef_init,\n estimate_prior_method = \"optim\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 20: model_init with null_weight\n# =============================================================================\n\ntest_that(\"susie() matches reference with model_init and null_weight - optim\", {\n skip(\"Bug fix: susieR1.0 incorrectly set lpo=0 for infinite shat2 (null column), ignoring the actual null_weight. susieR2.0 correctly uses log(prior_weights).\")\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(38)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n null_weight = 0.5,\n estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n null_weight = 0.5,\n estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n null_weight = 0.5,\n estimate_prior_method = \"optim\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init and null_weight - simple\", {\n skip(\"Bug fix: susieR1.0 incorrectly set lpo=0 for infinite shat2 (null column), ignoring the actual null_weight. susieR2.0 correctly uses log(prior_weights).\")\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(38)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n null_weight = 0.5,\n estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n null_weight = 0.5,\n estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n null_weight = 0.5,\n estimate_prior_method = \"simple\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 21: model_init with prior_weights\n# =============================================================================\n\ntest_that(\"susie() matches reference with model_init and prior_weights - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(39)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Non-uniform prior weights\n pw <- runif(p)\n pw <- pw / sum(pw)\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n prior_weights = pw,\n estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n prior_weights = pw,\n estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n prior_weights = pw,\n estimate_prior_method = \"optim\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init and prior_weights - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(39)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n pw <- runif(p)\n pw <- pw / sum(pw)\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n prior_weights = pw,\n estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n prior_weights = pw,\n estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n prior_weights = pw,\n estimate_prior_method = \"simple\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# L expansion with prior_weights\ntest_that(\"susie() matches reference with model_init, L expansion, and prior_weights - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(40)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n pw <- runif(p)\n pw <- pw / sum(pw)\n\n init_args <- list(X = X, y = y, L = 3, max_iter = 3,\n prior_weights = pw,\n estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 8, model_init = dev_init,\n prior_weights = pw,\n estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 8, s_init = ref_init,\n prior_weights = pw,\n estimate_prior_method = \"optim\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 22: model_init with max_iter=1 (single iteration - check initialization)\n# =============================================================================\n# Running with max_iter=1 ensures we're testing the initialization path itself,\n# not just the converged output.\n\ntest_that(\"susie() matches reference with model_init, max_iter=1 - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(41)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n max_iter = 1, estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n max_iter = 1, estimate_prior_method = \"optim\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init, max_iter=1 - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(41)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 5, max_iter = 3,\n estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 5, model_init = dev_init,\n max_iter = 1, estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 5, s_init = ref_init,\n max_iter = 1, estimate_prior_method = \"simple\")\n\n dev_result <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args))\n ref_result <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\n# L expansion with max_iter=1\ntest_that(\"susie() matches reference with model_init, L expansion, max_iter=1 - optim\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(42)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 3, max_iter = 3,\n estimate_prior_method = \"optim\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 8, model_init = dev_init,\n max_iter = 1, estimate_prior_method = \"optim\")\n ref_args <- list(X = X, y = y, L = 8, s_init = ref_init,\n max_iter = 1, estimate_prior_method = \"optim\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n\ntest_that(\"susie() matches reference with model_init, L expansion, max_iter=1 - simple\", {\n skip_if_no_reference()\n\n ref_env <- load_reference_env()\n dev_env <- load_development_env()\n\n set.seed(42)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n init_args <- list(X = X, y = y, L = 3, max_iter = 3,\n estimate_prior_method = \"simple\")\n dev_init <- do.call(dev_env$env[[\"susie\"]], inject_em_null_check(init_args))\n ref_init <- do.call(ref_env$env[[\"susie\"]], inject_em_null_check(init_args))\n\n dev_args <- list(X = X, y = y, L = 8, model_init = dev_init,\n max_iter = 1, estimate_prior_method = \"simple\")\n ref_args <- list(X = X, y = y, L = 8, s_init = ref_init,\n max_iter = 1, estimate_prior_method = \"simple\")\n\n dev_result <- suppressMessages(do.call(dev_env$env[[\"susie\"]], inject_em_null_check(dev_args)))\n ref_result <- suppressMessages(do.call(ref_env$env[[\"susie\"]], inject_em_null_check(ref_args)))\n\n expect_equal_susie_objects(dev_result, ref_result, tolerance = 1e-5)\n})\n" }, { "path": "tests/testthat/reference/test_susie_rss_lambda_reference.R", "content": "# Source helper functions\nsource(file.path(\"..\", \"helper_reference.R\"), local = TRUE)\n\ncontext(\"susie_rss with lambda reference comparison\")\n\n# =============================================================================\n# REFERENCE TESTS FOR susie_rss_lambda() with lambda > 0\n# =============================================================================\n#\n# These tests compare susie_rss_lambda(lambda > 0) against the historical\n# susie_rss(lambda > 0) implementation from stephenslab/susieR@1f9166c.\n#\n\n# =============================================================================\n# Part 1: Different lambda values\n# =============================================================================\n\ntest_that(\"susie_rss_lambda() matches reference with lambda=1e-5 - optim\", {\n skip_if_no_reference()\n\n set.seed(1)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, estimate_prior_method = \"optim\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with lambda=1e-5 - EM\", {\n skip_if_no_reference()\n\n set.seed(1)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, estimate_prior_method = \"EM\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with lambda=1e-5 - simple\", {\n skip_if_no_reference()\n\n set.seed(1)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, estimate_prior_method = \"simple\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with lambda=0.1 - optim\", {\n skip_if_no_reference()\n\n set.seed(2)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 0.1, estimate_prior_method = \"optim\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with lambda=0.1 - EM\", {\n skip_if_no_reference()\n\n set.seed(2)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 0.1, estimate_prior_method = \"EM\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with lambda=0.1 - simple\", {\n skip_if_no_reference()\n\n set.seed(2)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 0.1, estimate_prior_method = \"simple\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with lambda=0.5 - optim\", {\n skip_if_no_reference()\n\n set.seed(3)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 0.5, estimate_prior_method = \"optim\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with lambda=0.5 - EM\", {\n skip_if_no_reference()\n\n set.seed(3)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 0.5, estimate_prior_method = \"EM\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with lambda=0.5 - simple\", {\n skip_if_no_reference()\n\n set.seed(3)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 0.5, estimate_prior_method = \"simple\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\n# =============================================================================\n# Part 2: Different L values\n# =============================================================================\n\ntest_that(\"susie_rss_lambda() matches reference with different L values - optim\", {\n skip_if_no_reference()\n\n set.seed(4)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Test L=1\n args1 <- list(z = z, R = R, L = 1, lambda = 1e-5, estimate_prior_method = \"optim\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args1, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n\n # Test L=5\n args5 <- list(z = z, R = R, L = 5, lambda = 1e-5, estimate_prior_method = \"optim\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args5, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n\n # Test L=20\n args20 <- list(z = z, R = R, L = 20, lambda = 1e-5, estimate_prior_method = \"optim\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args20, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with different L values - EM\", {\n skip_if_no_reference()\n\n set.seed(4)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Test L=1\n args1 <- list(z = z, R = R, L = 1, lambda = 1e-5, estimate_prior_method = \"EM\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args1, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n\n # Test L=5\n args5 <- list(z = z, R = R, L = 5, lambda = 1e-5, estimate_prior_method = \"EM\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args5, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n\n # Test L=20\n args20 <- list(z = z, R = R, L = 20, lambda = 1e-5, estimate_prior_method = \"EM\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args20, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with different L values - simple\", {\n skip_if_no_reference()\n\n set.seed(4)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Test L=1\n args1 <- list(z = z, R = R, L = 1, lambda = 1e-5, estimate_prior_method = \"simple\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args1, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n\n # Test L=5\n args5 <- list(z = z, R = R, L = 5, lambda = 1e-5, estimate_prior_method = \"simple\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args5, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n\n # Test L=20\n args20 <- list(z = z, R = R, L = 20, lambda = 1e-5, estimate_prior_method = \"simple\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args20, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\n# =============================================================================\n# Part 3: estimate_prior_variance parameter\n# =============================================================================\n\ntest_that(\"susie_rss_lambda() matches reference with estimate_prior_variance=FALSE - optim\", {\n skip_if_no_reference()\n\n set.seed(5)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = TRUE,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with estimate_prior_variance=FALSE - EM\", {\n skip_if_no_reference()\n\n set.seed(5)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = TRUE,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with estimate_prior_variance=FALSE - simple\", {\n skip_if_no_reference()\n\n set.seed(5)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = TRUE,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\n# =============================================================================\n# Part 4: estimate_residual_variance parameter\n# =============================================================================\n\ntest_that(\"susie_rss_lambda() matches reference with estimate_residual_variance=FALSE - optim\", {\n skip_if_no_reference()\n\n set.seed(6)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n estimate_residual_variance = FALSE,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with estimate_residual_variance=FALSE - EM\", {\n skip_if_no_reference()\n\n set.seed(6)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n estimate_residual_variance = FALSE,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with estimate_residual_variance=FALSE - simple\", {\n skip_if_no_reference()\n\n set.seed(6)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n estimate_residual_variance = FALSE,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with residual_variance fixed - optim\", {\n skip_if_no_reference()\n\n set.seed(7)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with residual_variance fixed - EM\", {\n skip_if_no_reference()\n\n set.seed(7)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with residual_variance fixed - simple\", {\n skip_if_no_reference()\n\n set.seed(7)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\n# =============================================================================\n# Part 5: prior_variance parameter\n# =============================================================================\n\ntest_that(\"susie_rss_lambda() matches reference with prior_variance=100 - optim\", {\n skip_if_no_reference()\n\n set.seed(8)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, prior_variance = 100, estimate_prior_method = \"optim\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with prior_variance=100 - EM\", {\n skip_if_no_reference()\n\n set.seed(8)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, prior_variance = 100, estimate_prior_method = \"EM\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with prior_variance=100 - simple\", {\n skip_if_no_reference()\n\n set.seed(8)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, prior_variance = 100, estimate_prior_method = \"simple\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\n# =============================================================================\n# Part 6: prior_weights\n# =============================================================================\n\ntest_that(\"susie_rss_lambda() matches reference with prior_weights - optim\", {\n skip_if_no_reference()\n\n set.seed(9)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Use non-uniform prior weights\n prior_weights <- runif(p)\n prior_weights <- prior_weights / sum(prior_weights)\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, prior_weights = prior_weights, estimate_prior_method = \"optim\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with prior_weights - EM\", {\n skip_if_no_reference()\n\n set.seed(9)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Use non-uniform prior weights\n prior_weights <- runif(p)\n prior_weights <- prior_weights / sum(prior_weights)\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, prior_weights = prior_weights, estimate_prior_method = \"EM\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with prior_weights - simple\", {\n skip_if_no_reference()\n\n set.seed(9)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Use non-uniform prior weights\n prior_weights <- runif(p)\n prior_weights <- prior_weights / sum(prior_weights)\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, prior_weights = prior_weights, estimate_prior_method = \"simple\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\n# =============================================================================\n# Part 7: maf filtering\n# =============================================================================\n\ntest_that(\"susie_rss_lambda() matches reference with maf filtering - optim\", {\n skip_if_no_reference()\n\n set.seed(10)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Simulate minor allele frequencies\n maf <- runif(p, 0.05, 0.5)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n maf = maf, maf_thresh = 0.1,\n estimate_prior_method = \"optim\",\n estimate_residual_variance = TRUE\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with maf filtering - EM\", {\n skip_if_no_reference()\n\n set.seed(10)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Simulate minor allele frequencies\n maf <- runif(p, 0.05, 0.5)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n maf = maf, maf_thresh = 0.1,\n estimate_prior_method = \"EM\",\n estimate_residual_variance = TRUE\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with maf filtering - simple\", {\n skip_if_no_reference()\n\n set.seed(10)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Simulate minor allele frequencies\n maf <- runif(p, 0.05, 0.5)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n maf = maf, maf_thresh = 0.1,\n estimate_prior_method = \"simple\",\n estimate_residual_variance = TRUE\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\n# =============================================================================\n# Part 8: coverage and min_abs_corr\n# =============================================================================\n\ntest_that(\"susie_rss_lambda() matches reference with coverage=0.99 - optim\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, coverage = 0.99, estimate_prior_method = \"optim\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with coverage=0.99 - EM\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, coverage = 0.99, estimate_prior_method = \"EM\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with coverage=0.99 - simple\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, coverage = 0.99, estimate_prior_method = \"simple\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with min_abs_corr=0.7 - optim\", {\n skip_if_no_reference()\n\n set.seed(12)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, min_abs_corr = 0.7, estimate_prior_method = \"optim\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with min_abs_corr=0.7 - EM\", {\n skip_if_no_reference()\n\n set.seed(12)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, min_abs_corr = 0.7, estimate_prior_method = \"EM\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with min_abs_corr=0.7 - simple\", {\n skip_if_no_reference()\n\n set.seed(12)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, min_abs_corr = 0.7, estimate_prior_method = \"simple\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\n# =============================================================================\n# Part 9: prior_tol parameter\n# =============================================================================\n\ntest_that(\"susie_rss_lambda() matches reference with prior_tol=1e-5 - optim\", {\n skip_if_no_reference()\n\n set.seed(13)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Disable check_null_threshold so we can see prior_tol effects\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n prior_tol = 0.1,\n estimate_prior_method = \"optim\",\n estimate_residual_variance = TRUE\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with prior_tol=1e-5 - EM\", {\n skip_if_no_reference()\n\n set.seed(13)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n prior_tol = 0.1,\n estimate_prior_method = \"EM\",\n estimate_residual_variance = TRUE\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with prior_tol=1e-5 - simple\", {\n skip_if_no_reference()\n\n set.seed(13)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n prior_tol = 0.1,\n estimate_prior_method = \"simple\",\n estimate_residual_variance = TRUE\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\n# =============================================================================\n# Part 10: check_null_threshold parameter\n# =============================================================================\n\ntest_that(\"susie_rss_lambda() matches reference with check_null_threshold=0.1 - optim\", {\n skip_if_no_reference()\n\n set.seed(14)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n check_null_threshold = 0.1,\n estimate_prior_method = \"optim\",\n estimate_residual_variance = TRUE\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with check_null_threshold=0.1 - EM\", {\n skip(\"Not a bug: susieR2.0 intentionally skips the check_null_threshold V-zeroing step for EM (see R/single_effect_regression.R:169 and stephenslab/mvsusieR#26). The check would zero V without recomputing the posterior, creating an inconsistent (q, V) pair that can decrease the ELBO. Since dev ignores check_null_threshold for EM, this test cannot match a reference that always applies the check.\")\n skip_if_no_reference()\n\n set.seed(14)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n check_null_threshold = 0.1,\n estimate_prior_method = \"EM\",\n estimate_residual_variance = TRUE\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with check_null_threshold=0.1 - simple\", {\n skip_if_no_reference()\n\n set.seed(14)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n check_null_threshold = 0.1,\n estimate_prior_method = \"simple\",\n estimate_residual_variance = TRUE\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\n# =============================================================================\n# Part 11: intercept_value parameter\n# =============================================================================\n\ntest_that(\"susie_rss_lambda() matches reference with intercept_value=0.5 - optim\", {\n skip_if_no_reference()\n\n set.seed(15)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, intercept_value = 0.5, estimate_prior_method = \"optim\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with intercept_value=0.5 - EM\", {\n skip_if_no_reference()\n\n set.seed(15)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, intercept_value = 0.5, estimate_prior_method = \"EM\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with intercept_value=0.5 - simple\", {\n skip_if_no_reference()\n\n set.seed(15)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, lambda = 1e-5, intercept_value = 0.5, estimate_prior_method = \"simple\", estimate_residual_variance = TRUE)\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\n# =============================================================================\n# Part 12: Combined parameter tests\n# =============================================================================\n\ntest_that(\"susie_rss_lambda() matches reference with combined params - optim\", {\n skip_if_no_reference()\n\n set.seed(16)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Test combination: estimate_prior_variance=FALSE, estimate_residual_variance=FALSE\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with combined params - EM\", {\n skip_if_no_reference()\n\n set.seed(16)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n\ntest_that(\"susie_rss_lambda() matches reference with combined params - simple\", {\n skip_if_no_reference()\n\n set.seed(16)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, L = 10, lambda = 1e-5,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_rss_lambda\", args, tolerance = 1e-5, ref_func_name = \"susie_rss\")\n})\n" }, { "path": "tests/testthat/reference/test_susie_rss_reference.R", "content": "# Source helper functions\nsource(file.path(\"..\", \"helper_reference.R\"), local = TRUE)\n\ncontext(\"susie_rss reference comparison\")\n\n# =============================================================================\n# REFERENCE TESTS FOR susie_rss() with lambda = 0\n# =============================================================================\n#\n# These tests compare the new susie_rss() implementation (lambda = 0) against\n# the reference package susie_rss() from stephenslab/susieR@1f9166c\n#\n# Tests cover all major parameters with all three prior variance optimization\n# methods: \"optim\", \"EM\", \"simple\"\n\n# =============================================================================\n# Part 1: Basic Input Formats\n# =============================================================================\n# Test that different input formats (z, bhat/shat) work correctly\n\ntest_that(\"susie_rss() matches reference with z-scores - optim\", {\n skip_if_no_reference()\n\n set.seed(1)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Compute z-scores and R using standard approach\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with z-scores - EM\", {\n skip_if_no_reference()\n\n set.seed(1)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with z-scores - simple\", {\n skip_if_no_reference()\n\n set.seed(1)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with bhat/shat - optim\", {\n skip_if_no_reference()\n\n set.seed(2)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Compute bhat, shat and R\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n bhat <- ss$betahat\n shat <- ss$sebetahat\n\n args <- list(bhat = bhat, shat = shat, R = R, n = n, L = 10, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with bhat/shat - EM\", {\n skip_if_no_reference()\n\n set.seed(2)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n bhat <- ss$betahat\n shat <- ss$sebetahat\n\n args <- list(bhat = bhat, shat = shat, R = R, n = n, L = 10, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with bhat/shat - simple\", {\n skip_if_no_reference()\n\n set.seed(2)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n bhat <- ss$betahat\n shat <- ss$sebetahat\n\n args <- list(bhat = bhat, shat = shat, R = R, n = n, L = 10, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 2: Sample size n parameter\n# =============================================================================\n# Test with n provided vs. not provided (large n approximation)\n\ntest_that(\"susie_rss() matches reference with n provided - optim\", {\n skip_if_no_reference()\n\n set.seed(3)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with n provided - EM\", {\n skip_if_no_reference()\n\n set.seed(3)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with n provided - simple\", {\n skip_if_no_reference()\n\n set.seed(3)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference without n - optim\", {\n skip_if_no_reference()\n\n set.seed(4)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Note: n not provided - uses large n approximation\n args <- list(z = z, R = R, L = 10, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference without n - EM\", {\n skip_if_no_reference()\n\n set.seed(4)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference without n - simple\", {\n skip_if_no_reference()\n\n set.seed(4)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, L = 10, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 3: Different L values\n# =============================================================================\n\ntest_that(\"susie_rss() matches reference with different L values - optim\", {\n skip_if_no_reference()\n\n set.seed(5)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Test L=1\n args1 <- list(z = z, R = R, n = n, L = 1, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_rss\", args1, tolerance = 1e-5)\n\n # Test L=5\n args5 <- list(z = z, R = R, n = n, L = 5, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_rss\", args5, tolerance = 1e-5)\n\n # Test L=20\n args20 <- list(z = z, R = R, n = n, L = 20, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_rss\", args20, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with different L values - EM\", {\n skip_if_no_reference()\n\n set.seed(5)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Test L=1\n args1 <- list(z = z, R = R, n = n, L = 1, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_rss\", args1, tolerance = 1e-5)\n\n # Test L=5\n args5 <- list(z = z, R = R, n = n, L = 5, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_rss\", args5, tolerance = 1e-5)\n\n # Test L=20\n args20 <- list(z = z, R = R, n = n, L = 20, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_rss\", args20, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with different L values - simple\", {\n skip_if_no_reference()\n\n set.seed(5)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Test L=1\n args1 <- list(z = z, R = R, n = n, L = 1, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_rss\", args1, tolerance = 1e-5)\n\n # Test L=5\n args5 <- list(z = z, R = R, n = n, L = 5, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_rss\", args5, tolerance = 1e-5)\n\n # Test L=20\n args20 <- list(z = z, R = R, n = n, L = 20, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_rss\", args20, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 4: estimate_prior_variance parameter\n# =============================================================================\n\ntest_that(\"susie_rss() matches reference with estimate_prior_variance=FALSE - optim\", {\n skip_if_no_reference()\n\n set.seed(6)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n estimate_prior_variance = FALSE,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with estimate_prior_variance=FALSE - EM\", {\n skip_if_no_reference()\n\n set.seed(6)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n estimate_prior_variance = FALSE,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with estimate_prior_variance=FALSE - simple\", {\n skip_if_no_reference()\n\n set.seed(6)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n estimate_prior_variance = FALSE,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 5: estimate_residual_variance parameter\n# =============================================================================\n\ntest_that(\"susie_rss() matches reference with estimate_residual_variance=TRUE - optim\", {\n skip_if_no_reference()\n\n set.seed(7)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n estimate_residual_variance = TRUE,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with estimate_residual_variance=TRUE - EM\", {\n skip_if_no_reference()\n\n set.seed(7)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n estimate_residual_variance = TRUE,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with estimate_residual_variance=TRUE - simple\", {\n skip_if_no_reference()\n\n set.seed(7)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n estimate_residual_variance = TRUE,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with estimate_residual_variance=FALSE - optim\", {\n skip_if_no_reference()\n\n set.seed(8)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with estimate_residual_variance=FALSE - EM\", {\n skip_if_no_reference()\n\n set.seed(8)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with estimate_residual_variance=FALSE - simple\", {\n skip_if_no_reference()\n\n set.seed(8)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n estimate_residual_variance = FALSE,\n residual_variance = 1.0,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 6: prior_weights\n# =============================================================================\n\ntest_that(\"susie_rss() matches reference with prior_weights - optim\", {\n skip_if_no_reference()\n\n set.seed(9)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Use non-uniform prior weights\n prior_weights <- runif(p)\n prior_weights <- prior_weights / sum(prior_weights)\n args <- list(z = z, R = R, n = n, L = 10, prior_weights = prior_weights, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with prior_weights - EM\", {\n skip_if_no_reference()\n\n set.seed(9)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Use non-uniform prior weights\n prior_weights <- runif(p)\n prior_weights <- prior_weights / sum(prior_weights)\n args <- list(z = z, R = R, n = n, L = 10, prior_weights = prior_weights, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with prior_weights - simple\", {\n skip_if_no_reference()\n\n set.seed(9)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Use non-uniform prior weights\n prior_weights <- runif(p)\n prior_weights <- prior_weights / sum(prior_weights)\n args <- list(z = z, R = R, n = n, L = 10, prior_weights = prior_weights, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 7: scaled_prior_variance\n# =============================================================================\n\ntest_that(\"susie_rss() matches reference with scaled_prior_variance - optim\", {\n skip_if_no_reference()\n\n set.seed(10)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, scaled_prior_variance = 0.5, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with scaled_prior_variance - EM\", {\n skip_if_no_reference()\n\n set.seed(10)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, scaled_prior_variance = 0.5, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with scaled_prior_variance - simple\", {\n skip_if_no_reference()\n\n set.seed(10)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, scaled_prior_variance = 0.5, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 8: var_y parameter\n# =============================================================================\n\ntest_that(\"susie_rss() matches reference with var_y - optim\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n # Compute bhat, shat and R\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n bhat <- ss$betahat\n shat <- ss$sebetahat\n var_y <- var(y)\n\n args <- list(bhat = bhat, shat = shat, R = R, n = n, L = 10, var_y = var_y, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with var_y - EM\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n bhat <- ss$betahat\n shat <- ss$sebetahat\n var_y <- var(y)\n\n args <- list(bhat = bhat, shat = shat, R = R, n = n, L = 10, var_y = var_y, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with var_y - simple\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n bhat <- ss$betahat\n shat <- ss$sebetahat\n var_y <- var(y)\n\n args <- list(bhat = bhat, shat = shat, R = R, n = n, L = 10, var_y = var_y, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 9: coverage and min_abs_corr\n# =============================================================================\n\ntest_that(\"susie_rss() matches reference with coverage=0.99 - optim\", {\n skip_if_no_reference()\n\n set.seed(12)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, coverage = 0.99, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with coverage=0.99 - EM\", {\n skip_if_no_reference()\n\n set.seed(12)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, coverage = 0.99, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with coverage=0.99 - simple\", {\n skip_if_no_reference()\n\n set.seed(12)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, coverage = 0.99, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with min_abs_corr=0.7 - optim\", {\n skip_if_no_reference()\n\n set.seed(13)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, min_abs_corr = 0.7, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with min_abs_corr=0.7 - EM\", {\n skip_if_no_reference()\n\n set.seed(13)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, min_abs_corr = 0.7, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with min_abs_corr=0.7 - simple\", {\n skip_if_no_reference()\n\n set.seed(13)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(z = z, R = R, n = n, L = 10, min_abs_corr = 0.7, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 10: prior_tol parameter\n# =============================================================================\n\ntest_that(\"susie_rss() matches reference with prior_tol=1e-5 - optim\", {\n skip(\"Intentional change: susieR2.0 adds a post-convergence trim_null_effects() pass that zeros model$V entries where V < prior_tol. The reference uses prior_tol only to filter PIPs; it never zeros V. The args here use prior_tol=0.1 (despite the test name), which triggers the trim on dev and produces a V / alpha / mu divergence above 1e-5.\")\n skip_if_no_reference()\n\n set.seed(15)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Disable check_null_threshold so we can see prior_tol effects\n args <- list(\n z = z, R = R, n = n, L = 10,\n prior_tol = 0.1,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with prior_tol=1e-5 - EM\", {\n skip(\"Intentional change: susieR2.0 adds a post-convergence trim_null_effects() pass that zeros model$V entries where V < prior_tol. The reference uses prior_tol only to filter PIPs; it never zeros V. Triggers a V / alpha / mu divergence above 1e-5.\")\n skip_if_no_reference()\n\n set.seed(15)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n prior_tol = 0.1,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with prior_tol=1e-5 - simple\", {\n skip_if_no_reference()\n\n set.seed(15)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n prior_tol = 0.1,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 11: check_null_threshold parameter\n# =============================================================================\n\ntest_that(\"susie_rss() matches reference with check_null_threshold=0.1 - optim\", {\n skip_if_no_reference()\n\n set.seed(16)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n check_null_threshold = 0.1,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with check_null_threshold=0.1 - EM\", {\n skip(\"Not a bug: susieR2.0 intentionally skips the check_null_threshold V-zeroing step for EM (see R/single_effect_regression.R:169 and stephenslab/mvsusieR#26). The check would zero V without recomputing the posterior, creating an inconsistent (q, V) pair that can decrease the ELBO. Since dev ignores check_null_threshold for EM, this test cannot match a reference that always applies the check.\")\n skip_if_no_reference()\n\n set.seed(16)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n check_null_threshold = 0.1,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with check_null_threshold=0.1 - simple\", {\n skip_if_no_reference()\n\n set.seed(16)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n check_null_threshold = 0.1,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\n# =============================================================================\n# Part 11: MAF filtering\n# =============================================================================\n\ntest_that(\"susie_rss() matches reference with maf filtering - optim\", {\n skip_if_no_reference()\n\n set.seed(17)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Simulate minor allele frequencies\n maf <- runif(p, 0.05, 0.5)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n maf = maf, maf_thresh = 0.1,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with maf filtering - EM\", {\n skip_if_no_reference()\n\n set.seed(17)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Simulate minor allele frequencies\n maf <- runif(p, 0.05, 0.5)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n maf = maf, maf_thresh = 0.1,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n\ntest_that(\"susie_rss() matches reference with maf filtering - simple\", {\n skip_if_no_reference()\n\n set.seed(17)\n n <- 500\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[c(5, 10, 20)] <- c(0.5, 0.4, 0.3)\n y <- as.vector(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n ss <- univariate_regression(X, y)\n R <- with(input_ss, cov2cor(XtX))\n R <- (R + t(R)) / 2\n z <- with(ss, betahat / sebetahat)\n\n # Simulate minor allele frequencies\n maf <- runif(p, 0.05, 0.5)\n\n args <- list(\n z = z, R = R, n = n, L = 10,\n maf = maf, maf_thresh = 0.1,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_rss\", args, tolerance = 1e-5)\n})\n" }, { "path": "tests/testthat/reference/test_susie_ss_reference.R", "content": "# Source helper functions\nsource(file.path(\"..\", \"helper_reference.R\"), local = TRUE)\n\ncontext(\"susie_ss reference comparison\")\n\n# =============================================================================\n# REFERENCE TESTS FOR susie_ss()\n# =============================================================================\n#\n# These tests compare the new susie_ss() implementation against the reference\n# susie_suff_stat() from stephenslab/susieR@1f9166c\n#\n# Tests cover all major parameters and their combinations with all three\n# prior variance optimization methods: \"optim\", \"EM\", \"simple\"\n\n# =============================================================================\n# Part 1: Basic Parameter Tests\n# =============================================================================\n\ntest_that(\"susie_ss() matches reference with default parameters - optim\", {\n skip_if_no_reference()\n\n set.seed(1)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with default parameters - EM\", {\n skip_if_no_reference()\n\n set.seed(1)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with default parameters - simple\", {\n skip_if_no_reference()\n\n set.seed(1)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\n# =============================================================================\n# Part 2: X_colmeans and y_mean (intercept estimation)\n# =============================================================================\n\ntest_that(\"susie_ss() matches reference with X_colmeans and y_mean - optim\", {\n skip_if_no_reference()\n\n set.seed(2)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_colmeans <- colMeans(X)\n y_mean <- mean(y)\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - y_mean\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n X_colmeans = X_colmeans, y_mean = y_mean,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with X_colmeans and y_mean - EM\", {\n skip_if_no_reference()\n\n set.seed(2)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_colmeans <- colMeans(X)\n y_mean <- mean(y)\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - y_mean\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n X_colmeans = X_colmeans, y_mean = y_mean,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with X_colmeans and y_mean - simple\", {\n skip_if_no_reference()\n\n set.seed(2)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_colmeans <- colMeans(X)\n y_mean <- mean(y)\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - y_mean\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n X_colmeans = X_colmeans, y_mean = y_mean,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\n# =============================================================================\n# Part 3: standardize parameter\n# =============================================================================\n\ntest_that(\"susie_ss() matches reference with standardize=FALSE - optim\", {\n skip_if_no_reference()\n\n set.seed(3)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n standardize = FALSE, estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with standardize=FALSE - EM\", {\n skip_if_no_reference()\n\n set.seed(3)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n standardize = FALSE, estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with standardize=FALSE - simple\", {\n skip_if_no_reference()\n\n set.seed(3)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n standardize = FALSE, estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\n# =============================================================================\n# Part 4: estimate_prior_variance=FALSE\n# =============================================================================\n\ntest_that(\"susie_ss() matches reference with estimate_prior_variance=FALSE - optim\", {\n skip_if_no_reference()\n\n set.seed(4)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n estimate_prior_variance = FALSE, estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with estimate_prior_variance=FALSE - EM\", {\n skip_if_no_reference()\n\n set.seed(4)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n estimate_prior_variance = FALSE, estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with estimate_prior_variance=FALSE - simple\", {\n skip_if_no_reference()\n\n set.seed(4)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n estimate_prior_variance = FALSE, estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\n# =============================================================================\n# Part 5: estimate_residual_variance parameter\n# =============================================================================\n\ntest_that(\"susie_ss() matches reference with estimate_residual_variance=FALSE - optim\", {\n skip_if_no_reference()\n\n set.seed(5)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n estimate_residual_variance = FALSE, residual_variance = 1.0,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with estimate_residual_variance=FALSE - EM\", {\n skip_if_no_reference()\n\n set.seed(5)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n estimate_residual_variance = FALSE, residual_variance = 1.0,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with estimate_residual_variance=FALSE - simple\", {\n skip_if_no_reference()\n\n set.seed(5)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n estimate_residual_variance = FALSE, residual_variance = 1.0,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\n# =============================================================================\n# Part 6: Different L values\n# =============================================================================\n\ntest_that(\"susie_ss() matches reference with different L values - optim\", {\n skip_if_no_reference()\n\n set.seed(6)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Test L=1\n args1 <- list(XtX = XtX, Xty = Xty, yty = yty, n = n, L = 1, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_ss\", args1, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n\n # Test L=5\n args5 <- list(XtX = XtX, Xty = Xty, yty = yty, n = n, L = 5, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_ss\", args5, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n\n # Test L=20\n args20 <- list(XtX = XtX, Xty = Xty, yty = yty, n = n, L = 20, estimate_prior_method = \"optim\")\n compare_to_reference(\"susie_ss\", args20, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with different L values - EM\", {\n skip_if_no_reference()\n\n set.seed(6)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Test L=1\n args1 <- list(XtX = XtX, Xty = Xty, yty = yty, n = n, L = 1, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_ss\", args1, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n\n # Test L=5\n args5 <- list(XtX = XtX, Xty = Xty, yty = yty, n = n, L = 5, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_ss\", args5, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n\n # Test L=20\n args20 <- list(XtX = XtX, Xty = Xty, yty = yty, n = n, L = 20, estimate_prior_method = \"EM\")\n compare_to_reference(\"susie_ss\", args20, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with different L values - simple\", {\n skip_if_no_reference()\n\n set.seed(6)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Test L=1\n args1 <- list(XtX = XtX, Xty = Xty, yty = yty, n = n, L = 1, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_ss\", args1, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n\n # Test L=5\n args5 <- list(XtX = XtX, Xty = Xty, yty = yty, n = n, L = 5, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_ss\", args5, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n\n # Test L=20\n args20 <- list(XtX = XtX, Xty = Xty, yty = yty, n = n, L = 20, estimate_prior_method = \"simple\")\n compare_to_reference(\"susie_ss\", args20, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\n# =============================================================================\n# Part 7: prior_weights\n# =============================================================================\n\ntest_that(\"susie_ss() matches reference with prior_weights - optim\", {\n skip_if_no_reference()\n\n set.seed(7)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Use non-uniform prior weights\n prior_weights <- runif(p)\n prior_weights <- prior_weights / sum(prior_weights)\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n prior_weights = prior_weights, estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with prior_weights - EM\", {\n skip_if_no_reference()\n\n set.seed(7)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Use non-uniform prior weights\n prior_weights <- runif(p)\n prior_weights <- prior_weights / sum(prior_weights)\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n prior_weights = prior_weights, estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with prior_weights - simple\", {\n skip_if_no_reference()\n\n set.seed(7)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Use non-uniform prior weights\n prior_weights <- runif(p)\n prior_weights <- prior_weights / sum(prior_weights)\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n prior_weights = prior_weights, estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\n# =============================================================================\n# Part 8: scaled_prior_variance\n# =============================================================================\n\ntest_that(\"susie_ss() matches reference with scaled_prior_variance - optim\", {\n skip_if_no_reference()\n\n set.seed(8)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n scaled_prior_variance = 0.5, estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with scaled_prior_variance - EM\", {\n skip_if_no_reference()\n\n set.seed(8)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n scaled_prior_variance = 0.5, estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with scaled_prior_variance - simple\", {\n skip_if_no_reference()\n\n set.seed(8)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n scaled_prior_variance = 0.5, estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\n# =============================================================================\n# Part 9: coverage, min_abs_corr, and n_purity\n# =============================================================================\n\ntest_that(\"susie_ss() matches reference with coverage=0.99 - optim\", {\n skip_if_no_reference()\n\n set.seed(9)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n coverage = 0.99, estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with coverage=0.99 - EM\", {\n skip_if_no_reference()\n\n set.seed(9)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n coverage = 0.99, estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with coverage=0.99 - simple\", {\n skip_if_no_reference()\n\n set.seed(9)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n coverage = 0.99, estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with min_abs_corr=0.7 - optim\", {\n skip_if_no_reference()\n\n set.seed(10)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n min_abs_corr = 0.7, estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with min_abs_corr=0.7 - EM\", {\n skip_if_no_reference()\n\n set.seed(10)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n min_abs_corr = 0.7, estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with min_abs_corr=0.7 - simple\", {\n skip_if_no_reference()\n\n set.seed(10)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n min_abs_corr = 0.7, estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with n_purity=3 - optim\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Set seed before calling to ensure same variant selection\n set.seed(999)\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n n_purity = 3, estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with n_purity=3 - EM\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Set seed before calling to ensure same variant selection\n set.seed(999)\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n n_purity = 3, estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with n_purity=3 - simple\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Set seed before calling to ensure same variant selection\n set.seed(999)\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n n_purity = 3, estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\n# =============================================================================\n# Part 10: Combined parameter variations\n# =============================================================================\n\ntest_that(\"susie_ss() matches reference with combined parameters - optim\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Test combination: standardize=FALSE, estimate_prior_variance=FALSE\n args1 <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n standardize = FALSE, estimate_prior_variance = FALSE,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args1, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n\n # Test combination: estimate_prior_variance=FALSE, estimate_residual_variance=FALSE\n args2 <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n estimate_prior_variance = FALSE, estimate_residual_variance = FALSE,\n residual_variance = 1.0, estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args2, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with combined parameters - EM\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Test combination: standardize=FALSE, estimate_prior_variance=FALSE\n args1 <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n standardize = FALSE, estimate_prior_variance = FALSE,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args1, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n\n # Test combination: estimate_prior_variance=FALSE, estimate_residual_variance=FALSE\n args2 <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n estimate_prior_variance = FALSE, estimate_residual_variance = FALSE,\n residual_variance = 1.0, estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args2, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with combined parameters - simple\", {\n skip_if_no_reference()\n\n set.seed(11)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Test combination: standardize=FALSE, estimate_prior_variance=FALSE\n args1 <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n standardize = FALSE, estimate_prior_variance = FALSE,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args1, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n\n # Test combination: estimate_prior_variance=FALSE, estimate_residual_variance=FALSE\n args2 <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n estimate_prior_variance = FALSE, estimate_residual_variance = FALSE,\n residual_variance = 1.0, estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args2, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\n# =============================================================================\n# Part 11: prior_tol parameter\n# =============================================================================\n\ntest_that(\"susie_ss() matches reference with prior_tol=1e-5 - optim\", {\n skip_if_no_reference()\n\n set.seed(12)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n prior_tol = 0.1,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with prior_tol=0.1 - EM\", {\n skip(\"Intentional change: susieR2.0 adds a post-convergence trim_null_effects() pass that zeros model$V entries where V < prior_tol. The reference uses prior_tol only to filter PIPs; it never zeros V. Triggers a V / alpha / mu divergence above 1e-5.\")\n skip_if_no_reference()\n\n set.seed(12)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n prior_tol = 0.1,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with prior_tol=0.1 - simple\", {\n skip_if_no_reference()\n\n set.seed(12)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n prior_tol = 0.1,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\n# =============================================================================\n# Part 12: check_null_threshold parameter\n# =============================================================================\n\ntest_that(\"susie_ss() matches reference with check_null_threshold=0.1 - optim\", {\n skip_if_no_reference()\n\n set.seed(13)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n check_null_threshold = 0.1, estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with check_null_threshold=0.1 - EM\", {\n skip(\"Not a bug: susieR2.0 intentionally skips the check_null_threshold V-zeroing step for EM (see R/single_effect_regression.R:169 and stephenslab/mvsusieR#26). The check would zero V without recomputing the posterior, creating an inconsistent (q, V) pair that can decrease the ELBO. Since dev ignores check_null_threshold for EM, this test cannot match a reference that always applies the check.\")\n skip_if_no_reference()\n\n set.seed(13)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n check_null_threshold = 0.1, estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with check_null_threshold=0.1 - simple\", {\n skip_if_no_reference()\n\n set.seed(13)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n check_null_threshold = 0.1, estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\n# =============================================================================\n# Part 13: maf and maf_thresh parameters\n# =============================================================================\n\ntest_that(\"susie_ss() matches reference with maf filtering - optim\", {\n skip_if_no_reference()\n\n set.seed(14)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Simulate minor allele frequencies\n maf <- runif(p, 0.05, 0.5)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n maf = maf, maf_thresh = 0.1,\n estimate_prior_method = \"optim\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with maf filtering - EM\", {\n skip_if_no_reference()\n\n set.seed(14)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Simulate minor allele frequencies\n maf <- runif(p, 0.05, 0.5)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n maf = maf, maf_thresh = 0.1,\n estimate_prior_method = \"EM\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n\ntest_that(\"susie_ss() matches reference with maf filtering - simple\", {\n skip_if_no_reference()\n\n set.seed(14)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:4] <- c(2, 3, -2, 1.5)\n y <- as.vector(X %*% beta + rnorm(n))\n\n X_centered <- scale(X, center = TRUE, scale = FALSE)\n y_centered <- y - mean(y)\n XtX <- crossprod(X_centered)\n Xty <- crossprod(X_centered, y_centered)\n yty <- sum(y_centered^2)\n\n # Simulate minor allele frequencies\n maf <- runif(p, 0.05, 0.5)\n\n args <- list(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 10,\n maf = maf, maf_thresh = 0.1,\n estimate_prior_method = \"simple\"\n )\n compare_to_reference(\"susie_ss\", args, tolerance = 1e-5, ref_func_name = \"susie_suff_stat\")\n})\n" }, { "path": "tests/testthat/test_X_centering.R", "content": "# Test that susie_rss gives equivalent results for raw, centered,\n# and standardized X inputs.\n\ncontext(\"X centering equivalence\")\n\ntest_that(\"Full-rank X: raw, centered, standardized give same results\", {\n set.seed(1)\n n <- 200\n p <- 50\n\n # Generate X with non-zero column means (raw)\n X_raw <- matrix(rnorm(n * p, mean = 5, sd = 2), n, p)\n X_raw[, 1:3] <- X_raw[, 1:3] + 10 # make some columns have large means\n\n # Centered and standardized versions\n X_centered <- scale(X_raw, center = TRUE, scale = FALSE)\n X_standardized <- scale(X_raw, center = TRUE, scale = TRUE)\n\n # Generate z-scores from centered X\n beta_true <- rep(0, p)\n beta_true[c(5, 15, 30)] <- c(0.5, -0.3, 0.4)\n y <- X_centered %*% beta_true + rnorm(n)\n z <- as.vector(sqrt(n) * cor(X_centered, y))\n\n # Fit with all three forms of X (full-rank path: nrow >= ncol)\n fit_raw <- susie_rss(z = z, X = X_raw, n = n, max_iter = 50)\n fit_cent <- susie_rss(z = z, X = X_centered, n = n, max_iter = 50)\n fit_std <- susie_rss(z = z, X = X_standardized, n = n, max_iter = 50)\n\n # All should produce identical results (full-rank path uses safe_cor\n # which centers internally, but we also center before calling safe_cor)\n expect_equal(fit_raw$elbo, fit_cent$elbo, tolerance = 1e-10)\n expect_equal(fit_raw$elbo, fit_std$elbo, tolerance = 1e-10)\n expect_equal(fit_raw$pip, fit_cent$pip, tolerance = 1e-10)\n expect_equal(fit_raw$pip, fit_std$pip, tolerance = 1e-10)\n})\n\ntest_that(\"Low-rank X: raw and centered give identical results\", {\n set.seed(2)\n n <- 200\n p <- 500\n B <- 100 # reference factor rows < p, triggers low-rank path\n\n # Generate full X and z-scores\n X_full <- matrix(rnorm(n * p), n, p)\n beta_true <- rep(0, p)\n beta_true[c(10, 50, 200)] <- c(0.5, -0.3, 0.4)\n y <- X_full %*% beta_true + rnorm(n)\n z <- as.vector(sqrt(n) * cor(X_full, y))\n\n # Create a reference factor matrix (B x p, B < p)\n S <- matrix(rnorm(B * n) / sqrt(B), B, n)\n X_ref <- S %*% X_full # B x p reference factor\n\n # Add offset to create \"raw\" version with non-zero column means\n X_ref_raw <- X_ref + 10\n # Manually center (avoid scale() attributes)\n X_ref_centered <- X_ref_raw - rep(colMeans(X_ref_raw), each = B)\n\n # Fit with both forms (low-rank path: nrow < ncol)\n fit_raw <- susie_rss(z = z, X = X_ref_raw, n = n, L = 5, max_iter = 50)\n fit_cent <- susie_rss(z = z, X = X_ref_centered, n = n, L = 5, max_iter = 50)\n\n # Raw and centered should give identical results\n expect_equal(fit_raw$elbo, fit_cent$elbo, tolerance = 1e-10)\n expect_equal(fit_raw$pip, fit_cent$pip, tolerance = 1e-10)\n})\n\ntest_that(\"Low-rank X: raw vs centered give same results (no n)\", {\n set.seed(3)\n p <- 300\n B <- 80\n\n # Generate reference factor matrix with non-zero means\n X_raw <- matrix(rnorm(B * p, mean = 3), B, p)\n X_centered <- X_raw - rep(colMeans(X_raw), each = B)\n\n z <- rnorm(p)\n z[c(5, 100)] <- c(4, -3.5)\n\n fit_raw <- susie_rss(z = z, X = X_raw, L = 5, max_iter = 30)\n fit_cent <- susie_rss(z = z, X = X_centered, L = 5, max_iter = 30)\n\n expect_equal(fit_raw$elbo, fit_cent$elbo, tolerance = 1e-10)\n expect_equal(fit_raw$pip, fit_cent$pip, tolerance = 1e-10)\n})\n\ntest_that(\"Low-rank X with lambda: raw and centered give same results\", {\n set.seed(4)\n p <- 200\n B <- 50\n\n X_raw <- matrix(rnorm(B * p, mean = 2, sd = 3), B, p)\n X_centered <- X_raw - rep(colMeans(X_raw), each = B)\n\n z <- rnorm(p)\n z[c(10, 80)] <- c(5, -4)\n\n fit_raw <- susie_rss_lambda(z = z, X = X_raw, lambda = 0.1, L = 5, max_iter = 30)\n fit_cent <- susie_rss_lambda(z = z, X = X_centered, lambda = 0.1, L = 5, max_iter = 30)\n\n expect_equal(fit_raw$elbo, fit_cent$elbo, tolerance = 1e-10)\n expect_equal(fit_raw$pip, fit_cent$pip, tolerance = 1e-10)\n})\n\ntest_that(\"Low-rank X: large offset does not break fitting\", {\n # Verify that adding a large constant offset to X columns does not\n # break the fitting (because centering removes it).\n set.seed(5)\n p <- 200\n B <- 80\n\n X_centered <- matrix(rnorm(B * p), B, p)\n X_offset <- X_centered + 1000 # huge offset\n\n z <- rnorm(p)\n z[c(10, 80)] <- c(5, -4)\n\n # Both should give identical results\n fit_cent <- susie_rss(z = z, X = X_centered, n = 500, L = 5, max_iter = 50)\n fit_off <- susie_rss(z = z, X = X_offset, n = 500, L = 5, max_iter = 50)\n\n # Tolerance accounts for floating-point cancellation when subtracting\n # the large offset (1000 * machine_eps ≈ 2e-13, amplified by iterations)\n expect_equal(fit_cent$elbo, fit_off$elbo, tolerance = 1e-6)\n expect_equal(fit_cent$pip, fit_off$pip, tolerance = 1e-6)\n})\n" }, { "path": "tests/testthat/test_coef_predict.R", "content": "context(\"coef and predict S3 methods\")\n\n# =============================================================================\n# COEF.SUSIE - EXTRACT COEFFICIENTS\n# =============================================================================\n\ntest_that(\"coef.susie returns correct format\", {\n set.seed(1)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n coefs <- coef(fit)\n\n expect_length(coefs, dat$p + 1)\n expect_type(coefs, \"double\")\n expect_named(coefs, NULL)\n})\n\ntest_that(\"coef.susie includes intercept as first element\", {\n set.seed(2)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n coefs <- coef(fit)\n\n expect_equal(coefs[1], fit$intercept)\n})\n\ntest_that(\"coef.susie computes coefficients correctly\", {\n set.seed(3)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n coefs <- coef(fit)\n\n expected <- c(fit$intercept,\n colSums(fit$alpha * fit$mu) / fit$X_column_scale_factors)\n expect_equal(coefs, expected)\n})\n\ntest_that(\"coef.susie handles intercept=FALSE\", {\n set.seed(4)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, intercept = FALSE, verbose = FALSE)\n\n coefs <- coef(fit)\n\n expect_equal(coefs[1], 0)\n})\n\ntest_that(\"coef.susie handles standardize=FALSE\", {\n set.seed(5)\n dat <- simulate_regression(n = 100, p = 50, k = 3, center = FALSE, scale = FALSE)\n fit <- susie(dat$X, dat$y, L = 5, standardize = FALSE, verbose = FALSE)\n\n coefs <- coef(fit)\n\n expect_length(coefs, dat$p + 1)\n expect_type(coefs, \"double\")\n})\n\n# =============================================================================\n# PREDICT.SUSIE - MAKE PREDICTIONS\n# =============================================================================\n\ntest_that(\"predict.susie with type='coefficients' returns coef\", {\n set.seed(6)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n pred_coef <- predict(fit, type = \"coefficients\")\n expected_coef <- coef(fit)\n\n expect_equal(pred_coef, expected_coef)\n})\n\ntest_that(\"predict.susie with type='coefficients' errors if newx provided\", {\n set.seed(7)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n newx <- matrix(rnorm(10 * 50), 10, 50)\n\n expect_error(\n predict(fit, newx = newx, type = \"coefficients\"),\n \"Do not supply newx\"\n )\n})\n\ntest_that(\"predict.susie without newx returns fitted values\", {\n set.seed(8)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n pred <- predict(fit, type = \"response\")\n\n expect_equal(pred, fit$fitted)\n expect_length(pred, dat$n)\n})\n\ntest_that(\"predict.susie with newx computes predictions correctly\", {\n set.seed(9)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n newx <- matrix(rnorm(20 * 50), 20, 50)\n newx <- scale(newx, center = TRUE, scale = TRUE)\n\n pred <- predict(fit, newx = newx, type = \"response\")\n\n expect_length(pred, 20)\n expect_type(pred, \"double\")\n\n coefs <- coef(fit)\n expected <- drop(fit$intercept + newx %*% coefs[-1])\n expect_equal(pred, expected)\n})\n\ntest_that(\"predict.susie handles intercept=FALSE with newx\", {\n set.seed(10)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, intercept = FALSE, verbose = FALSE)\n\n newx <- matrix(rnorm(20 * 50), 20, 50)\n newx <- scale(newx, center = TRUE, scale = TRUE)\n\n pred <- predict(fit, newx = newx)\n\n coefs <- coef(fit)\n expected <- drop(newx %*% coefs[-1])\n expect_equal(pred, expected)\n})\n\ntest_that(\"predict.susie with NA intercept warns and uses 0\", {\n set.seed(11)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n ss <- compute_summary_stats(dat$X, dat$y)\n fit <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5, verbose = FALSE)\n\n expect_true(is.na(fit$intercept))\n\n newx <- matrix(rnorm(20 * 50), 20, 50)\n newx <- scale(newx, center = TRUE, scale = TRUE)\n\n expect_message(\n pred <- predict(fit, newx = newx),\n \"intercept = 0\"\n )\n\n coefs <- coef(fit)\n expected <- drop(newx %*% coefs[-1])\n expect_equal(pred, expected)\n})\n\ntest_that(\"predict.susie default type is response\", {\n set.seed(12)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n pred1 <- predict(fit)\n pred2 <- predict(fit, type = \"response\")\n\n expect_equal(pred1, pred2)\n})\n\ntest_that(\"predict.susie works with single new observation\", {\n set.seed(13)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n newx <- matrix(rnorm(50), 1, 50)\n newx <- scale(newx, center = TRUE, scale = TRUE)\n\n pred <- predict(fit, newx = newx)\n\n expect_length(pred, 1)\n expect_type(pred, \"double\")\n})\n\ntest_that(\"predict.susie handles matrix vs data.frame newx\", {\n set.seed(14)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n newx_mat <- matrix(rnorm(20 * 50), 20, 50)\n newx_mat <- scale(newx_mat, center = TRUE, scale = TRUE)\n newx_df <- as.data.frame(newx_mat)\n\n pred_mat <- predict(fit, newx = newx_mat)\n pred_df <- predict(fit, newx = as.matrix(newx_df))\n\n expect_equal(pred_mat, pred_df)\n})\n\n# =============================================================================\n# INTEGRATION - COEF & PREDICT CONSISTENCY\n# =============================================================================\n\ntest_that(\"coef and predict work together consistently\", {\n set.seed(15)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n coefs <- coef(fit)\n newx <- matrix(rnorm(10 * 50), 10, 50)\n newx <- scale(newx, center = TRUE, scale = TRUE)\n\n pred_via_predict <- predict(fit, newx = newx)\n pred_via_coef <- drop(coefs[1] + newx %*% coefs[-1])\n\n expect_equal(pred_via_predict, pred_via_coef)\n})\n\ntest_that(\"coef.susie with all V=0 returns zero coefficients\", {\n set.seed(16)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n fit$V <- rep(0, 5)\n fit$alpha <- matrix(1/dat$p, 5, dat$p)\n fit$mu <- matrix(0, 5, dat$p)\n\n coefs <- coef(fit)\n\n expect_equal(coefs[-1], rep(0, dat$p))\n})\n\ntest_that(\"predict.susie with standardize=FALSE\", {\n set.seed(17)\n dat <- simulate_regression(n = 100, p = 50, k = 3, center = FALSE, scale = FALSE)\n fit <- susie(dat$X, dat$y, L = 5, standardize = FALSE, verbose = FALSE)\n\n pred <- predict(fit)\n\n expect_equal(pred, fit$fitted)\n expect_length(pred, dat$n)\n})\n" }, { "path": "tests/testthat/test_compute_marginal_bhat_shat.R", "content": "# compute_marginal_bhat_shat\n#\n# Per-position marginal OLS regression helper. Used by susieR's own\n# T = 1 SER path (cosmetic refactor candidate), mvsusieR's OLS\n# branch, and mfsusieR's prior init / SER. Three contracts:\n# 1. Vector-Y input is treated as a single-column matrix.\n# 2. predictor_weights override matches recompute from colSums(X^2).\n# 3. sigma2 supplied gives single-effect-residual Shat shape.\n\nset.seed(42)\nN <- 50\nJ <- 5\n\ntest_that(\"vector Y is treated as a single-column matrix\", {\n X <- matrix(rnorm(N * J), N, J)\n X <- scale(X, center = TRUE, scale = FALSE)\n y <- rnorm(N)\n\n out_vec <- compute_marginal_bhat_shat(X, y)\n out_mat <- compute_marginal_bhat_shat(X, matrix(y, ncol = 1))\n\n expect_equal(dim(out_vec$Bhat), c(J, 1L))\n expect_equal(dim(out_vec$Shat), c(J, 1L))\n expect_equal(out_vec$Bhat, out_mat$Bhat, tolerance = 0)\n expect_equal(out_vec$Shat, out_mat$Shat, tolerance = 0)\n})\n\ntest_that(\"matrix Y returns J x T Bhat / Shat\", {\n X <- matrix(rnorm(N * J), N, J)\n X <- scale(X, center = TRUE, scale = FALSE)\n Y <- matrix(rnorm(N * 3), N, 3)\n\n out <- compute_marginal_bhat_shat(X, Y)\n\n expect_equal(dim(out$Bhat), c(J, 3L))\n expect_equal(dim(out$Shat), c(J, 3L))\n})\n\ntest_that(\"predictor_weights override matches recompute from colSums(X^2)\", {\n X <- matrix(rnorm(N * J), N, J)\n X <- scale(X, center = TRUE, scale = FALSE)\n Y <- matrix(rnorm(N * 4), N, 4)\n\n pw <- colSums(X^2)\n\n out_default <- compute_marginal_bhat_shat(X, Y)\n out_override <- compute_marginal_bhat_shat(X, Y, predictor_weights = pw)\n\n expect_equal(out_default$Bhat, out_override$Bhat, tolerance = 0)\n expect_equal(out_default$Shat, out_override$Shat, tolerance = 0)\n})\n\ntest_that(\"sigma2 supplied gives single-effect-residual Shat (sqrt(sigma2 / pw))\", {\n X <- matrix(rnorm(N * J), N, J)\n X <- scale(X, center = TRUE, scale = FALSE)\n Y <- matrix(rnorm(N * 2), N, 2)\n\n out <- compute_marginal_bhat_shat(X, Y, sigma2 = 0.5)\n\n pw <- colSums(X^2)\n expected_shat <- matrix(sqrt(0.5 / pw), nrow = J, ncol = 2)\n expect_equal(out$Shat, expected_shat, tolerance = 0)\n})\n\ntest_that(\"Bhat = X'Y / colSums(X^2) for centred X\", {\n X <- matrix(rnorm(N * J), N, J)\n X <- scale(X, center = TRUE, scale = FALSE)\n Y <- matrix(rnorm(N * 3), N, 3)\n\n out <- compute_marginal_bhat_shat(X, Y)\n expected_bhat <- crossprod(X, Y) / colSums(X^2)\n\n expect_equal(out$Bhat, expected_bhat, tolerance = 0)\n})\n\ntest_that(\"Shat (no sigma2) matches per-column residual SD / sqrt(n-1)\", {\n X <- matrix(rnorm(N * J), N, J)\n X <- scale(X, center = TRUE, scale = FALSE)\n Y <- matrix(rnorm(N * 2), N, 2)\n\n out <- compute_marginal_bhat_shat(X, Y)\n\n # Manual recompute, no Rfast.\n Bhat <- crossprod(X, Y) / colSums(X^2)\n expected_shat <- matrix(0, nrow = J, ncol = 2)\n for (t in 1:2) {\n for (j in 1:J) {\n r <- Y[, t] - X[, j] * Bhat[j, t]\n expected_shat[j, t] <- sqrt(var(r))\n }\n }\n expected_shat <- expected_shat / sqrt(N - 1)\n\n expect_equal(out$Shat, expected_shat, tolerance = 1e-12)\n})\n" }, { "path": "tests/testthat/test_generic_methods.R", "content": "context(\"Generic methods infrastructure\")\n\n# =============================================================================\n# GENERIC EXISTENCE\n# =============================================================================\n\ntest_that(\"all core generics are defined\", {\n # Data initialization\n expect_true(exists(\"configure_data\", mode = \"function\"))\n expect_true(exists(\"get_var_y\", mode = \"function\"))\n\n # Model initialization\n expect_true(exists(\"initialize_susie_model\", mode = \"function\"))\n expect_true(exists(\"initialize_fitted\", mode = \"function\"))\n expect_true(exists(\"validate_prior\", mode = \"function\"))\n expect_true(exists(\"track_ibss_fit\", mode = \"function\"))\n\n # Single effect regression\n expect_true(exists(\"compute_residuals\", mode = \"function\"))\n expect_true(exists(\"compute_ser_statistics\", mode = \"function\"))\n expect_true(exists(\"SER_posterior_e_loglik\", mode = \"function\"))\n expect_true(exists(\"calculate_posterior_moments\", mode = \"function\"))\n expect_true(exists(\"compute_kl\", mode = \"function\"))\n expect_true(exists(\"get_ER2\", mode = \"function\"))\n expect_true(exists(\"Eloglik\", mode = \"function\"))\n expect_true(exists(\"loglik\", mode = \"function\"))\n expect_true(exists(\"neg_loglik\", mode = \"function\"))\n\n # Model updates\n expect_true(exists(\"update_fitted_values\", mode = \"function\"))\n expect_true(exists(\"update_variance_components\", mode = \"function\"))\n expect_true(exists(\"update_derived_quantities\", mode = \"function\"))\n\n # Output generation\n expect_true(exists(\"get_scale_factors\", mode = \"function\"))\n expect_true(exists(\"get_intercept\", mode = \"function\"))\n expect_true(exists(\"get_fitted\", mode = \"function\"))\n expect_true(exists(\"get_cs\", mode = \"function\"))\n expect_true(exists(\"get_variable_names\", mode = \"function\"))\n expect_true(exists(\"get_zscore\", mode = \"function\"))\n expect_true(exists(\"cleanup_model\", mode = \"function\"))\n})\n\n# =============================================================================\n# METHOD DISPATCH\n# =============================================================================\n\ntest_that(\"methods exist for all three data types\", {\n classes <- c(\"individual\", \"ss\", \"rss_lambda\")\n\n # Core generics that all data types must implement\n key_generics <- c(\n \"configure_data\",\n \"get_var_y\",\n \"initialize_susie_model\",\n \"initialize_fitted\",\n \"compute_residuals\",\n \"compute_ser_statistics\",\n \"SER_posterior_e_loglik\",\n \"calculate_posterior_moments\",\n \"get_ER2\",\n \"Eloglik\",\n \"loglik\",\n \"neg_loglik\",\n \"update_fitted_values\",\n \"update_variance_components\",\n \"get_scale_factors\",\n \"get_intercept\",\n \"get_fitted\",\n \"get_cs\",\n \"get_variable_names\",\n \"cleanup_model\"\n )\n\n for (generic in key_generics) {\n for (cls in classes) {\n method_name <- paste0(generic, \".\", cls)\n expect_true(exists(method_name, mode = \"function\"),\n info = paste(\"Missing method:\", method_name))\n }\n }\n})\n\ntest_that(\"default methods exist for optional generics\", {\n default_methods <- c(\n \"configure_data.default\",\n \"validate_prior.default\",\n \"track_ibss_fit.default\",\n \"compute_kl.default\",\n \"update_variance_components.default\",\n \"update_derived_quantities.default\",\n \"get_fitted.default\",\n \"get_zscore.default\",\n \"cleanup_model.default\"\n )\n\n for (method in default_methods) {\n expect_true(exists(method, mode = \"function\"),\n info = paste(\"Missing default method:\", method))\n }\n})\n\n# =============================================================================\n# DEFAULT METHOD BEHAVIOR\n# =============================================================================\n\ntest_that(\"default methods have sensible fallback behavior\", {\n data <- structure(list(n = 50, p = 10), class = \"test_class\")\n params <- list(track_fit = FALSE)\n model <- list(alpha = matrix(1/10, 3, 10), V = c(0.1, 0.2, 0.3), sigma2 = 1)\n\n # configure_data.default returns data unchanged\n expect_identical(configure_data.default(data, params), data)\n\n # validate_prior.default returns TRUE\n expect_true(validate_prior.default(data, params, model))\n\n # update_derived_quantities.default returns model unchanged\n expect_identical(update_derived_quantities.default(data, params, model), model)\n\n # get_fitted.default and get_zscore.default return NULL\n expect_null(get_fitted.default(data, params, model))\n expect_null(get_zscore.default(data, params, model))\n})\n\ntest_that(\"track_ibss_fit.default stores iteration snapshots\", {\n data <- structure(list(), class = \"test_class\")\n params <- list(track_fit = TRUE)\n model <- list(alpha = matrix(1/10, 3, 10), V = c(0.1, 0.2, 0.3), sigma2 = 1)\n tracking <- list()\n\n # Should store snapshot at iteration 1\n result <- track_ibss_fit.default(data, params, model, tracking, iter = 1, elbo = c(-Inf))\n expect_true(is.list(result[[1]]))\n expect_true(is.matrix(result[[1]]$alpha))\n expect_equal(result[[1]]$sigma2, 1)\n\n # Should store snapshot at iteration 2\n result2 <- track_ibss_fit.default(data, params, model, result, iter = 2, elbo = c(-Inf, 100))\n expect_equal(length(result2), 2)\n expect_equal(result2[[2]]$niter, 2)\n\n # With track_fit = FALSE, tracking stays empty\n params_no_track <- list(track_fit = FALSE)\n result3 <- track_ibss_fit.default(data, params_no_track, model, list(), iter = 1, elbo = c(-Inf))\n expect_equal(length(result3), 0)\n})\n\ntest_that(\"cleanup_model.default removes temporary fields\", {\n data <- structure(list(), class = \"test_class\")\n params <- list()\n model <- list(\n alpha = matrix(1/10, 3, 10),\n mu = matrix(0, 3, 10),\n sigma2 = 1,\n V = c(0.1, 0.2, 0.3),\n # Temporary fields to remove\n null_weight = 0,\n predictor_weights = rep(1/10, 10),\n residuals = rnorm(50),\n fitted_without_l = rnorm(50),\n runtime = list(prev_elbo = -100, prev_alpha = matrix(1/10, 3, 10), prev_pip_diff = 0.01)\n )\n\n result <- cleanup_model.default(data, params, model)\n\n # Keep core fields\n expect_true(\"alpha\" %in% names(result))\n expect_true(\"mu\" %in% names(result))\n expect_true(\"sigma2\" %in% names(result))\n expect_true(\"V\" %in% names(result))\n\n # Remove temporary fields\n expect_false(\"null_weight\" %in% names(result))\n expect_false(\"predictor_weights\" %in% names(result))\n expect_false(\"residuals\" %in% names(result))\n expect_false(\"fitted_without_l\" %in% names(result))\n expect_false(\"runtime\" %in% names(result))\n})\n\n# =============================================================================\n# DEFAULT METHOD ERROR MESSAGES\n# =============================================================================\n\ntest_that(\"get_var_y.default throws error for unimplemented class\", {\n data <- structure(list(y = rnorm(50)), class = \"unsupported_class\")\n\n expect_error(\n get_var_y.default(data),\n \"get_var_y: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"initialize_susie_model.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n params <- list(L = 5)\n\n expect_error(\n initialize_susie_model.default(data, params),\n \"initialize_susie_model: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"initialize_fitted.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n mat_init <- matrix(0, 5, 10)\n\n expect_error(\n initialize_fitted.default(data, mat_init),\n \"initialize_fitted: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"compute_residuals.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n params <- list()\n model <- list(alpha = matrix(1/10, 5, 10), V = rep(1, 5))\n l <- 1\n\n expect_error(\n compute_residuals.default(data, params, model, l),\n \"compute_residuals: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"compute_ser_statistics.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n params <- list()\n model <- list(alpha = matrix(1/10, 5, 10), residuals = rnorm(50))\n l <- 1\n\n expect_error(\n compute_ser_statistics.default(data, params, model, l),\n \"compute_ser_statistics: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"SER_posterior_e_loglik.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n params <- list()\n model <- list(alpha = matrix(1/10, 5, 10), lbf_variable = matrix(0, 5, 10))\n l <- 1\n\n expect_error(\n SER_posterior_e_loglik.default(data, params, model, l),\n \"SER_posterior_e_loglik: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"calculate_posterior_moments.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n params <- list()\n model <- list(alpha = matrix(1/10, 5, 10))\n V <- 1.0\n\n expect_error(\n calculate_posterior_moments.default(data, params, model, V),\n \"calculate_posterior_moments: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"get_ER2.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n model <- list(alpha = matrix(1/10, 5, 10), sigma2 = 1)\n\n expect_error(\n get_ER2.default(data, model),\n \"get_ER2: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"Eloglik.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n model <- list(alpha = matrix(1/10, 5, 10), sigma2 = 1)\n\n expect_error(\n Eloglik.default(data, model),\n \"Eloglik: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"loglik.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n params <- list()\n model <- list(alpha = matrix(1/10, 5, 10), sigma2 = 1)\n V <- 1.0\n ser_stats <- list(betahat = rnorm(10), shat2 = rep(1, 10))\n\n expect_error(\n loglik.default(data, params, model, V, ser_stats),\n \"loglik: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"neg_loglik.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n params <- list()\n model <- list(alpha = matrix(1/10, 5, 10), sigma2 = 1)\n V_param <- 0.0 # log scale\n ser_stats <- list(betahat = rnorm(10), shat2 = rep(1, 10))\n\n expect_error(\n neg_loglik.default(data, params, model, V_param, ser_stats),\n \"neg_loglik: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"update_fitted_values.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n params <- list()\n model <- list(alpha = matrix(1/10, 5, 10), mu = matrix(0, 5, 10))\n l <- 1\n\n expect_error(\n update_fitted_values.default(data, params, model, l),\n \"update_fitted_values: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"get_scale_factors.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n params <- list()\n\n expect_error(\n get_scale_factors.default(data, params),\n \"get_scale_factors: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"get_intercept.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n params <- list()\n model <- list(alpha = matrix(1/10, 5, 10), mu = matrix(0, 5, 10))\n\n expect_error(\n get_intercept.default(data, params, model),\n \"get_intercept: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"get_cs.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n params <- list(coverage = 0.95, min_abs_corr = 0.5)\n model <- list(alpha = matrix(1/10, 5, 10))\n\n expect_error(\n get_cs.default(data, params, model),\n \"get_cs: no method for class 'unsupported_class'\"\n )\n})\n\ntest_that(\"get_variable_names.default throws error for unimplemented class\", {\n data <- structure(list(n = 50, p = 10), class = \"unsupported_class\")\n model <- list(alpha = matrix(1/10, 5, 10))\n\n expect_error(\n get_variable_names.default(data, model),\n \"get_variable_names: no method for class 'unsupported_class'\"\n )\n})\n\n# =============================================================================\n# Per-class verbose-row generics (format_sigma2_summary, format_extra_diag)\n# =============================================================================\n\ntest_that(\"format_sigma2_summary.default returns sprintf %.4f of scalar sigma2\", {\n model <- list(sigma2 = 1.2345678)\n expect_equal(format_sigma2_summary(model), sprintf(\"%.4f\", 1.2345678))\n expect_type(format_sigma2_summary(model), \"character\")\n expect_length(format_sigma2_summary(model), 1L)\n})\n\ntest_that(\"format_extra_diag.default returns empty string\", {\n model <- list()\n expect_identical(format_extra_diag(model), \"\")\n})\n\n# =============================================================================\n# cleanup_extra_fields generic\n# =============================================================================\n\ntest_that(\"cleanup_extra_fields.default returns character(0)\", {\n data <- list()\n expect_identical(cleanup_extra_fields(data), character(0))\n})\n\ntest_that(\"cleanup_model.default strips standard temp fields\", {\n data <- list() # default class\n model <- list(\n null_weight = 0.5,\n runtime = list(prev_elbo = -Inf),\n fitted_without_l = NA,\n keep_me = 42\n )\n out <- cleanup_model.default(data, params = list(), model = model)\n expect_null(out$null_weight)\n expect_null(out$runtime)\n expect_null(out$fitted_without_l)\n expect_equal(out$keep_me, 42)\n})\n\n# =============================================================================\n# get_objective.default sum(KL) tolerates NA entries via na.rm = TRUE\n# =============================================================================\n\ntest_that(\"get_objective.default skips NA entries in KL via na.rm = TRUE\", {\n # Construct a minimal model where KL contains NA on a null effect.\n # Eloglik will throw because the model class is generic; instead we\n # intercept at the line that computes objective. Use a tiny test:\n model <- list(\n alpha = matrix(1/10, 5, 10),\n KL = c(1.0, NA_real_, 2.0, NA_real_, 0.5),\n sigma2 = 1.0\n )\n\n # Direct test: does sum(model$KL, na.rm = TRUE) equal 3.5?\n expect_equal(sum(model$KL, na.rm = TRUE), 3.5)\n})\n" }, { "path": "tests/testthat/test_ibss.R", "content": "context(\"Iterative Bayesian Stepwise Selection (IBSS)\")\n\n# =============================================================================\n# IBSS_INITIALIZE - Basic Structure and Components\n# =============================================================================\n\ntest_that(\"ibss_initialize returns correct structure with susie class\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_s3_class(model, \"susie\")\n expect_type(model, \"list\")\n})\n\ntest_that(\"ibss_initialize creates all required model components\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n # Core posterior components\n expect_true(\"alpha\" %in% names(model))\n expect_true(\"mu\" %in% names(model))\n expect_true(\"mu2\" %in% names(model))\n expect_true(\"V\" %in% names(model))\n expect_true(\"sigma2\" %in% names(model))\n\n # Tracking components\n expect_true(\"lbf\" %in% names(model))\n expect_true(\"lbf_variable\" %in% names(model))\n expect_true(\"KL\" %in% names(model))\n\n # Prior components\n expect_true(\"pi\" %in% names(model))\n expect_true(\"predictor_weights\" %in% names(model))\n\n # Fitted values\n expect_true(\"Xr\" %in% names(model))\n expect_true(\"null_index\" %in% names(model))\n})\n\ntest_that(\"ibss_initialize creates matrices with correct dimensions\", {\n n <- 100\n p <- 50\n L <- 5\n setup <- setup_individual_data(n = n, p = p, L = L)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_equal(dim(model$alpha), c(L, p))\n expect_equal(dim(model$mu), c(L, p))\n expect_equal(dim(model$mu2), c(L, p))\n expect_equal(dim(model$lbf_variable), c(L, p))\n expect_length(model$V, L)\n expect_length(model$lbf, L)\n expect_length(model$KL, L)\n expect_length(model$Xr, n)\n})\n\n# =============================================================================\n# IBSS_INITIALIZE - Parameter Validation\n# =============================================================================\n\ntest_that(\"ibss_initialize adjusts L when p < L\", {\n setup <- setup_individual_data(n = 100, p = 10, L = 20)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n # L should be reduced to p\n expect_equal(nrow(model$alpha), 10)\n expect_equal(length(model$V), 10)\n})\n\ntest_that(\"ibss_initialize validates residual variance is positive\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$residual_variance <- -1\n\n expect_error(\n ibss_initialize(setup$data, setup$params),\n \"Residual variance sigma2 must be positive\"\n )\n})\n\ntest_that(\"ibss_initialize validates residual variance is scalar\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$residual_variance <- c(1, 2)\n\n expect_error(\n ibss_initialize(setup$data, setup$params),\n \"Input residual variance sigma2 must be a scalar\"\n )\n})\n\ntest_that(\"ibss_initialize validates residual variance is numeric\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$residual_variance <- \"one\"\n\n expect_error(\n ibss_initialize(setup$data, setup$params),\n \"Input residual variance sigma2 must be numeric\"\n )\n})\n\ntest_that(\"ibss_initialize sets default residual variance to var(y)\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$residual_variance <- NULL\n\n var_y <- var(drop(setup$data$y))\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_equal(model$sigma2, var_y)\n})\n\ntest_that(\"ibss_initialize uses provided residual variance\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$residual_variance <- 2.5\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_equal(model$sigma2, 2.5)\n})\n\n# =============================================================================\n# IBSS_INITIALIZE - Model Initialization (model_init)\n# =============================================================================\n\ntest_that(\"ibss_initialize works without model_init\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$model_init <- NULL\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_equal(dim(model$alpha), c(5, 50))\n expect_true(all(model$alpha >= 0 & model$alpha <= 1))\n expect_true(all(is.finite(model$mu)))\n})\n\ntest_that(\"ibss_initialize accepts valid susie model_init\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 3)\n\n # Create a proper previous susie fit to use as model_init\n model_init <- ibss_initialize(setup$data, setup$params)\n model_init$V <- rep(0.5, 3) # Set some prior variance\n\n # Use it as initialization for a new fit\n setup2 <- setup_individual_data(n = 100, p = 50, L = 3)\n setup2$params$model_init <- model_init\n\n model <- ibss_initialize(setup2$data, setup2$params)\n\n expect_equal(dim(model$alpha), c(3, 50))\n expect_true(all(model$alpha >= 0 & model$alpha <= 1))\n})\n\ntest_that(\"ibss_initialize handles model_init with fewer effects than L\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 2)\n\n # Create init with 2 effects\n model_init <- ibss_initialize(setup$data, setup$params)\n model_init$V <- rep(0.5, 2)\n\n # Try to expand to 5 effects\n setup2 <- setup_individual_data(n = 100, p = 50, L = 5)\n setup2$params$model_init <- model_init\n\n model <- ibss_initialize(setup2$data, setup2$params)\n\n # Should expand to L=5 effects\n expect_equal(dim(model$alpha), c(5, 50))\n})\n\ntest_that(\"ibss_initialize handles model_init with more effects than L\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 6)\n\n # Create init with 6 effects\n model_init <- ibss_initialize(setup$data, setup$params)\n model_init$V <- rep(0.5, 6)\n\n # Try to reduce to 3 effects\n setup2 <- setup_individual_data(n = 100, p = 50, L = 3)\n setup2$params$model_init <- model_init\n\n # When model_init has more effects, it keeps all of them (expands L)\n expect_message(\n model <- ibss_initialize(setup2$data, setup2$params),\n \"using L = 6\"\n )\n\n # Should keep all 6 effects from model_init\n expect_equal(dim(model$alpha), c(6, 50))\n})\n\n# =============================================================================\n# IBSS_INITIALIZE - Mathematical Properties\n# =============================================================================\n\ntest_that(\"ibss_initialize alpha rows sum to 1\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n row_sums <- rowSums(model$alpha)\n expect_equal(row_sums, rep(1, 5), tolerance = 1e-10)\n})\n\ntest_that(\"ibss_initialize alpha values are valid probabilities\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_true(all(model$alpha >= 0 & model$alpha <= 1))\n})\n\ntest_that(\"ibss_initialize V values are non-negative\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_true(all(model$V >= 0))\n expect_true(all(is.finite(model$V)))\n})\n\ntest_that(\"ibss_initialize sigma2 is positive\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_true(model$sigma2 > 0)\n expect_true(is.finite(model$sigma2))\n})\n\ntest_that(\"ibss_initialize KL and lbf are initialized to NA\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$model_init <- NULL\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_true(all(is.na(model$KL)))\n expect_true(all(is.na(model$lbf)))\n})\n\n# =============================================================================\n# IBSS_INITIALIZE - Fitted Values\n# =============================================================================\n\ntest_that(\"ibss_initialize creates fitted values for individual data\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_true(\"Xr\" %in% names(model))\n expect_length(model$Xr, 100)\n expect_true(all(is.finite(model$Xr)))\n})\n\ntest_that(\"ibss_initialize creates fitted values for sufficient stats\", {\n setup <- setup_ss_data(n = 100, p = 50, L = 5)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_true(\"XtXr\" %in% names(model))\n expect_length(model$XtXr, 50)\n expect_true(all(is.finite(model$XtXr)))\n})\n\ntest_that(\"ibss_initialize creates fitted values for rss_lambda\", {\n setup <- setup_rss_lambda_data(n = 500, p = 50, L = 5, lambda = 0.5)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_true(\"Rz\" %in% names(model))\n expect_length(model$Rz, 50)\n expect_true(all(is.finite(model$Rz)))\n})\n\n# =============================================================================\n# IBSS_INITIALIZE - Null Index\n# =============================================================================\n\ntest_that(\"ibss_initialize sets null_index to 0 when null_weight = 0\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$model$null_weight <- 0\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_equal(model$null_index, 0)\n})\n\ntest_that(\"ibss_initialize sets null_index when null_weight > 0\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$null_weight <- 0.5\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_true(model$null_index > 0)\n})\n\n# =============================================================================\n# IBSS_INITIALIZE - Data Type Compatibility\n# =============================================================================\n\ntest_that(\"ibss_initialize works with individual data\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_s3_class(model, \"susie\")\n expect_true(\"Xr\" %in% names(model))\n})\n\ntest_that(\"ibss_initialize works with sufficient stats\", {\n setup <- setup_ss_data(n = 100, p = 50, L = 5)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_s3_class(model, \"susie\")\n expect_true(\"XtXr\" %in% names(model))\n})\n\ntest_that(\"ibss_initialize works with rss_lambda\", {\n setup <- setup_rss_lambda_data(n = 500, p = 50, L = 5, lambda = 0.5)\n\n model <- ibss_initialize(setup$data, setup$params)\n\n expect_s3_class(model, \"susie\")\n expect_true(\"Rz\" %in% names(model))\n})\n\n# =============================================================================\n# IBSS_FIT - Basic Functionality\n# =============================================================================\n\ntest_that(\"ibss_fit updates all L effects\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n\n # Fit one iteration\n model_updated <- ibss_fit(setup$data, setup$params, model)\n\n # All effects should still have valid probabilities\n for (l in 1:5) {\n expect_equal(sum(model_updated$alpha[l, ]), 1, tolerance = 1e-10)\n }\n\n # V should be updated (even if to 0 for no signal)\n expect_true(all(is.finite(model_updated$V)))\n expect_true(all(model_updated$V >= 0))\n})\n\ntest_that(\"ibss_fit updates V for all effects\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n\n # Store initial V\n V_init <- model$V\n\n # Fit one iteration\n model_updated <- ibss_fit(setup$data, setup$params, model)\n\n # V should be updated (unless it converged to same values)\n expect_length(model_updated$V, 5)\n expect_true(all(model_updated$V >= 0))\n expect_true(all(is.finite(model_updated$V)))\n})\n\ntest_that(\"ibss_fit updates lbf for all effects\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n\n # Fit one iteration\n model_updated <- ibss_fit(setup$data, setup$params, model)\n\n expect_length(model_updated$lbf, 5)\n expect_true(all(is.finite(model_updated$lbf)))\n})\n\ntest_that(\"ibss_fit updates KL for all effects\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n\n # Fit one iteration\n model_updated <- ibss_fit(setup$data, setup$params, model)\n\n expect_length(model_updated$KL, 5)\n expect_true(all(is.finite(model_updated$KL)))\n # KL divergence should be non-negative\n expect_true(all(model_updated$KL >= -1e-6))\n})\n\n# =============================================================================\n# IBSS_FIT - Mathematical Properties\n# =============================================================================\n\ntest_that(\"ibss_fit maintains valid probability distributions\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n\n model_updated <- ibss_fit(setup$data, setup$params, model)\n\n # Each row of alpha should sum to 1\n row_sums <- rowSums(model_updated$alpha)\n expect_equal(row_sums, rep(1, 5), tolerance = 1e-10)\n\n # All alpha values should be valid probabilities\n expect_true(all(model_updated$alpha >= 0))\n expect_true(all(model_updated$alpha <= 1))\n})\n\ntest_that(\"ibss_fit maintains finite values\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n\n model_updated <- ibss_fit(setup$data, setup$params, model)\n\n expect_true(all(model_updated$alpha >= 0 & model_updated$alpha <= 1))\n expect_true(all(is.finite(model_updated$mu)))\n expect_true(all(is.finite(model_updated$mu2)))\n expect_true(all(is.finite(model_updated$V)))\n})\n\ntest_that(\"ibss_fit updates fitted values\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n\n Xr_init <- model$Xr\n model_updated <- ibss_fit(setup$data, setup$params, model)\n\n # Fitted values should be updated\n expect_true(\"Xr\" %in% names(model_updated))\n expect_length(model_updated$Xr, 100)\n})\n\n# =============================================================================\n# IBSS_FIT - Edge Cases\n# =============================================================================\n\ntest_that(\"ibss_fit works with L=1\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 1)\n model <- ibss_initialize(setup$data, setup$params)\n\n model_updated <- ibss_fit(setup$data, setup$params, model)\n\n expect_equal(dim(model_updated$alpha), c(1, 50))\n expect_equal(sum(model_updated$alpha), 1, tolerance = 1e-10)\n})\n\ntest_that(\"ibss_fit works with L=0 (no effects)\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 0)\n model <- list(alpha = matrix(0, 0, 50))\n\n # Should handle gracefully\n model_updated <- ibss_fit(setup$data, setup$params, model)\n\n expect_equal(nrow(model_updated$alpha), 0)\n})\n\ntest_that(\"ibss_fit works with different data types\", {\n # Individual data\n setup_ind <- setup_individual_data(n = 100, p = 50, L = 5)\n model_ind <- ibss_initialize(setup_ind$data, setup_ind$params)\n model_ind_updated <- ibss_fit(setup_ind$data, setup_ind$params, model_ind)\n expect_s3_class(model_ind_updated, \"susie\")\n\n # Sufficient stats\n setup_ss <- setup_ss_data(n = 100, p = 50, L = 5)\n model_ss <- ibss_initialize(setup_ss$data, setup_ss$params)\n model_ss_updated <- ibss_fit(setup_ss$data, setup_ss$params, model_ss)\n expect_s3_class(model_ss_updated, \"susie\")\n\n # RSS lambda\n setup_rss <- setup_rss_lambda_data(n = 500, p = 50, L = 5, lambda = 0.5)\n model_rss <- ibss_initialize(setup_rss$data, setup_rss$params)\n model_rss_updated <- ibss_fit(setup_rss$data, setup_rss$params, model_rss)\n expect_s3_class(model_rss_updated, \"susie\")\n})\n\n# =============================================================================\n# IBSS_FIT - Iterative Behavior\n# =============================================================================\n\ntest_that(\"ibss_fit can be called iteratively\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n\n # Run multiple iterations\n for (iter in 1:3) {\n model <- ibss_fit(setup$data, setup$params, model)\n\n # Check validity after each iteration\n expect_equal(rowSums(model$alpha), rep(1, 5), tolerance = 1e-10)\n expect_true(all(model$V >= 0))\n }\n})\n\n# =============================================================================\n# IBSS_FINALIZE - Basic Functionality\n# =============================================================================\n\ntest_that(\"ibss_finalize adds required output fields\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n model <- ibss_fit(setup$data, setup$params, model)\n\n model_final <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 10L, tracking = NULL)\n\n # Check for required output fields\n expect_true(\"niter\" %in% names(model_final))\n expect_true(\"intercept\" %in% names(model_final))\n expect_true(\"fitted\" %in% names(model_final))\n expect_true(\"sets\" %in% names(model_final))\n expect_true(\"pip\" %in% names(model_final))\n expect_true(\"X_column_scale_factors\" %in% names(model_final))\n})\n\ntest_that(\"ibss_finalize sets iteration count\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n model <- ibss_fit(setup$data, setup$params, model)\n\n model_final <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 42L, tracking = NULL)\n\n expect_equal(model_final$niter, 42L)\n})\n\ntest_that(\"ibss_finalize computes PIPs\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n model <- ibss_fit(setup$data, setup$params, model)\n\n model_final <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 10L, tracking = NULL)\n\n expect_length(model_final$pip, 50)\n expect_true(all(model_final$pip >= 0))\n expect_true(all(model_final$pip <= 1))\n expect_true(all(is.finite(model_final$pip)))\n})\n\ntest_that(\"ibss_finalize computes credible sets\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n model <- ibss_fit(setup$data, setup$params, model)\n\n model_final <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 10L, tracking = NULL)\n\n expect_true(\"sets\" %in% names(model_final))\n expect_type(model_final$sets, \"list\")\n})\n\ntest_that(\"ibss_finalize computes fitted values\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n model <- ibss_fit(setup$data, setup$params, model)\n\n model_final <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 10L, tracking = NULL)\n\n expect_true(\"fitted\" %in% names(model_final))\n expect_length(model_final$fitted, 100)\n expect_true(all(is.finite(model_final$fitted)))\n})\n\ntest_that(\"ibss_finalize computes intercept\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$intercept <- TRUE\n model <- ibss_initialize(setup$data, setup$params)\n model <- ibss_fit(setup$data, setup$params, model)\n\n model_final <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 10L, tracking = NULL)\n\n expect_true(\"intercept\" %in% names(model_final))\n expect_true(is.finite(model_final$intercept))\n})\n\n# =============================================================================\n# IBSS_FINALIZE - Tracking\n# =============================================================================\n\ntest_that(\"ibss_finalize includes tracking when track_fit=TRUE\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$track_fit <- TRUE\n model <- ibss_initialize(setup$data, setup$params)\n model <- ibss_fit(setup$data, setup$params, model)\n\n # Create mock tracking data\n tracking <- list(\n elbo = c(100, 110, 115),\n sigma2 = c(1, 0.9, 0.85)\n )\n\n model_final <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 3L, tracking = tracking)\n\n expect_true(\"trace\" %in% names(model_final))\n expect_type(model_final$trace, \"list\")\n})\n\ntest_that(\"ibss_finalize excludes tracking when track_fit=FALSE\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$track_fit <- FALSE\n model <- ibss_initialize(setup$data, setup$params)\n model <- ibss_fit(setup$data, setup$params, model)\n\n model_final <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 3L, tracking = NULL)\n\n expect_false(\"trace\" %in% names(model_final))\n})\n\n# =============================================================================\n# IBSS_FINALIZE - Variable Names\n# =============================================================================\n\ntest_that(\"ibss_finalize assigns variable names when available\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n\n # Add column names to X\n colnames(setup$data$X) <- paste0(\"var\", 1:50)\n\n model <- ibss_initialize(setup$data, setup$params)\n model <- ibss_fit(setup$data, setup$params, model)\n\n model_final <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 10L, tracking = NULL)\n\n # Check that variable names are assigned to pip\n expect_named(model_final$pip, paste0(\"var\", 1:50))\n})\n\n# =============================================================================\n# IBSS_FINALIZE - Z-scores\n# =============================================================================\n\ntest_that(\"ibss_finalize computes z-scores for individual data\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n model <- ibss_fit(setup$data, setup$params, model)\n\n model_final <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 10L, tracking = NULL)\n\n expect_true(\"z\" %in% names(model_final))\n if (!is.null(model_final$z)) {\n expect_length(model_final$z, 50)\n expect_true(all(is.finite(model_final$z)))\n }\n})\n\n# =============================================================================\n# IBSS_FINALIZE - Scale Factors\n# =============================================================================\n\ntest_that(\"ibss_finalize computes X_column_scale_factors\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n model <- ibss_fit(setup$data, setup$params, model)\n\n model_final <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 10L, tracking = NULL)\n\n expect_true(\"X_column_scale_factors\" %in% names(model_final))\n expect_length(model_final$X_column_scale_factors, 50)\n})\n\n# =============================================================================\n# IBSS_FINALIZE - Data Type Compatibility\n# =============================================================================\n\ntest_that(\"ibss_finalize works with individual data\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n model <- ibss_initialize(setup$data, setup$params)\n model <- ibss_fit(setup$data, setup$params, model)\n\n model_final <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 10L, tracking = NULL)\n\n expect_s3_class(model_final, \"susie\")\n expect_true(\"fitted\" %in% names(model_final))\n expect_length(model_final$fitted, 100)\n})\n\n\n# =============================================================================\n# FULL IBSS PIPELINE\n# =============================================================================\n\ntest_that(\"Full IBSS pipeline produces valid susie object\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n\n # Initialize\n model <- ibss_initialize(setup$data, setup$params)\n\n # Fit (run 5 iterations)\n for (i in 1:5) {\n model <- ibss_fit(setup$data, setup$params, model)\n }\n\n # Finalize\n model <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 5L, tracking = NULL)\n\n # Check final model is complete\n expect_s3_class(model, \"susie\")\n expect_true(\"alpha\" %in% names(model))\n expect_true(\"mu\" %in% names(model))\n expect_true(\"V\" %in% names(model))\n expect_true(\"pip\" %in% names(model))\n expect_true(\"sets\" %in% names(model))\n expect_true(\"fitted\" %in% names(model))\n expect_true(\"niter\" %in% names(model))\n expect_equal(model$niter, 5L)\n})\n\ntest_that(\"Full IBSS pipeline maintains mathematical properties\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n\n # Initialize\n model <- ibss_initialize(setup$data, setup$params)\n\n # Fit (run 3 iterations)\n for (i in 1:3) {\n model <- ibss_fit(setup$data, setup$params, model)\n }\n\n # Finalize\n model <- ibss_finalize(setup$data, setup$params, model,\n elbo = NULL, iter = 3L, tracking = NULL)\n\n # Check mathematical properties\n expect_equal(rowSums(model$alpha), rep(1, 5), tolerance = 1e-10)\n expect_true(all(model$pip >= 0))\n expect_true(all(model$pip <= 1))\n expect_true(all(model$V >= 0))\n})\n\n" }, { "path": "tests/testthat/test_individual_data_methods.R", "content": "context(\"S3 methods for individual data class\")\n\n# =============================================================================\n# DATA INITIALIZATION & CONFIGURATION\n# =============================================================================\n\ntest_that(\"configure_data.individual returns data when unmappable_effects='none'\", {\n setup <- setup_individual_data()\n setup$params$unmappable_effects <- \"none\"\n\n result <- configure_data.individual(setup$data, setup$params)\n\n expect_true(\"individual\" %in% class(result))\n})\n\ntest_that(\"get_var_y.individual computes variance of y\", {\n setup <- setup_individual_data()\n\n var_y <- get_var_y.individual(setup$data)\n\n expect_type(var_y, \"double\")\n expect_length(var_y, 1)\n expect_true(var_y > 0)\n expect_equal(var_y, var(setup$data$y))\n})\n\n# =============================================================================\n# MODEL INITIALIZATION & SETUP\n# =============================================================================\n\ntest_that(\"initialize_susie_model.individual creates model with predictor_weights\", {\n setup <- setup_individual_data()\n var_y <- var(setup$data$y)\n\n model <- initialize_susie_model.individual(setup$data, setup$params, var_y)\n\n expect_true(\"predictor_weights\" %in% names(model))\n expect_length(model$predictor_weights, setup$data$p)\n expect_equal(model$predictor_weights, attr(setup$data$X, \"d\"))\n})\n\ntest_that(\"initialize_fitted.individual creates Xr\", {\n setup <- setup_individual_data()\n\n mat_init <- list(\n alpha = setup$model$alpha,\n mu = setup$model$mu\n )\n\n fitted <- initialize_fitted.individual(setup$data, mat_init)\n\n expect_true(\"Xr\" %in% names(fitted))\n expect_length(fitted$Xr, setup$data$n)\n})\n\ntest_that(\"validate_prior.individual delegates to default method\", {\n setup <- setup_individual_data()\n\n result <- validate_prior.individual(setup$data, setup$params, setup$model)\n\n expect_type(result, \"logical\")\n})\n\ntest_that(\"track_ibss_fit.individual delegates to default method\", {\n setup <- setup_individual_data()\n tracking <- list()\n iter <- 1\n elbo <- -100\n\n result <- track_ibss_fit.individual(setup$data, setup$params, setup$model,\n tracking, iter, elbo)\n\n expect_type(result, \"list\")\n})\n\n# =============================================================================\n# SINGLE EFFECT REGRESSION & ELBO\n# =============================================================================\n\ntest_that(\"compute_residuals.individual computes residuals correctly\", {\n setup <- setup_individual_data()\n l <- 1\n\n model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n\n expect_true(\"residuals\" %in% names(model))\n expect_true(\"fitted_without_l\" %in% names(model))\n expect_true(\"raw_residuals\" %in% names(model))\n expect_true(\"residual_variance\" %in% names(model))\n\n expect_length(model$residuals, setup$data$p)\n expect_length(model$raw_residuals, setup$data$n)\n})\n\ntest_that(\"compute_ser_statistics.individual computes betahat and shat2\", {\n setup <- setup_individual_data()\n l <- 1\n\n model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n ser_stats <- compute_ser_statistics.individual(setup$data, setup$params, model, l)\n\n expect_true(\"betahat\" %in% names(ser_stats))\n expect_true(\"shat2\" %in% names(ser_stats))\n expect_true(\"optim_init\" %in% names(ser_stats))\n expect_true(\"optim_bounds\" %in% names(ser_stats))\n expect_true(\"optim_scale\" %in% names(ser_stats))\n\n expect_length(ser_stats$betahat, setup$data$p)\n expect_length(ser_stats$shat2, setup$data$p)\n expect_true(all(ser_stats$shat2 > 0))\n})\n\ntest_that(\"calculate_posterior_moments.individual computes posterior correctly\", {\n setup <- setup_individual_data()\n l <- 1\n V <- 1.0\n\n model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n model <- calculate_posterior_moments.individual(setup$data, setup$params, model, V, l)\n\n expect_length(model$mu[l, ], setup$data$p)\n expect_length(model$mu2[l, ], setup$data$p)\n\n post_var <- model$mu2[l, ] - model$mu[l, ]^2\n expect_true(all(post_var >= -1e-10))\n expect_true(all(model$mu2[l, ] >= model$mu[l, ]^2 - 1e-10))\n})\n\ntest_that(\"calculate_posterior_moments.individual handles V=0\", {\n setup <- setup_individual_data()\n l <- 1\n V <- 0\n\n setup$params$use_NIG <- TRUE\n model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n model <- calculate_posterior_moments.individual(setup$data, setup$params, model, V, l)\n\n expect_equal(model$mu[l, ], rep(0, setup$data$p))\n expect_equal(model$mu2[l, ], rep(0, setup$data$p))\n})\n\ntest_that(\"compute_kl.individual computes KL divergence\", {\n setup <- setup_individual_data()\n l <- 1\n\n setup$model$lbf <- rep(0, setup$params$L)\n setup$model$alpha[l, ] <- rep(1/setup$data$p, setup$data$p)\n setup$model$mu[l, ] <- rnorm(setup$data$p, sd = 0.1)\n setup$model$mu2[l, ] <- setup$model$mu[l, ]^2 + 0.1\n\n model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n model <- compute_kl.individual(setup$data, setup$params, model, l)\n\n expect_type(model$KL[l], \"double\")\n expect_length(model$KL[l], 1)\n})\n\ntest_that(\"get_ER2.individual computes expected squared residuals\", {\n setup <- setup_individual_data()\n\n er2 <- get_ER2.individual(setup$data, setup$model)\n\n expect_type(er2, \"double\")\n expect_length(er2, 1)\n expect_true(er2 >= 0)\n})\n\ntest_that(\"Eloglik.individual computes expected log-likelihood\", {\n setup <- setup_individual_data()\n\n e_loglik <- Eloglik.individual(setup$data, setup$model)\n\n expect_type(e_loglik, \"double\")\n expect_length(e_loglik, 1)\n})\n\ntest_that(\"loglik.individual computes log Bayes factors\", {\n setup <- setup_individual_data()\n l <- 1\n V <- 1.0\n\n model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n ser_stats <- compute_ser_statistics.individual(setup$data, setup$params, model, l)\n model <- loglik.individual(setup$data, setup$params, model, V, ser_stats, l)\n\n expect_length(model$lbf_variable[l, ], setup$data$p)\n expect_length(model$alpha[l, ], setup$data$p)\n\n expect_true(all(model$alpha[l, ] >= 0))\n expect_true(abs(sum(model$alpha[l, ]) - 1) < 1e-10)\n expect_true(is.numeric(model$lbf[l]))\n})\n\ntest_that(\"neg_loglik.individual returns negative log-likelihood\", {\n setup <- setup_individual_data()\n l <- 1\n V_param <- log(1.0)\n\n model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n ser_stats <- compute_ser_statistics.individual(setup$data, setup$params, model, l)\n neg_ll <- neg_loglik.individual(setup$data, setup$params, model, V_param, ser_stats)\n\n expect_type(neg_ll, \"double\")\n expect_length(neg_ll, 1)\n})\n\ntest_that(\"SER_posterior_e_loglik.individual computes expected log-likelihood\", {\n setup <- setup_individual_data()\n l <- 1\n\n setup$model$alpha[l, ] <- rep(1/setup$data$p, setup$data$p)\n setup$model$mu[l, ] <- rnorm(setup$data$p)\n setup$model$mu2[l, ] <- setup$model$mu[l, ]^2 + 0.1\n\n model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n e_loglik <- SER_posterior_e_loglik.individual(setup$data, setup$params, model, l)\n\n expect_type(e_loglik, \"double\")\n expect_length(e_loglik, 1)\n})\n\n# =============================================================================\n# MODEL UPDATES & FITTING\n# =============================================================================\n\ntest_that(\"update_fitted_values.individual updates Xr\", {\n setup <- setup_individual_data()\n l <- 1\n\n model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n setup$model$fitted_without_l <- model$fitted_without_l\n\n updated_model <- update_fitted_values.individual(setup$data, setup$params, setup$model, l)\n\n expect_true(\"Xr\" %in% names(updated_model))\n expect_length(updated_model$Xr, setup$data$n)\n})\n\ntest_that(\"update_variance_components.individual delegates to default method\", {\n setup <- setup_individual_data()\n\n result <- update_variance_components.individual(setup$data, setup$params, setup$model)\n\n expect_type(result, \"list\")\n})\n\ntest_that(\"update_derived_quantities.individual delegates to default method\", {\n setup <- setup_individual_data()\n\n result <- update_derived_quantities.individual(setup$data, setup$params, setup$model)\n\n expect_type(result, \"list\")\n})\n\n# =============================================================================\n# OUTPUT GENERATION & POST-PROCESSING\n# =============================================================================\n\ntest_that(\"get_scale_factors.individual returns column scale factors\", {\n setup <- setup_individual_data()\n\n scales <- get_scale_factors.individual(setup$data, setup$params)\n\n expect_length(scales, setup$data$p)\n expect_true(all(scales > 0))\n expect_equal(scales, attr(setup$data$X, \"scaled:scale\"))\n})\n\ntest_that(\"get_intercept.individual computes intercept when intercept=TRUE\", {\n setup <- setup_individual_data()\n setup$params$intercept <- TRUE\n\n intercept <- get_intercept.individual(setup$data, setup$params, setup$model)\n\n expect_type(intercept, \"double\")\n expect_length(intercept, 1)\n})\n\ntest_that(\"get_intercept.individual returns 0 when intercept=FALSE\", {\n setup <- setup_individual_data()\n setup$params$intercept <- FALSE\n\n intercept <- get_intercept.individual(setup$data, setup$params, setup$model)\n\n expect_equal(intercept, 0)\n})\n\ntest_that(\"get_fitted.individual returns fitted values with correct length\", {\n setup <- setup_individual_data()\n\n fitted <- get_fitted.individual(setup$data, setup$params, setup$model)\n\n expect_length(fitted, setup$data$n)\n expect_type(fitted, \"double\")\n})\n\ntest_that(\"get_fitted.individual adds intercept when intercept=TRUE\", {\n setup <- setup_individual_data()\n setup$params$intercept <- TRUE\n setup$data$mean_y <- 5.0\n\n fitted <- get_fitted.individual(setup$data, setup$params, setup$model)\n\n expect_true(any(fitted != setup$model$Xr))\n})\n\ntest_that(\"get_fitted.individual does not add intercept when intercept=FALSE\", {\n setup <- setup_individual_data()\n setup$params$intercept <- FALSE\n setup$data$mean_y <- 0\n\n fitted <- get_fitted.individual(setup$data, setup$params, setup$model)\n\n expect_equal(fitted, drop(setup$model$Xr))\n})\n\ntest_that(\"get_cs.individual returns NULL when coverage is NULL\", {\n setup <- setup_individual_data()\n setup$params$coverage <- NULL\n\n cs <- get_cs.individual(setup$data, setup$params, setup$model)\n\n expect_null(cs)\n})\n\ntest_that(\"get_cs.individual returns NULL when min_abs_corr is NULL\", {\n setup <- setup_individual_data()\n setup$params$min_abs_corr <- NULL\n\n cs <- get_cs.individual(setup$data, setup$params, setup$model)\n\n expect_null(cs)\n})\n\ntest_that(\"get_variable_names.individual assigns variable names to model\", {\n setup <- setup_individual_data()\n colnames(setup$data$X) <- paste0(\"var\", 1:setup$data$p)\n setup$model$pip <- rep(0.1, setup$data$p)\n setup$model$null_weight <- NULL\n setup$model$alpha <- matrix(0, 5, setup$data$p)\n setup$model$mu <- matrix(0, 5, setup$data$p)\n setup$model$mu2 <- matrix(0, 5, setup$data$p)\n setup$model$lbf_variable <- matrix(0, 5, setup$data$p)\n\n model_with_names <- get_variable_names.individual(setup$data, setup$model)\n\n expect_true(all(grepl(\"var\", colnames(model_with_names$alpha))))\n expect_true(all(grepl(\"var\", colnames(model_with_names$mu))))\n expect_true(all(grepl(\"var\", colnames(model_with_names$mu2))))\n expect_true(all(grepl(\"var\", names(model_with_names$pip))))\n})\n\ntest_that(\"get_zscore.individual computes z-scores\", {\n setup <- setup_individual_data()\n setup$params$compute_univariate_zscore <- TRUE\n\n z <- get_zscore.individual(setup$data, setup$params, setup$model)\n\n expect_length(z, setup$data$p)\n expect_type(z, \"double\")\n})\n\ntest_that(\"get_zscore.individual handles null_weight\", {\n setup <- setup_individual_data()\n setup$params$compute_univariate_zscore <- TRUE\n setup$model$null_weight <- 0.1\n\n setup$data$X <- cbind(setup$data$X, 0)\n\n z <- get_zscore.individual(setup$data, setup$params, setup$model)\n\n expect_length(z, setup$data$p)\n})\n\ntest_that(\"get_zscore.individual returns default when compute_univariate_zscore=FALSE\", {\n setup <- setup_individual_data()\n setup$params$compute_univariate_zscore <- FALSE\n\n z <- get_zscore.individual(setup$data, setup$params, setup$model)\n\n expect_null(z)\n})\n\ntest_that(\"get_zscore.individual warns when X is not a matrix (sparse/trend filtering)\", {\n setup <- setup_individual_data()\n setup$params$compute_univariate_zscore <- TRUE\n\n # Convert X to sparse matrix\n setup$data$X <- Matrix::Matrix(setup$data$X, sparse = TRUE)\n\n # Should produce warning about slow computation\n expect_message(\n z <- get_zscore.individual(setup$data, setup$params, setup$model),\n \"Calculation of univariate regression z-scores is not implemented specifically for sparse or trend filtering matrices\"\n )\n\n # Should still compute z-scores\n expect_length(z, setup$data$p)\n expect_type(z, \"double\")\n})\n\ntest_that(\"cleanup_model.individual removes temporary fields\", {\n setup <- setup_individual_data()\n\n setup$model$raw_residuals <- rnorm(setup$data$n)\n setup$model$residuals <- rnorm(setup$data$p)\n\n cleaned <- cleanup_model.individual(setup$data, setup$params, setup$model)\n\n expect_false(\"raw_residuals\" %in% names(cleaned))\n})" }, { "path": "tests/testthat/test_l_greedy.R", "content": "# Greedy-L outer loop in susie_workhorse.\n# Contracts: (1) L_greedy = NULL is bit-identical to fixed-L susie.\n# (2) L_greedy != NULL grows L until min(lbf) < lbf_min or L reaches\n# params$L.\n\nset.seed(42)\nN <- 200\nJ <- 100\nX <- matrix(rnorm(N * J), N, J)\ntrue_idx <- c(10, 30) # K = 2 real effects\nbeta <- numeric(J)\nbeta[true_idx] <- c(2.5, -1.8)\ny <- X %*% beta + rnorm(N, sd = 0.3)\n\ntest_that(\"L_greedy = NULL is bit-identical to fixed-L susie\", {\n fit_fixed <- susie(X, y, L = 5)\n\n obj <- susie(X, y, L = 5, init_only = TRUE)\n obj$params$L_greedy <- NULL\n fit_direct <- susie_workhorse(obj$data, obj$params)\n\n expect_equal(fit_direct$alpha, fit_fixed$alpha, tolerance = 0)\n expect_equal(fit_direct$lbf, fit_fixed$lbf, tolerance = 0)\n expect_equal(fit_direct$elbo, fit_fixed$elbo, tolerance = 0)\n})\n\ntest_that(\"L_greedy grows L in steps of L_greedy, capped at params$L\", {\n obj <- susie(X, y, L = 10, init_only = TRUE)\n obj$params$L_greedy <- 3\n obj$params$lbf_min <- 0.1\n fit <- susie_workhorse(obj$data, obj$params)\n\n final_L <- nrow(fit$alpha)\n expect_true(final_L %in% c(3, 6, 9, 10)) # multiple of 3, capped at 10\n expect_lte(final_L, 9) # K = 2 real, saturates early\n})\n\ntest_that(\"L_greedy >= K_true saturates in a single round\", {\n # L_greedy = 6, K = 2 real. Round 1 at L = 6 has empty slots so\n # min(lbf) < lbf_min fires immediately, no wasted second round.\n obj <- susie(X, y, L = 12, init_only = TRUE)\n obj$params$L_greedy <- 6\n obj$params$lbf_min <- 0.1\n fit <- susie_workhorse(obj$data, obj$params)\n\n expect_identical(nrow(fit$alpha), 6L)\n})\n\ntest_that(\"K_true > L_greedy keeps growing past the first round\", {\n set.seed(7)\n Xh <- matrix(rnorm(N * J), N, J)\n bh <- numeric(J)\n bh[c(5, 20, 45, 70)] <- c(2.5, -2.0, 1.8, -1.5) # K = 4 real effects\n yh <- Xh %*% bh + rnorm(N, sd = 0.3)\n\n obj <- susie(Xh, yh, L = 10, init_only = TRUE)\n obj$params$L_greedy <- 3\n obj$params$lbf_min <- 0.1\n fit <- susie_workhorse(obj$data, obj$params)\n\n expect_gte(nrow(fit$alpha), 6)\n expect_lte(nrow(fit$alpha), 10)\n})\n\ntest_that(\"L_greedy = L stops after one round at L\", {\n obj <- susie(X, y, L = 3, init_only = TRUE)\n obj$params$L_greedy <- 3\n fit <- susie_workhorse(obj$data, obj$params)\n\n expect_identical(nrow(fit$alpha), 3L)\n})\n\ntest_that(\"L_greedy is exposed through susie interfaces\", {\n fit <- susie(X, y, L = 8, L_greedy = 3, greedy_lbf_cutoff = 0.1,\n verbose = FALSE)\n expect_lte(nrow(fit$alpha), 8)\n expect_gte(nrow(fit$alpha), 3)\n\n y_vec <- drop(y)\n ss <- compute_suff_stat(X, y_vec, standardize = TRUE)\n fit_ss <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 8,\n L_greedy = 3, greedy_lbf_cutoff = 0.1,\n verbose = FALSE)\n expect_lte(nrow(fit_ss$alpha), 8)\n expect_gte(nrow(fit_ss$alpha), 3)\n\n z <- as.vector(crossprod(scale(X), drop(scale(y_vec))) / sqrt(nrow(X) - 1))\n R <- cor(X)\n fit_rss <- susie_rss(z = z, R = R, n = nrow(X), L = 8,\n L_greedy = 3, greedy_lbf_cutoff = 0.1,\n verbose = FALSE)\n expect_lte(nrow(fit_rss$alpha), 8)\n expect_gte(nrow(fit_rss$alpha), 3)\n})\n" }, { "path": "tests/testthat/test_mixture_prior.R", "content": "# Tests for estimate_prior_method = \"fixed_mixture\"\n#\n# Key invariant: a K=1 mixture with grid = c(V) and weights = c(1)\n# must produce identical results to the scalar V path with\n# estimate_prior_variance = FALSE and prior_variance = V.\n\ncontext(\"Fixed mixture prior\")\n\n# Generate a small test dataset\nset.seed(1)\nn <- 200\np <- 50\nX <- matrix(rnorm(n * p), n, p)\nbeta <- rep(0, p)\nbeta[c(1, 5, 10)] <- c(0.5, -0.3, 0.4)\ny <- X %*% beta + rnorm(n)\n\n# Compute summary stats\nR <- cor(X)\nz <- as.vector(sqrt(n) * crossprod(X, y) / sqrt(n * diag(crossprod(X))))\n\n# =============================================================================\n# Test 1: K=1 mixture matches scalar V exactly (individual data)\n# =============================================================================\ntest_that(\"K=1 mixture matches scalar V for individual data\", {\n L <- 5\n # Run scalar path first to find effective V\n fit_scalar <- susie(X, y, L = L,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n max_iter = 20, tol = 1e-4)\n V_eff <- fit_scalar$V[1]\n\n # K=1 mixture path with the same effective V\n fit_mixture <- susie(X, y, L = L,\n prior_variance_grid = c(V_eff),\n mixture_weights = c(1),\n estimate_residual_variance = FALSE,\n max_iter = 20, tol = 1e-4)\n\n expect_equal(fit_scalar$pip, fit_mixture$pip, tolerance = 1e-10)\n expect_equal(fit_scalar$alpha, fit_mixture$alpha, tolerance = 1e-10)\n expect_equal(fit_scalar$mu, fit_mixture$mu, tolerance = 1e-10)\n expect_equal(fit_scalar$lbf, fit_mixture$lbf, tolerance = 1e-10)\n})\n\n# =============================================================================\n# Test 2: K=1 mixture matches scalar V exactly (RSS data)\n# =============================================================================\ntest_that(\"K=1 mixture matches scalar V for RSS data\", {\n L <- 5\n # Run scalar path first to find what V is actually used\n fit_scalar <- susie_rss(z = z, R = R, n = n, L = L,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n max_iter = 20, tol = 1e-4)\n # The effective V is stored in fit_scalar$V[1] (same for all L since\n # scaled_prior_variance is a scalar and estimate_prior_variance = FALSE)\n V_eff <- fit_scalar$V[1]\n\n # K=1 mixture path with the same effective V\n fit_mixture <- susie_rss(z = z, R = R, n = n, L = L,\n prior_variance_grid = c(V_eff),\n mixture_weights = c(1),\n estimate_residual_variance = FALSE,\n max_iter = 20, tol = 1e-4)\n\n expect_equal(fit_scalar$pip, fit_mixture$pip, tolerance = 1e-10)\n expect_equal(fit_scalar$alpha, fit_mixture$alpha, tolerance = 1e-10)\n expect_equal(fit_scalar$mu, fit_mixture$mu, tolerance = 1e-10)\n expect_equal(fit_scalar$lbf, fit_mixture$lbf, tolerance = 1e-10)\n})\n\n# =============================================================================\n# Test 3: K=1 mixture matches scalar V exactly (sufficient stats)\n# =============================================================================\ntest_that(\"K=1 mixture matches scalar V for sufficient stats\", {\n L <- 5\n XtX <- crossprod(X)\n Xty <- crossprod(X, y)\n yty <- sum(y^2)\n\n # Run scalar path first to find effective V\n fit_scalar <- susie_ss(XtX = XtX, Xty = Xty, yty = yty, n = n, L = L,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n max_iter = 20, tol = 1e-4)\n V_eff <- fit_scalar$V[1]\n\n # K=1 mixture path with the same effective V\n fit_mixture <- susie_ss(XtX = XtX, Xty = Xty, yty = yty, n = n, L = L,\n prior_variance_grid = c(V_eff),\n mixture_weights = c(1),\n estimate_residual_variance = FALSE,\n max_iter = 20, tol = 1e-4)\n\n expect_equal(fit_scalar$pip, fit_mixture$pip, tolerance = 1e-10)\n expect_equal(fit_scalar$alpha, fit_mixture$alpha, tolerance = 1e-10)\n expect_equal(fit_scalar$mu, fit_mixture$mu, tolerance = 1e-10)\n expect_equal(fit_scalar$lbf, fit_mixture$lbf, tolerance = 1e-10)\n})\n\n# =============================================================================\n# Test 4: K>1 mixture produces valid outputs\n# =============================================================================\ntest_that(\"K=3 mixture produces valid outputs for RSS data\", {\n L <- 5\n grid <- c(1, 10, 50)\n w <- c(0.3, 0.5, 0.2)\n\n fit <- susie_rss(z = z, R = R, n = n, L = L,\n prior_variance_grid = grid,\n mixture_weights = w,\n estimate_residual_variance = FALSE,\n max_iter = 20, tol = 1e-4)\n\n # PIPs in [0, 1]\n expect_true(all(fit$pip >= 0 & fit$pip <= 1))\n # Alpha rows sum to 1\n expect_equal(rowSums(fit$alpha), rep(1, L), tolerance = 1e-10)\n # lbf_grid is a list of L elements\n expect_length(fit$lbf_grid, L)\n # Each element is p x K matrix\n expect_equal(dim(fit$lbf_grid[[1]]), c(p, 3))\n # Posterior means are finite\n expect_true(all(is.finite(fit$mu)))\n # Posterior second moments >= posterior means squared\n expect_true(all(fit$mu2 >= fit$mu^2 - 1e-10))\n})\n\n# =============================================================================\n# Test 5: Uniform weights produces correct mixture BF\n# =============================================================================\ntest_that(\"Uniform mixture weights give correct BF\", {\n L <- 1\n grid <- c(1, 50)\n w <- c(0.5, 0.5)\n\n fit <- susie_rss(z = z, R = R, n = n, L = L,\n prior_variance_grid = grid,\n mixture_weights = w,\n estimate_residual_variance = FALSE,\n max_iter = 1)\n\n # Manually compute mixture BF for variant 1\n # lbf(V) = -0.5*log(1 + V*R[1,1]) + 0.5*z[1]^2*V*R[1,1]/(V*R[1,1]+1)\n # For RSS with lambda=0, sigma2=1: shat2 = 1/R[1,1], betahat = z[1]/R[1,1] * shat2\n # This is approximate due to eigendecomposition; just check BF matrix shape\n expect_equal(ncol(fit$lbf_grid[[1]]), 2)\n expect_equal(nrow(fit$lbf_grid[[1]]), p)\n})\n\n# =============================================================================\n# Test 6: Input validation\n# =============================================================================\ntest_that(\"Invalid mixture prior inputs are rejected\", {\n # Mismatched lengths\n expect_error(\n susie_rss(z = z, R = R, n = n, L = 5,\n prior_variance_grid = c(1, 10),\n mixture_weights = c(1)),\n \"length\"\n )\n # Negative grid values\n expect_error(\n susie_rss(z = z, R = R, n = n, L = 5,\n prior_variance_grid = c(-1, 10),\n mixture_weights = c(0.5, 0.5)),\n \"prior_variance_grid\"\n )\n # Weights not summing to 1\n expect_error(\n susie_rss(z = z, R = R, n = n, L = 5,\n prior_variance_grid = c(1, 10),\n mixture_weights = c(0.3, 0.3)),\n \"sum\"\n )\n})\n\n# =============================================================================\n# Test 7: Default weights (uniform) when mixture_weights is NULL\n# =============================================================================\ntest_that(\"NULL mixture_weights defaults to uniform\", {\n L <- 5\n grid <- c(1, 10, 50)\n\n # Should not error, should use uniform weights\n fit <- susie_rss(z = z, R = R, n = n, L = L,\n prior_variance_grid = grid,\n estimate_residual_variance = FALSE,\n max_iter = 5)\n\n expect_true(all(fit$pip >= 0 & fit$pip <= 1))\n})\n\n# =============================================================================\n# Test 8: Existing tests still pass (backward compatibility)\n# =============================================================================\ntest_that(\"Standard susie_rss without mixture prior is unchanged\", {\n fit <- susie_rss(z = z, R = R, n = n, L = 5,\n estimate_prior_variance = TRUE,\n estimate_residual_variance = FALSE,\n max_iter = 20)\n expect_true(all(fit$pip >= 0 & fit$pip <= 1))\n expect_null(fit$lbf_grid) # no grid stored in standard path\n})\n\n# =============================================================================\n# Test 9: K=1 mixture with RSS-lambda path (explicit lambda > 0)\n# =============================================================================\ntest_that(\"K=1 mixture matches scalar V with lambda regularization\", {\n L <- 3\n lam <- 0.1\n fit_scalar <- susie_rss_lambda(z = z, R = R, n = n, L = L, lambda = lam,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n max_iter = 10)\n V_eff <- fit_scalar$V[1]\n\n fit_mixture <- susie_rss_lambda(z = z, R = R, n = n, L = L, lambda = lam,\n prior_variance_grid = c(V_eff),\n mixture_weights = c(1),\n estimate_residual_variance = FALSE,\n max_iter = 10)\n\n expect_equal(fit_scalar$alpha, fit_mixture$alpha, tolerance = 1e-10)\n expect_equal(fit_scalar$mu, fit_mixture$mu, tolerance = 1e-10)\n expect_equal(fit_scalar$lbf, fit_mixture$lbf, tolerance = 1e-10)\n})\n\n# =============================================================================\n# Test 10: Mixture prior with finite-reference R inflation (inflated shat2)\n# =============================================================================\ntest_that(\"Mixture prior works with finite-reference R inflation\", {\n skip_if_not_installed(\"Matrix\")\n L <- 3\n grid <- c(1, 10, 50)\n w <- c(0.3, 0.5, 0.2)\n\n # Run with R_finite to trigger shat2 inflation\n fit <- susie_rss(z = z, R = R, n = n, L = L,\n prior_variance_grid = grid,\n mixture_weights = w,\n estimate_residual_variance = FALSE,\n R_finite = 30,\n max_iter = 5)\n\n # Basic validity\n expect_true(all(fit$pip >= 0 & fit$pip <= 1))\n expect_equal(rowSums(fit$alpha), rep(1, L), tolerance = 1e-10)\n expect_length(fit$lbf_grid, L)\n})\n\n# =============================================================================\n# Test 11: Mixture weights are correctly used (asymmetric weights)\n# =============================================================================\ntest_that(\"Asymmetric mixture weights shift PIPs correctly\", {\n L <- 3\n # Large V component only: should produce wider credible intervals\n fit_large <- susie_rss(z = z, R = R, n = n, L = L,\n prior_variance_grid = c(0.001, 100),\n mixture_weights = c(0.01, 0.99),\n estimate_residual_variance = FALSE,\n max_iter = 10)\n # Small V component only: should produce tighter credible intervals\n fit_small <- susie_rss(z = z, R = R, n = n, L = L,\n prior_variance_grid = c(0.001, 100),\n mixture_weights = c(0.99, 0.01),\n estimate_residual_variance = FALSE,\n max_iter = 10)\n\n # Both should be valid\n expect_true(all(fit_large$pip >= 0 & fit_large$pip <= 1))\n expect_true(all(fit_small$pip >= 0 & fit_small$pip <= 1))\n # PIPs should differ\n expect_false(all(abs(fit_large$pip - fit_small$pip) < 1e-6))\n})\n\n# =============================================================================\n# Test 12: K=1 individual data exact match (L=1, single iteration)\n# =============================================================================\ntest_that(\"K=1 mixture is numerically identical for L=1 individual data\", {\n L <- 1\n fit_scalar <- susie(X, y, L = L,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n max_iter = 1)\n V_eff <- fit_scalar$V[1]\n\n fit_mixture <- susie(X, y, L = L,\n prior_variance_grid = c(V_eff),\n mixture_weights = c(1),\n estimate_residual_variance = FALSE,\n max_iter = 1)\n\n # After exactly 1 iteration with L=1, results must match to machine precision\n expect_equal(fit_scalar$alpha, fit_mixture$alpha, tolerance = .Machine$double.eps * 10)\n expect_equal(fit_scalar$mu, fit_mixture$mu, tolerance = .Machine$double.eps * 10)\n expect_equal(fit_scalar$lbf, fit_mixture$lbf, tolerance = .Machine$double.eps * 10)\n})\n" }, { "path": "tests/testthat/test_mr_ash_equivalence.R", "content": "# =============================================================================\n# Test: mr.ash vs mr.ash.rss Equivalence\n# =============================================================================\n#\n# Verifies that mr.ash (individual-level data) and mr.ash.rss (summary\n# statistics) produce equivalent results when fed the same data.\n#\n# The key mathematical relationship is:\n# mr.ash model: beta_j ~ sum_k pi_k * N(0, sigma2 * sa2[k])\n# mr.ash.rss reconstructs X'X, X'y from (bhat, shat, R, var_y, n)\n# and uses s0 as the prior variance scale (multiplied by sigma2_e internally).\n#\n# Summary statistics are derived from individual data as:\n# bhat_j = X_j'y / X_j'X_j (univariate OLS)\n# shat_j = sqrt(RSS_j / ((n-2) * X_j'X_j)) (standard error with n-2 df)\n# R = cor(X)\n# var_y = var(y)\n# =============================================================================\n\n# Helper: derive summary statistics from individual data\n# Uses n-2 df for shat to match the PVE adjustment in mr.ash.rss\nderive_summary_stats <- function(X, y) {\n n <- nrow(X)\n p <- ncol(X)\n bhat <- sapply(1:p, function(j) sum(X[, j] * y) / sum(X[, j]^2))\n shat <- sapply(1:p, function(j) {\n resid <- y - X[, j] * bhat[j]\n sqrt(sum(resid^2) / ((n - 2) * sum(X[, j]^2)))\n })\n R_mat <- cor(X)\n var_y <- c(var(y))\n list(bhat = bhat, shat = shat, R = R_mat, var_y = var_y, n = n)\n}\n\n# Helper: generate test data and prior\nsetup_mr_ash_test <- function(n = 100, p = 50, k = 5, seed = 42) {\n set.seed(seed)\n X <- matrix(rnorm(n * p), n, p)\n X <- scale(X, center = TRUE, scale = FALSE)\n beta_true <- rep(0, p)\n causal <- sample(1:p, k)\n beta_true[causal] <- rnorm(k, sd = 2)\n y <- c(X %*% beta_true + rnorm(n))\n y <- y - mean(y)\n\n # Prior matching mr.ash defaults\n sa2 <- c(0, (2^((1:19) / 20) - 1)^2)\n w <- colSums(X^2)\n sa2 <- sa2 / median(w) * n\n K <- length(sa2)\n pi0 <- rep(1 / K, K)\n sigma2_init <- c(var(y))\n\n list(\n X = X, y = y, n = n, p = p,\n sa2 = sa2, K = K, pi0 = pi0, sigma2_init = sigma2_init\n )\n}\n\ntest_that(\"mr.ash and mr.ash.rss produce identical beta with fixed sigma and pi\", {\n d <- setup_mr_ash_test(n = 100, p = 50, k = 5, seed = 42)\n\n fit_ind <- mr.ash(d$X, d$y,\n sa2 = d$sa2, pi = d$pi0, sigma2 = d$sigma2_init,\n intercept = FALSE, standardize = FALSE,\n update.sigma2 = FALSE, update.pi = FALSE,\n max.iter = 100, verbose = FALSE\n )\n\n ss <- derive_summary_stats(d$X, d$y)\n fit_rss <- mr.ash.rss(\n bhat = ss$bhat, shat = ss$shat, R = ss$R,\n var_y = ss$var_y, n = ss$n,\n sigma2_e = d$sigma2_init, s0 = d$sa2, w0 = d$pi0,\n tol = 1e-4, max_iter = 100,\n update_w0 = FALSE, update_sigma = FALSE\n )\n\n # Should match to near-machine precision (ignore dim attributes from Armadillo)\n expect_equal(c(fit_rss$beta), c(fit_ind$beta), tolerance = 1e-10)\n expect_equal(c(fit_rss$sigma2), c(fit_ind$sigma2), tolerance = 1e-10)\n expect_equal(c(fit_rss$pi), c(fit_ind$pi), tolerance = 1e-10)\n})\n\ntest_that(\"mr.ash and mr.ash.rss agree with sigma2 updates enabled\", {\n d <- setup_mr_ash_test(n = 100, p = 50, k = 5, seed = 42)\n\n fit_ind <- mr.ash(d$X, d$y,\n sa2 = d$sa2, pi = d$pi0, sigma2 = d$sigma2_init,\n intercept = FALSE, standardize = FALSE,\n update.sigma2 = TRUE, update.pi = FALSE,\n max.iter = 200, verbose = FALSE\n )\n\n ss <- derive_summary_stats(d$X, d$y)\n fit_rss <- mr.ash.rss(\n bhat = ss$bhat, shat = ss$shat, R = ss$R,\n var_y = ss$var_y, n = ss$n,\n sigma2_e = d$sigma2_init, s0 = d$sa2, w0 = d$pi0,\n tol = 1e-4, max_iter = 200,\n update_w0 = FALSE, update_sigma = TRUE\n )\n\n expect_equal(c(fit_rss$beta), c(fit_ind$beta), tolerance = 1e-3)\n expect_equal(c(fit_rss$sigma2), c(fit_ind$sigma2), tolerance = 1e-4)\n})\n\ntest_that(\"mr.ash and mr.ash.rss agree with full EM (sigma + pi updates)\", {\n d <- setup_mr_ash_test(n = 100, p = 50, k = 5, seed = 42)\n\n fit_ind <- mr.ash(d$X, d$y,\n sa2 = d$sa2, pi = d$pi0, sigma2 = d$sigma2_init,\n intercept = FALSE, standardize = FALSE,\n update.sigma2 = TRUE, update.pi = TRUE,\n max.iter = 200, verbose = FALSE\n )\n\n ss <- derive_summary_stats(d$X, d$y)\n fit_rss <- mr.ash.rss(\n bhat = ss$bhat, shat = ss$shat, R = ss$R,\n var_y = ss$var_y, n = ss$n,\n sigma2_e = d$sigma2_init, s0 = d$sa2, w0 = d$pi0,\n tol = 1e-4, max_iter = 200,\n update_w0 = TRUE, update_sigma = TRUE\n )\n\n expect_equal(c(fit_rss$beta), c(fit_ind$beta), tolerance = 1e-3)\n expect_equal(c(fit_rss$sigma2), c(fit_ind$sigma2), tolerance = 1e-3)\n expect_equal(c(fit_rss$pi), c(fit_ind$pi), tolerance = 1e-2)\n})\n\ntest_that(\"mr.ash.rss output format matches mr.ash\", {\n d <- setup_mr_ash_test(n = 80, p = 20, k = 3, seed = 123)\n\n ss <- derive_summary_stats(d$X, d$y)\n fit_rss <- mr.ash.rss(\n bhat = ss$bhat, shat = ss$shat, R = ss$R,\n var_y = ss$var_y, n = ss$n,\n sigma2_e = 1.0, s0 = d$sa2, w0 = d$pi0,\n tol = 1e-4, max_iter = 100,\n update_w0 = FALSE, update_sigma = FALSE\n )\n\n # Check that mr.ash-compatible fields exist and have correct types\n expect_true(is.numeric(fit_rss$beta))\n expect_true(is.numeric(fit_rss$sigma2))\n expect_true(is.numeric(fit_rss$pi))\n expect_true(is.integer(fit_rss$iter))\n expect_true(is.numeric(fit_rss$varobj))\n\n # Check dimensions\n expect_length(fit_rss$beta, d$p)\n expect_length(fit_rss$sigma2, 1)\n expect_length(fit_rss$pi, d$K)\n expect_true(fit_rss$iter > 0)\n expect_true(length(fit_rss$varobj) > 0)\n expect_true(length(fit_rss$varobj) <= 100)\n\n # Original RSS-specific fields also present\n expect_true(!is.null(fit_rss$mu1))\n expect_true(!is.null(fit_rss$sigma2_1))\n expect_true(!is.null(fit_rss$w1))\n expect_true(!is.null(fit_rss$sigma2_e))\n expect_true(!is.null(fit_rss$w0))\n})\n\ntest_that(\"mr.ash and mr.ash.rss agree on different data sizes\", {\n # Test with a wider range of n, p combinations\n for (params in list(\n list(n = 80, p = 20, k = 3, seed = 100),\n list(n = 200, p = 30, k = 5, seed = 200)\n )) {\n d <- setup_mr_ash_test(\n n = params$n, p = params$p,\n k = params$k, seed = params$seed\n )\n\n fit_ind <- mr.ash(d$X, d$y,\n sa2 = d$sa2, pi = d$pi0, sigma2 = d$sigma2_init,\n intercept = FALSE, standardize = FALSE,\n update.sigma2 = FALSE, update.pi = FALSE,\n max.iter = 50, verbose = FALSE\n )\n\n ss <- derive_summary_stats(d$X, d$y)\n fit_rss <- mr.ash.rss(\n bhat = ss$bhat, shat = ss$shat, R = ss$R,\n var_y = ss$var_y, n = ss$n,\n sigma2_e = d$sigma2_init, s0 = d$sa2, w0 = d$pi0,\n tol = 1e-4, max_iter = 50,\n update_w0 = FALSE, update_sigma = FALSE\n )\n\n expect_equal(c(fit_rss$beta), c(fit_ind$beta), tolerance = 1e-10,\n label = sprintf(\"beta (n=%d, p=%d)\", params$n, params$p)\n )\n }\n})\n" }, { "path": "tests/testthat/test_plotting.R", "content": "context(\"Plotting functions\")\n\n# =============================================================================\n# SUSIE_PLOT - BASIC FUNCTIONALITY\n# =============================================================================\n\ntest_that(\"susie_plot with PIP creates plot without error\", {\n set.seed(1)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Should not error\n expect_error(\n susie_plot(fit, \"PIP\"),\n NA\n )\n})\n\ntest_that(\"susie_plot with z-scores requires compute_univariate_zscore\", {\n set.seed(2)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, compute_univariate_zscore = FALSE, verbose = FALSE)\n\n # Should error when z-scores not computed\n expect_error(\n susie_plot(fit, \"z\"),\n \"z-scores are not available\"\n )\n})\n\ntest_that(\"susie_plot with z_original also requires z-scores\", {\n set.seed(51)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, compute_univariate_zscore = FALSE, verbose = FALSE)\n\n # Should error when trying to plot z_original without z-scores\n expect_error(\n susie_plot(fit, \"z_original\"),\n \"z-scores are not available\"\n )\n})\n\ntest_that(\"susie_plot with z-scores works when available\", {\n set.seed(3)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, compute_univariate_zscore = TRUE, verbose = FALSE)\n\n # Should not error\n expect_error(\n susie_plot(fit, \"z\"),\n NA\n )\n})\n\ntest_that(\"susie_plot with z_original works\", {\n set.seed(4)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, compute_univariate_zscore = TRUE, verbose = FALSE)\n\n expect_error(\n susie_plot(fit, \"z_original\"),\n NA\n )\n})\n\ntest_that(\"susie_plot with log10PIP works\", {\n set.seed(5)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n expect_error(\n susie_plot(fit, \"log10PIP\"),\n NA\n )\n})\n\ntest_that(\"susie_plot with invalid y type errors\", {\n set.seed(6)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n expect_error(\n susie_plot(fit, \"invalid_type\"),\n \"Need to specify\"\n )\n})\n\ntest_that(\"susie_plot errors when pos list missing required elements\", {\n set.seed(34)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n fit$genomic_position <- 1000 + (1:length(fit$pip))\n\n # Missing 'attr'\n expect_error(\n susie_plot(fit, \"PIP\", pos = list(start = 1000, end = 1025)),\n \"pos argument should be a list\"\n )\n\n # Missing 'start'\n expect_error(\n susie_plot(fit, \"PIP\", pos = list(attr = \"genomic_position\", end = 1025)),\n \"pos argument should be a list\"\n )\n\n # Missing 'end'\n expect_error(\n susie_plot(fit, \"PIP\", pos = list(attr = \"genomic_position\", start = 1000)),\n \"pos argument should be a list\"\n )\n})\n\ntest_that(\"susie_plot errors when pos$attr not in model\", {\n set.seed(35)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n expect_error(\n susie_plot(fit, \"PIP\", pos = list(attr = \"nonexistent_attr\", start = 1, end = 25)),\n \"Cannot find attribute nonexistent_attr\"\n )\n})\n\ntest_that(\"susie_plot errors when pos$start >= pos$end\", {\n set.seed(36)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n fit$genomic_position <- 1000 + (1:length(fit$pip))\n\n expect_error(\n susie_plot(fit, \"PIP\", pos = list(attr = \"genomic_position\", start = 1025, end = 1000)),\n \"Position start should be smaller than end\"\n )\n\n # Equal values\n expect_error(\n susie_plot(fit, \"PIP\", pos = list(attr = \"genomic_position\", start = 1000, end = 1000)),\n \"Position start should be smaller than end\"\n )\n})\n\ntest_that(\"susie_plot errors when numeric pos outside range\", {\n set.seed(37)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n expect_error(\n susie_plot(fit, \"PIP\", pos = 1:100), # Only 50 variables\n \"Provided position is outside the range\"\n )\n\n expect_error(\n susie_plot(fit, \"PIP\", pos = c(0, 1, 2)), # 0 is out of range\n \"Provided position is outside the range\"\n )\n})\n\n# =============================================================================\n# SUSIE_PLOT - PARAMETERS\n# =============================================================================\n\ntest_that(\"susie_plot with add_bar=TRUE works\", {\n set.seed(7)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n expect_error(\n susie_plot(fit, \"PIP\", add_bar = TRUE),\n NA\n )\n})\n\ntest_that(\"susie_plot with add_legend=TRUE works\", {\n set.seed(8)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n expect_error(\n susie_plot(fit, \"PIP\", add_legend = TRUE),\n NA\n )\n})\n\ntest_that(\"susie_plot with add_legend location string works\", {\n set.seed(9)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n expect_error(\n susie_plot(fit, \"PIP\", add_legend = \"bottomright\"),\n NA\n )\n})\n\ntest_that(\"susie_plot with pos as numeric vector works\", {\n set.seed(10)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Plot subset of variables\n expect_error(\n susie_plot(fit, \"PIP\", pos = 1:25),\n NA\n )\n})\n\ntest_that(\"susie_plot with pos as list works\", {\n set.seed(11)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n fit$genomic_position <- 1000 + (1:length(fit$pip))\n\n # Plot with custom position attribute\n expect_error(\n susie_plot(fit, \"PIP\", pos = list(attr = \"genomic_position\", start = 1000, end = 1025)),\n NA\n )\n})\n\ntest_that(\"susie_plot with b (true effects) works\", {\n set.seed(12)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Highlight true effects\n expect_error(\n susie_plot(fit, \"PIP\", b = dat$beta),\n NA\n )\n})\n\ntest_that(\"susie_plot with max_cs parameter works\", {\n set.seed(13)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n # Limit number of CS displayed\n expect_error(\n susie_plot(fit, \"PIP\", max_cs = 2),\n NA\n )\n})\n\ntest_that(\"susie_plot with max_cs purity threshold works\", {\n set.seed(38)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n # Filter by purity (< 1)\n expect_error(\n susie_plot(fit, \"PIP\", max_cs = 0.5, add_legend = TRUE),\n NA\n )\n\n # Very strict purity filter (should exclude most/all CS)\n expect_error(\n susie_plot(fit, \"PIP\", max_cs = 0.99),\n NA\n )\n\n # Very lenient purity filter\n expect_error(\n susie_plot(fit, \"PIP\", max_cs = 0.1),\n NA\n )\n})\n\ntest_that(\"susie_plot with different legend positions works\", {\n set.seed(39)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n positions <- c(\"topleft\", \"top\", \"left\", \"center\",\n \"right\", \"bottomleft\", \"bottom\")\n\n for (pos in positions) {\n expect_error(\n susie_plot(fit, \"PIP\", add_legend = pos),\n NA,\n info = paste(\"Failed for legend position:\", pos)\n )\n }\n})\n\ntest_that(\"susie_plot with invalid legend position defaults to topright\", {\n set.seed(40)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n # Invalid position should default to \"topright\" (no error)\n expect_error(\n susie_plot(fit, \"PIP\", add_legend = \"invalid_position\"),\n NA\n )\n})\n\ntest_that(\"susie_plot respects custom plotting parameters\", {\n set.seed(41)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Test various plotting parameters\n expect_error(\n susie_plot(fit, \"PIP\", main = \"Custom Title\", col = \"blue\", cex = 0.5),\n NA\n )\n\n expect_error(\n susie_plot(fit, \"PIP\", xlim = c(0, 30), ylim = c(0, 1)),\n NA\n )\n})\n\n# =============================================================================\n# SUSIE_PLOT - VECTOR INPUT\n# =============================================================================\n\ntest_that(\"susie_plot with PIP vector input works\", {\n set.seed(14)\n pip <- runif(50)\n\n expect_error(\n susie_plot(pip, \"PIP\"),\n NA\n )\n})\n\ntest_that(\"susie_plot with z-score vector input works\", {\n set.seed(15)\n z <- rnorm(50)\n\n expect_error(\n susie_plot(z, \"z\"),\n NA\n )\n})\n\ntest_that(\"susie_plot with non-susie vector and different y types\", {\n set.seed(42)\n\n # Test with z_original on vector\n z_vec <- rnorm(50)\n expect_error(susie_plot(z_vec, \"z_original\"), NA)\n\n # Test with log10PIP on vector\n pip_vec <- runif(50)\n expect_error(susie_plot(pip_vec, \"log10PIP\"), NA)\n\n # Test with generic data (not PIP, z, etc.)\n data_vec <- runif(50, 0, 10)\n expect_error(susie_plot(data_vec, \"custom_data\"), NA)\n})\n\n# =============================================================================\n# SUSIE_PLOT - EDGE CASES\n# =============================================================================\n\ntest_that(\"susie_plot with no credible sets works\", {\n set.seed(16)\n dat <- simulate_regression(n = 100, p = 50, k = 0) # No signal\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n expect_error(\n susie_plot(fit, \"PIP\"),\n NA\n )\n})\n\ntest_that(\"susie_plot with single variable works\", {\n set.seed(17)\n dat <- simulate_regression(n = 100, p = 1, k = 1)\n fit <- susie(dat$X, dat$y, L = 1, verbose = FALSE)\n\n expect_error(\n susie_plot(fit, \"PIP\"),\n NA\n )\n})\n\ntest_that(\"susie_plot returns NULL invisibly\", {\n set.seed(18)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n result <- susie_plot(fit, \"PIP\")\n\n expect_null(result)\n})\n\ntest_that(\"susie_plot with list pos and credible sets adjusts correctly\", {\n set.seed(43)\n # Create data with clear signal so we get CS\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$genomic_position <- 1000 + (1:length(fit$pip))\n\n # Should successfully plot with CS adjusted to new positions\n expect_error(\n susie_plot(fit, \"PIP\",\n pos = list(attr = \"genomic_position\", start = 1000, end = 1050),\n add_legend = TRUE),\n NA\n )\n})\n\ntest_that(\"susie_plot with b parameter highlights specific positions\", {\n set.seed(44)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Test with b having non-zero elements at specific positions\n b_test <- rep(0, 50)\n b_test[c(10, 20, 30)] <- 1\n expect_error(\n susie_plot(fit, \"PIP\", b = b_test),\n NA\n )\n\n # Test with actual beta from simulation and add_bar\n expect_error(\n susie_plot(fit, \"PIP\", b = dat$beta, add_bar = TRUE, add_legend = TRUE),\n NA\n )\n})\n\ntest_that(\"susie_plot sets x0 and y1 to NULL when CS filtered by max_cs\", {\n set.seed(52)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n # Get CS with purity info\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n if (!is.null(fit$sets$cs) && length(fit$sets$cs) > 0) {\n # Use very strict max_cs filter (size < 1) to exclude CS\n # This should trigger the else branch: x0 <- NULL; y1 <- NULL\n expect_error(\n susie_plot(fit, \"PIP\", max_cs = 1, add_legend = TRUE), # Only CS with size < 1\n NA\n )\n\n # Also test with very high purity threshold (max_cs as purity)\n expect_error(\n susie_plot(fit, \"PIP\", max_cs = 0.999, add_legend = TRUE), # Very high purity\n NA\n )\n } else {\n skip(\"No CS found for max_cs filter test\")\n }\n})\n\ntest_that(\"susie_plot skips CS when x0 is NULL (next statement)\", {\n set.seed(53)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n # Get CS\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n if (!is.null(fit$sets$cs) && length(fit$sets$cs) > 0) {\n # Use max_cs to filter out large CS, causing is.null(x0) to be TRUE\n # This should trigger the next statement to skip those CS\n expect_error(\n susie_plot(fit, \"PIP\", max_cs = 2), # Skip CS with > 2 variables\n NA\n )\n } else {\n skip(\"No CS found for next statement test\")\n }\n})\n\ntest_that(\"susie_plot uses cs_index when available (else uses cs_idx)\", {\n set.seed(54)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n # Get CS which should populate cs_index\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n if (!is.null(fit$sets$cs) && length(fit$sets$cs) > 0) {\n # When cs_index exists, should use it\n expect_true(!is.null(fit$sets$cs_index))\n\n # Plot with legend to see cs_index values\n expect_error(\n susie_plot(fit, \"PIP\", add_legend = TRUE),\n NA\n )\n\n # Test the else branch: remove cs_index to force use of cs_idx\n fit_no_index <- fit\n fit_no_index$sets$cs_index <- NULL\n\n expect_error(\n susie_plot(fit_no_index, \"PIP\", add_legend = TRUE),\n NA\n )\n } else {\n skip(\"No CS found for cs_index test\")\n }\n})\n\n# =============================================================================\n# SUSIE_PLOT_ITERATION\n# =============================================================================\n\ntest_that(\"susie_plot_iteration uses tempdir when file_prefix missing\", {\n set.seed(55)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, track_fit = FALSE, verbose = FALSE)\n\n # Don't provide file_prefix - should use tempdir()\n result <- invisible(capture.output({\n suppressMessages(susie_plot_iteration(fit, L = 5))\n }, type = \"output\"))\n\n # Check that file was created in tempdir\n expected_path <- file.path(tempdir(), \"susie_plot.pdf\")\n expect_true(file.exists(expected_path))\n\n # Clean up\n if (file.exists(expected_path)) file.remove(expected_path)\n})\n\ntest_that(\"susie_plot_iteration with track_fit=FALSE uses final fit only\", {\n set.seed(19)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n # Without track_fit\n fit <- susie(dat$X, dat$y, L = 5, track_fit = FALSE, verbose = FALSE)\n\n temp_prefix <- tempfile(\"susie_iter_no_track_\")\n\n # Should work but only plot final iteration\n expect_error({\n invisible(capture.output({\n suppressMessages(susie_plot_iteration(fit, L = 5, file_prefix = temp_prefix))\n }, type = \"output\"))\n }, NA)\n\n # Clean up\n temp_files <- list.files(dirname(temp_prefix),\n pattern = basename(temp_prefix),\n full.names = TRUE)\n file.remove(temp_files)\n})\n\ntest_that(\"susie_plot_iteration works with track_fit=TRUE\", {\n set.seed(20)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n # With track_fit\n fit <- susie(dat$X, dat$y, L = 5, track_fit = TRUE, max_iter = 10, verbose = FALSE)\n\n # Create temp file for output\n temp_prefix <- tempfile(\"susie_iter_\")\n\n expect_error({\n invisible(capture.output({\n suppressMessages(susie_plot_iteration(fit, L = 5, file_prefix = temp_prefix))\n }, type = \"output\"))\n }, NA)\n\n # Clean up temp files\n temp_files <- list.files(dirname(temp_prefix),\n pattern = basename(temp_prefix),\n full.names = TRUE)\n file.remove(temp_files)\n})\n\ntest_that(\"susie_plot_iteration with pos parameter works\", {\n set.seed(21)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 5, track_fit = TRUE, max_iter = 10, verbose = FALSE)\n\n temp_prefix <- tempfile(\"susie_iter_pos_\")\n\n expect_error({\n invisible(capture.output({\n suppressMessages(susie_plot_iteration(fit, L = 5, file_prefix = temp_prefix, pos = 1:25))\n }, type = \"output\"))\n }, NA)\n\n # Clean up\n temp_files <- list.files(dirname(temp_prefix),\n pattern = basename(temp_prefix),\n full.names = TRUE)\n file.remove(temp_files)\n})\n\ntest_that(\"susie_plot_iteration creates PDF files\", {\n set.seed(22)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 5, track_fit = TRUE, max_iter = 5, verbose = FALSE)\n\n temp_dir <- tempdir()\n temp_prefix <- file.path(temp_dir, \"test_susie_iter\")\n\n invisible(capture.output({\n suppressMessages(susie_plot_iteration(fit, L = 5, file_prefix = temp_prefix))\n }, type = \"output\"))\n\n # Check that PDF files were created\n pdf_files <- list.files(temp_dir, pattern = \"test_susie_iter.*\\\\.pdf$\", full.names = TRUE)\n\n expect_true(length(pdf_files) > 0)\n\n # Clean up\n file.remove(pdf_files)\n})\n\ntest_that(\"susie_plot_iteration with L greater than nrow(alpha)\", {\n set.seed(45)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 3, track_fit = TRUE, verbose = FALSE)\n\n temp_prefix <- tempfile(\"test_large_L_\")\n\n # Request L=10 when fit only has L=3\n expect_error({\n invisible(capture.output({\n suppressMessages(susie_plot_iteration(fit, L = 10, file_prefix = temp_prefix))\n }, type = \"output\"))\n }, NA)\n\n # Clean up\n temp_files <- list.files(dirname(temp_prefix),\n pattern = basename(temp_prefix),\n full.names = TRUE)\n if (length(temp_files) > 0) file.remove(temp_files)\n})\n\ntest_that(\"susie_plot_iteration with few iterations\", {\n set.seed(46)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n # Use max_iter=5 to ensure we have some iterations tracked\n fit <- susie(dat$X, dat$y, L = 5, track_fit = TRUE, max_iter = 5, verbose = FALSE)\n\n temp_prefix <- tempfile(\"test_few_iter_\")\n\n expect_error({\n invisible(capture.output({\n suppressMessages(susie_plot_iteration(fit, L = 5, file_prefix = temp_prefix))\n }, type = \"output\"))\n }, NA)\n\n # Clean up\n temp_files <- list.files(dirname(temp_prefix),\n pattern = basename(temp_prefix),\n full.names = TRUE)\n if (length(temp_files) > 0) file.remove(temp_files)\n})\n\ntest_that(\"susie_plot_iteration returns invisibly\", {\n set.seed(47)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, track_fit = FALSE, verbose = FALSE)\n\n temp_prefix <- tempfile(\"test_invisible_\")\n\n invisible(capture.output({\n result <- suppressMessages(susie_plot_iteration(fit, L = 5, file_prefix = temp_prefix))\n }, type = \"output\"))\n\n expect_null(result)\n\n # Clean up\n temp_files <- list.files(dirname(temp_prefix),\n pattern = basename(temp_prefix),\n full.names = TRUE)\n if (length(temp_files) > 0) file.remove(temp_files)\n})\n\n# =============================================================================\n# SUSIE_PLOT_CHANGEPOINT\n# =============================================================================\n\ntest_that(\"susie_plot_changepoint with basic usage works\", {\n set.seed(23)\n mu <- c(rep(0, 25), rep(2, 25), rep(-1, 25), rep(1, 25))\n y <- mu + rnorm(100, sd = 0.5)\n\n s <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n expect_error(\n susie_plot_changepoint(s, y),\n NA\n )\n})\n\ntest_that(\"susie_plot_changepoint with custom colors works\", {\n set.seed(24)\n mu <- c(rep(0, 30), rep(2, 30))\n y <- mu + rnorm(60, sd = 0.3)\n\n s <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n expect_error(\n susie_plot_changepoint(s, y, line_col = \"red\", line_size = 2),\n NA\n )\n})\n\ntest_that(\"susie_plot_changepoint with cs_col parameter works\", {\n set.seed(25)\n mu <- c(rep(0, 30), rep(2, 30))\n y <- mu + rnorm(60, sd = 0.3)\n\n s <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n expect_error(\n susie_plot_changepoint(s, y, cs_col = \"green\"),\n NA\n )\n})\n\ntest_that(\"susie_plot_changepoint with single changepoint works\", {\n set.seed(28)\n mu <- c(rep(0, 30), rep(2, 30))\n y <- mu + rnorm(60, sd = 0.3)\n\n s <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n expect_error(\n susie_plot_changepoint(s, y),\n NA\n )\n})\n\ntest_that(\"susie_plot_changepoint with no changepoints works\", {\n set.seed(29)\n y <- rnorm(50, mean = 5, sd = 0.5)\n\n s <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n expect_error(\n susie_plot_changepoint(s, y),\n NA\n )\n})\n\ntest_that(\"susie_plot_changepoint returns ggplot object\", {\n set.seed(30)\n mu <- c(rep(0, 30), rep(2, 30))\n y <- mu + rnorm(60, sd = 0.3)\n\n s <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n result <- susie_plot_changepoint(s, y)\n\n expect_s3_class(result, \"gg\")\n expect_s3_class(result, \"ggplot\")\n})\n\ntest_that(\"susie_plot_changepoint with multiple changepoints\", {\n set.seed(48)\n # Create data with multiple clear changepoints\n mu <- c(rep(0, 25), rep(2, 25), rep(-1, 25), rep(1, 25))\n y <- mu + rnorm(100, sd = 0.3)\n\n s <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n result <- susie_plot_changepoint(s, y)\n\n # Verify it's a ggplot object\n expect_s3_class(result, \"gg\")\n\n # Check that CS were found\n cs <- susie_get_cs(s)\n expect_true(length(cs$cs) > 0)\n})\n\ntest_that(\"susie_plot_changepoint with very strong signal\", {\n set.seed(49)\n # Very clear changepoints with low noise\n mu <- c(rep(0, 30), rep(5, 30))\n y <- mu + rnorm(60, sd = 0.1)\n\n s <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n result <- susie_plot_changepoint(s, y, line_col = \"red\", line_size = 2, cs_col = \"blue\")\n\n expect_s3_class(result, \"gg\")\n expect_s3_class(result, \"ggplot\")\n})\n\ntest_that(\"susie_plot_changepoint can be modified after creation\", {\n set.seed(50)\n mu <- c(rep(0, 30), rep(2, 30))\n y <- mu + rnorm(60, sd = 0.3)\n\n s <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n # Use all defaults\n result <- susie_plot_changepoint(s, y)\n\n expect_s3_class(result, \"ggplot\")\n\n # Can add to the plot after creation\n expect_error(\n result + ggplot2::ggtitle(\"Custom Title\"),\n NA\n )\n})\n\n# =============================================================================\n# INTEGRATION TESTS\n# =============================================================================\n\ntest_that(\"susie_plot works with susie_ss output\", {\n set.seed(31)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_summary_stats(dat$X, dat$y)\n\n fit <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5, verbose = FALSE)\n\n expect_error(\n susie_plot(fit, \"PIP\"),\n NA\n )\n})\n\ntest_that(\"susie_plot works with susie_rss output\", {\n set.seed(32)\n n <- 200\n p <- 100\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n beta[1:3] <- 1\n y <- X %*% beta + rnorm(n)\n\n ss <- univariate_regression(X, y)\n R <- cor(X)\n z <- with(ss, betahat / sebetahat)\n\n fit <- susie_rss(z, R, n = n, L = 5, verbose = FALSE)\n\n expect_error(\n susie_plot(fit, \"PIP\"),\n NA\n )\n})\n\ntest_that(\"all three plot functions work in sequence\", {\n set.seed(33)\n\n # Regular susie fit\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit1 <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n expect_error(susie_plot(fit1, \"PIP\"), NA)\n\n # Trendfilter\n mu <- c(rep(0, 30), rep(2, 30))\n y <- mu + rnorm(60, sd = 0.3)\n fit2 <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n expect_error(susie_plot_changepoint(fit2, y), NA)\n\n # Iteration plot\n fit3 <- susie(dat$X, dat$y, L = 5, track_fit = TRUE, max_iter = 5, verbose = FALSE)\n temp_prefix <- tempfile(\"test_seq_\")\n\n expect_error({\n invisible(capture.output({\n suppressMessages(susie_plot_iteration(fit3, L = 5, file_prefix = temp_prefix))\n }, type = \"output\"))\n }, NA)\n\n # Clean up\n temp_files <- list.files(dirname(temp_prefix),\n pattern = basename(temp_prefix),\n full.names = TRUE)\n file.remove(temp_files)\n})\n" }, { "path": "tests/testthat/test_post_outcome_configuration_summary.R", "content": "# Tests for `summary.susie_post_outcome_configuration` and its print\n# method. The numerical algorithms (susiex / coloc_pairwise) are exercised\n# in mfsusieR's `tests/testthat/test_susie_post_outcome_configuration.R`\n# against a verbatim port of the legacy `mvf.susie.alpha::posthoc_multfsusie`\n# kernel; here we focus on:\n# * dispatch via class tag\n# * tidy-table shape and column names\n# * signal_only filtering and the kept/total bookkeeping\n# * defensive handling of malformed / partial input\n\n# ---- Helpers --------------------------------------------------------------\n\n# A minimal hand-built `susiex` tuple (skips the IBSS + algorithm and\n# constructs the documented fields directly).\nmake_susiex_tuple <- function(trait_names,\n cs_indices,\n marginal_prob,\n top_config_idx = 1L,\n prob_thresh = 0.8) {\n N <- length(trait_names)\n configs <- as.matrix(expand.grid(rep(list(c(0L, 1L)), N)))\n colnames(configs) <- paste0(\"trait_\", seq_len(N))\n cp <- numeric(2L^N)\n cp[top_config_idx] <- 1\n list(\n cs_indices = setNames(as.integer(cs_indices), trait_names),\n logBF_trait = setNames(rep(0, N), trait_names),\n configs = configs,\n config_prob = cp,\n marginal_prob = setNames(marginal_prob, trait_names),\n active = setNames(marginal_prob >= prob_thresh, trait_names)\n )\n}\n\nmake_post_obj <- function(susiex = NULL, coloc = NULL) {\n out <- list()\n if (!is.null(susiex)) out$susiex <- susiex\n if (!is.null(coloc)) out$coloc_pairwise <- coloc\n class(out) <- c(\"susie_post_outcome_configuration\", \"list\")\n out\n}\n\nmake_coloc_df <- function(rows) {\n do.call(rbind, lapply(rows, function(r) {\n pp <- r$pp\n data.frame(trait1 = r$t1, trait2 = r$t2,\n l1 = r$l1, l2 = r$l2,\n hit1 = r$h1, hit2 = r$h2,\n PP.H0 = pp[1], PP.H1 = pp[2], PP.H2 = pp[3],\n PP.H3 = pp[4], PP.H4 = pp[5],\n stringsAsFactors = FALSE, row.names = NULL)\n }))\n}\n\n# ---- Dispatch -------------------------------------------------------------\n\ntest_that(\"summary() dispatches on the class tag\", {\n obj <- make_post_obj(\n susiex = list(make_susiex_tuple(c(\"a\", \"b\"),\n cs_indices = c(1, 1),\n marginal_prob = c(0.95, 0.95))))\n s <- summary(obj, color = FALSE)\n expect_s3_class(s, \"summary.susie_post_outcome_configuration\")\n # Print returns input invisibly without erroring.\n out <- capture.output(p <- print(s))\n expect_identical(p, s)\n # The captured output mentions the SuSiEx header.\n expect_true(any(grepl(\"SuSiEx:\", out)))\n})\n\n# ---- Tidy table shape -----------------------------------------------------\n\ntest_that(\"susiex tidy table carries one row per CS tuple with reserved + per-trait columns\", {\n tuples <- list(\n make_susiex_tuple(c(\"trait_a\", \"trait_b\"),\n cs_indices = c(1, 1),\n marginal_prob = c(0.95, 0.30)),\n make_susiex_tuple(c(\"trait_a\", \"trait_b\"),\n cs_indices = c(2, 2),\n marginal_prob = c(0.10, 0.92)))\n s <- summary(make_post_obj(susiex = tuples), color = FALSE,\n signal_only = FALSE)\n expect_s3_class(s$susiex, \"data.frame\")\n expect_equal(nrow(s$susiex), 2L)\n expect_setequal(colnames(s$susiex),\n c(\"tuple\", \"trait_a\", \"trait_b\", \"top_pattern\", \"top_prob\"))\n expect_equal(s$susiex$tuple, c(\"(1,1)\", \"(2,2)\"))\n expect_equal(s$susiex$trait_a, c(0.95, 0.10))\n})\n\ntest_that(\"coloc tidy table extends the input data.frame with verdict and top_pp\", {\n rows <- list(\n list(t1 = \"A\", t2 = \"B\", l1 = 1, l2 = 1, h1 = \"rs1\", h2 = \"rs1\",\n pp = c(0.001, 0.001, 0.001, 0.05, 0.947)),\n list(t1 = \"A\", t2 = \"C\", l1 = 1, l2 = 1, h1 = \"rs1\", h2 = \"rs9\",\n pp = c(0.99, 0.005, 0.002, 0.002, 0.001))) # H0 dominant\n s <- summary(make_post_obj(coloc = make_coloc_df(rows)),\n color = FALSE, signal_only = FALSE)\n expect_s3_class(s$coloc_pairwise, \"data.frame\")\n expect_equal(nrow(s$coloc_pairwise), 2L)\n expect_true(all(c(\"verdict\", \"top_pp\") %in% colnames(s$coloc_pairwise)))\n expect_equal(s$coloc_pairwise$verdict, c(\"H4 shared\", \"H0 no signal\"))\n expect_equal(s$coloc_pairwise$top_pp, c(0.947, 0.990), tolerance = 1e-9)\n})\n\n# ---- signal_only filtering + bookkeeping ----------------------------------\n\ntest_that(\"signal_only drops below-threshold susiex rows and counts them in n_total/n_kept\", {\n tuples <- list(\n make_susiex_tuple(c(\"a\", \"b\"),\n cs_indices = c(1, 1),\n marginal_prob = c(0.95, 0.20)), # signal (a active)\n make_susiex_tuple(c(\"a\", \"b\"),\n cs_indices = c(2, 2),\n marginal_prob = c(0.40, 0.30))) # no signal\n s_filt <- summary(make_post_obj(susiex = tuples), color = FALSE,\n signal_only = TRUE)\n s_all <- summary(make_post_obj(susiex = tuples), color = FALSE,\n signal_only = FALSE)\n expect_equal(s_filt$susiex_n_total, 2L)\n expect_equal(s_filt$susiex_n_kept, 1L)\n expect_equal(s_all$susiex_n_kept, 2L)\n expect_equal(s_filt$susiex$tuple, \"(1,1)\")\n})\n\ntest_that(\"signal_only drops H0-dominant coloc rows and footers the count\", {\n rows <- list(\n list(t1 = \"A\", t2 = \"B\", l1 = 1, l2 = 1, h1 = \"rs1\", h2 = \"rs1\",\n pp = c(0.99, 0.005, 0.002, 0.002, 0.001)), # H0\n list(t1 = \"A\", t2 = \"B\", l1 = 1, l2 = 2, h1 = \"rs1\", h2 = \"rs7\",\n pp = c(0.001, 0.001, 0.001, 0.05, 0.947))) # H4\n obj <- make_post_obj(coloc = make_coloc_df(rows))\n s <- summary(obj, color = FALSE, signal_only = TRUE)\n expect_equal(s$coloc_n_total, 2L)\n expect_equal(s$coloc_n_kept, 1L)\n out <- capture.output(print(s))\n expect_true(any(grepl(\"1/2 pairs hidden\", out)))\n})\n\n# ---- Defensive paths ------------------------------------------------------\n\ntest_that(\"summary handles entirely empty input gracefully\", {\n s <- summary(make_post_obj(), color = FALSE)\n expect_null(s$susiex)\n expect_null(s$coloc_pairwise)\n out <- capture.output(print(s))\n expect_true(any(grepl(\"no signals\", out)))\n})\n\ntest_that(\"summary tolerates susiex tuples with missing fields (skips them)\", {\n good <- make_susiex_tuple(c(\"a\", \"b\"),\n cs_indices = c(1, 1),\n marginal_prob = c(0.95, 0.95))\n broken <- list(cs_indices = c(2, 2)) # missing marginal_prob etc.\n s <- summary(make_post_obj(susiex = list(good, broken)),\n color = FALSE, signal_only = FALSE)\n expect_equal(nrow(s$susiex), 1L)\n expect_equal(s$susiex_n_total, 2L) # both counted in total\n expect_equal(s$susiex_n_kept, 1L)\n})\n\ntest_that(\"summary prefixes trait names that collide with reserved column names\", {\n # Trait literally named \"tuple\" must not clobber the CS-tuple column.\n tup <- make_susiex_tuple(c(\"tuple\", \"top_prob\"),\n cs_indices = c(1, 1),\n marginal_prob = c(0.95, 0.95))\n s <- summary(make_post_obj(susiex = list(tup)), color = FALSE)\n expect_true(\"tuple\" %in% colnames(s$susiex))\n # Reserved-name traits get a \"trait_\" prefix.\n expect_true(\"trait_tuple\" %in% colnames(s$susiex))\n expect_true(\"trait_top_prob\" %in% colnames(s$susiex))\n})\n\ntest_that(\"summary warns and skips coloc when required PP columns are missing\", {\n bad <- data.frame(trait1 = \"A\", trait2 = \"B\",\n l1 = 1, l2 = 1, hit1 = \"rs1\", hit2 = \"rs1\",\n PP.H0 = 0.5, PP.H1 = 0.5,\n stringsAsFactors = FALSE)\n expect_warning(\n s <- summary(make_post_obj(coloc = bad), color = FALSE),\n \"missing required columns\")\n expect_null(s$coloc_pairwise)\n expect_equal(s$coloc_n_total, 1L)\n expect_equal(s$coloc_n_kept, 0L)\n})\n\ntest_that(\"summary validates its arguments\", {\n obj <- make_post_obj()\n expect_error(summary(obj, prob_thresh = 1.1), \"prob_thresh\")\n expect_error(summary(obj, prob_thresh = -0.1), \"prob_thresh\")\n expect_error(summary(obj, ambiguous_lower = 0.9, prob_thresh = 0.8),\n \"ambiguous_lower\")\n expect_error(summary(obj, signal_only = NA), \"signal_only\")\n expect_error(summary(obj, color = \"yes\"), \"color\")\n})\n\n# ---- Color toggle ---------------------------------------------------------\n\ntest_that(\"color = FALSE produces ASCII-only output\", {\n obj <- make_post_obj(\n susiex = list(make_susiex_tuple(c(\"a\", \"b\"),\n cs_indices = c(1, 1),\n marginal_prob = c(0.95, 0.95))))\n out <- capture.output(print(summary(obj, color = FALSE)))\n # No ANSI escape sequences.\n expect_false(any(grepl(\"\\033\\\\[\", out)))\n})\n\ntest_that(\"color = TRUE injects ANSI escape sequences\", {\n obj <- make_post_obj(\n susiex = list(make_susiex_tuple(c(\"a\", \"b\"),\n cs_indices = c(1, 1),\n marginal_prob = c(0.95, 0.95))))\n out <- capture.output(print(summary(obj, color = TRUE)))\n expect_true(any(grepl(\"\\033\\\\[\", out)),\n info = \"Forcing color = TRUE should emit at least one ANSI SGR.\")\n})\n" }, { "path": "tests/testthat/test_refinement.R", "content": "context(\"Refinement unit tests\")\n\n# =============================================================================\n# BASIC FUNCTIONALITY\n# =============================================================================\n\ntest_that(\"run_refine returns a valid susie model\", {\n setup <- create_model_with_cs(seed = 100)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found in initial model\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(\"alpha\" %in% names(refined_model))\n expect_true(\"mu\" %in% names(refined_model))\n expect_true(\"V\" %in% names(refined_model))\n expect_true(\"sigma2\" %in% names(refined_model))\n expect_true(\"elbo\" %in% names(refined_model))\n})\n\ntest_that(\"run_refine maintains or improves ELBO\", {\n setup <- create_model_with_cs(seed = 101)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found in initial model\")\n\n initial_elbo <- susie_get_objective(setup$model)\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n final_elbo <- susie_get_objective(refined_model)\n\n expect_true(final_elbo >= initial_elbo - 1e-6)\n})\n\ntest_that(\"run_refine preserves model dimensions\", {\n setup <- create_model_with_cs(seed = 102)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found in initial model\")\n\n initial_L <- nrow(setup$model$alpha)\n initial_p <- ncol(setup$model$alpha)\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_equal(nrow(refined_model$alpha), initial_L)\n expect_equal(ncol(refined_model$alpha), initial_p)\n expect_equal(nrow(refined_model$mu), initial_L)\n expect_equal(ncol(refined_model$mu), initial_p)\n})\n\ntest_that(\"run_refine returns finite ELBO\", {\n setup <- create_model_with_cs(seed = 103)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found in initial model\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(all(is.finite(refined_model$elbo)))\n expect_true(is.finite(susie_get_objective(refined_model)))\n})\n\ntest_that(\"run_refine maintains valid probability distributions\", {\n setup <- create_model_with_cs(seed = 104)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found in initial model\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(all(refined_model$alpha >= 0))\n expect_true(all(refined_model$alpha <= 1))\n\n row_sums <- rowSums(refined_model$alpha)\n expect_true(all(abs(row_sums - 1) < 1e-10))\n})\n\n# =============================================================================\n# REFINEMENT LOGIC\n# =============================================================================\n\ntest_that(\"run_refine iterates through credible sets\", {\n setup <- create_model_with_cs(n = 200, p = 100, L = 10,\n n_causal = 3, seed = 105)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found in initial model\")\n\n n_cs_initial <- length(setup$model$sets$cs)\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(is.finite(susie_get_objective(refined_model)))\n})\n\ntest_that(\"run_refine uses two-step procedure correctly\", {\n setup <- create_model_with_cs(seed = 106)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found in initial model\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(\"alpha\" %in% names(refined_model))\n expect_true(all(refined_model$alpha >= 0 & refined_model$alpha <= 1))\n})\n\ntest_that(\"run_refine preserves prior weights structure\", {\n setup <- create_model_with_cs(seed = 107)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found in initial model\")\n\n initial_pi <- setup$model$pi\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_equal(length(refined_model$pi), length(initial_pi))\n expect_true(all(refined_model$pi >= 0))\n expect_true(abs(sum(refined_model$pi) - 1) < 1e-10)\n})\n\ntest_that(\"run_refine evaluates multiple candidate models\", {\n setup <- create_model_with_cs(n = 200, p = 100, L = 10,\n n_causal = 4, seed = 108)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) < 2,\n \"Need at least 2 credible sets\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(is.finite(susie_get_objective(refined_model)))\n})\n\n# =============================================================================\n# CONVERGENCE BEHAVIOR\n# =============================================================================\n\ntest_that(\"run_refine stops when ELBO improvement < tol\", {\n setup <- create_model_with_cs(seed = 109)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found in initial model\")\n\n params_tight_tol <- setup$params\n params_tight_tol$tol <- 1e-10\n\n refined_model <- run_refine(setup$model, setup$data, params_tight_tol)\n\n expect_true(is.finite(susie_get_objective(refined_model)))\n})\n\ntest_that(\"run_refine with loose tolerance may iterate more\", {\n setup <- create_model_with_cs(seed = 110)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found in initial model\")\n\n params_loose <- setup$params\n params_loose$tol <- 1e-1\n\n refined_model <- run_refine(setup$model, setup$data, params_loose)\n\n expect_true(is.finite(susie_get_objective(refined_model)))\n})\n\ntest_that(\"run_refine stops when no candidate models generated\", {\n setup <- create_model_with_cs(seed = 111)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found in initial model\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(\"elbo\" %in% names(refined_model))\n})\n\ntest_that(\"run_refine convergence is deterministic\", {\n setup <- create_model_with_cs(seed = 112)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found in initial model\")\n\n refined1 <- run_refine(setup$model, setup$data, setup$params)\n refined2 <- run_refine(setup$model, setup$data, setup$params)\n\n expect_equal(susie_get_objective(refined1),\n susie_get_objective(refined2))\n})\n\n# =============================================================================\n# EDGE CASES\n# =============================================================================\n\ntest_that(\"run_refine handles model with no credible sets\", {\n set.seed(113)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n\n model <- susie(X, y, L = 5, verbose = FALSE)\n\n constructor_result <- individual_data_constructor(\n X = X, y = y, L = 5,\n standardize = TRUE, intercept = TRUE,\n estimate_residual_method = \"MLE\",\n convergence_method = \"elbo\",\n coverage = 0.95, min_abs_corr = 0.5,\n n_purity = 100,\n track_fit = FALSE\n )\n\n if (is.null(model$sets) || length(model$sets$cs) == 0) {\n refined_model <- run_refine(model, constructor_result$data,\n constructor_result$params)\n\n expect_equal(susie_get_objective(refined_model),\n susie_get_objective(model))\n } else {\n skip(\"Model unexpectedly found credible sets\")\n }\n})\n\ntest_that(\"run_refine handles single credible set\", {\n setup <- create_model_with_cs(n = 200, p = 100, L = 10,\n n_causal = 1, seed = 114)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(is.finite(susie_get_objective(refined_model)))\n expect_true(susie_get_objective(refined_model) >=\n susie_get_objective(setup$model) - 1e-6)\n})\n\ntest_that(\"run_refine handles credible set with all prior weights zero\", {\n setup <- create_model_with_cs(seed = 115)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n if (length(setup$model$sets$cs) > 0) {\n cs_vars <- setup$model$sets$cs[[1]]\n\n if (length(cs_vars) < ncol(setup$model$alpha)) {\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n expect_true(is.finite(susie_get_objective(refined_model)))\n }\n }\n})\n\ntest_that(\"run_refine handles large credible set\", {\n setup <- create_model_with_cs(n = 200, p = 100, seed = 116)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(is.finite(susie_get_objective(refined_model)))\n})\n\ntest_that(\"run_refine handles small p relative to L\", {\n setup <- create_model_with_cs(n = 100, p = 10, L = 5,\n n_causal = 2, seed = 117)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(is.finite(susie_get_objective(refined_model)))\n})\n\n# =============================================================================\n# PARAMETER HANDLING\n# =============================================================================\n\ntest_that(\"run_refine respects verbose parameter\", {\n setup <- create_model_with_cs(seed = 118)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n params_verbose <- setup$params\n params_verbose$verbose <- TRUE\n\n expect_message(\n run_refine(setup$model, setup$data, params_verbose),\n \"Block ascent iter\"\n )\n})\n\ntest_that(\"run_refine verbose=FALSE produces no output\", {\n setup <- create_model_with_cs(seed = 119)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n params_silent <- setup$params\n params_silent$verbose <- FALSE\n\n expect_silent(\n run_refine(setup$model, setup$data, params_silent)\n )\n})\n\ntest_that(\"run_refine warns about model_init\", {\n setup <- create_model_with_cs(seed = 120)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n params_with_init <- setup$params\n params_with_init$model_init <- list(alpha = setup$model$alpha)\n\n expect_message(\n run_refine(setup$model, setup$data, params_with_init),\n \"model_init is not used\"\n )\n})\n\ntest_that(\"run_refine respects tolerance parameter\", {\n setup <- create_model_with_cs(seed = 121)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n params_tol1 <- setup$params\n params_tol1$tol <- 1e-2\n\n params_tol2 <- setup$params\n params_tol2$tol <- 1e-6\n\n refined1 <- run_refine(setup$model, setup$data, params_tol1)\n refined2 <- run_refine(setup$model, setup$data, params_tol2)\n\n expect_true(is.finite(susie_get_objective(refined1)))\n expect_true(is.finite(susie_get_objective(refined2)))\n})\n\ntest_that(\"run_refine preserves null_weight\", {\n setup <- create_model_with_cs(seed = 122)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n initial_null_weight <- setup$model$null_weight\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_equal(refined_model$null_weight, initial_null_weight)\n})\n\n# =============================================================================\n# INTEGRATION\n# =============================================================================\n\ntest_that(\"run_refine works with individual data\", {\n setup <- create_model_with_cs(seed = 123)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n expect_equal(class(setup$data), \"individual\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(is.finite(susie_get_objective(refined_model)))\n})\n\ntest_that(\"run_refine works with sufficient statistics\", {\n set.seed(124)\n n <- 100\n p <- 50\n X <- matrix(rnorm(n * p), n, p)\n X <- scale(X)\n\n beta <- rep(0, p)\n beta[c(5, 15, 25)] <- c(1.5, -1.2, 1.0)\n y <- as.vector(X %*% beta + rnorm(n, sd = 0.5))\n\n XtX <- crossprod(X)\n Xty <- as.vector(crossprod(X, y))\n yty <- sum(y^2)\n\n model <- susie_ss(XtX, Xty, yty, n = n, L = 5, verbose = FALSE)\n\n skip_if(is.null(model$sets) || length(model$sets$cs) == 0,\n \"No credible sets found\")\n\n constructor_result <- sufficient_stats_constructor(\n XtX = XtX, Xty = Xty, yty = yty, n = n, L = 5,\n standardize = TRUE,\n estimate_residual_method = \"MLE\",\n convergence_method = \"elbo\",\n coverage = 0.95, min_abs_corr = 0.5,\n n_purity = 100,\n track_fit = FALSE\n )\n\n refined_model <- run_refine(model, constructor_result$data,\n constructor_result$params)\n\n expect_true(is.finite(susie_get_objective(refined_model)))\n})\n\ntest_that(\"run_refine output compatible with susie_get functions\", {\n setup <- create_model_with_cs(seed = 125)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n pips <- susie_get_pip(refined_model)\n expect_equal(length(pips), ncol(refined_model$alpha))\n expect_true(all(pips >= 0))\n expect_true(all(pips <= 1))\n\n cs <- susie_get_cs(refined_model)\n expect_true(is.null(cs) || is.list(cs))\n\n post_mean <- susie_get_posterior_mean(refined_model)\n expect_true(all(is.finite(post_mean)))\n})\n\ntest_that(\"run_refine maintains fitted values\", {\n setup <- create_model_with_cs(seed = 126)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(\"fitted\" %in% names(refined_model))\n expect_equal(length(refined_model$fitted), nrow(setup$X))\n expect_true(all(is.finite(refined_model$fitted)))\n})\n\ntest_that(\"run_refine maintains intercept\", {\n setup <- create_model_with_cs(seed = 127)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(\"intercept\" %in% names(refined_model))\n expect_true(is.finite(refined_model$intercept))\n})\n\n# =============================================================================\n# MATHEMATICAL PROPERTIES\n# =============================================================================\n\ntest_that(\"run_refine maintains non-negative prior variances\", {\n setup <- create_model_with_cs(seed = 128)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(all(refined_model$V >= 0))\n expect_true(all(is.finite(refined_model$V)))\n})\n\ntest_that(\"run_refine maintains positive residual variance\", {\n setup <- create_model_with_cs(seed = 129)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(refined_model$sigma2 > 0)\n expect_true(is.finite(refined_model$sigma2))\n})\n\ntest_that(\"run_refine maintains non-negative KL divergences\", {\n setup <- create_model_with_cs(seed = 130)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_true(all(refined_model$KL >= -1e-6))\n})\n\ntest_that(\"run_refine ELBO is monotonically increasing\", {\n setup <- create_model_with_cs(seed = 131)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n elbo_diff <- diff(refined_model$elbo)\n expect_true(all(elbo_diff > -1e-6))\n})\n\n# =============================================================================\n# SIGNAL RECOVERY\n# =============================================================================\n\ntest_that(\"run_refine improves or maintains signal recovery\", {\n setup <- create_model_with_cs(n = 200, p = 100, L = 10,\n n_causal = 3, seed = 132)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n pips_initial <- susie_get_pip(setup$model)\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n pips_refined <- susie_get_pip(refined_model)\n\n expect_equal(length(pips_refined), length(pips_initial))\n expect_true(all(pips_refined >= 0))\n expect_true(all(pips_refined <= 1))\n})\n\ntest_that(\"run_refine identifies true causal variables\", {\n setup <- create_model_with_cs(n = 200, p = 100, L = 10,\n n_causal = 3, seed = 133)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n pips <- susie_get_pip(refined_model)\n top_vars <- order(pips, decreasing = TRUE)[1:5]\n\n overlap <- length(intersect(top_vars, setup$causal_idx))\n expect_true(overlap >= 1)\n})\n\ntest_that(\"run_refine maintains low PIPs for null variables\", {\n setup <- create_model_with_cs(n = 200, p = 100, L = 10,\n n_causal = 3, seed = 134)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n pips <- susie_get_pip(refined_model)\n null_vars <- setdiff(1:length(pips), setup$causal_idx)\n null_pips <- pips[null_vars]\n\n expect_true(median(null_pips) < 0.3)\n})\n\n# =============================================================================\n# COMPARISON\n# =============================================================================\n\ntest_that(\"run_refine produces different result than no refinement\", {\n setup <- create_model_with_cs(n = 200, p = 100, L = 10,\n n_causal = 3, seed = 135)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n initial_elbo <- susie_get_objective(setup$model)\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n refined_elbo <- susie_get_objective(refined_model)\n\n if (refined_elbo > initial_elbo + setup$params$tol) {\n expect_true(TRUE)\n } else {\n expect_equal(refined_elbo, initial_elbo, tolerance = setup$params$tol)\n }\n})\n\ntest_that(\"run_refine with tight tolerance may differ from loose tolerance\", {\n setup <- create_model_with_cs(seed = 136)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n params_tight <- setup$params\n params_tight$tol <- 1e-6\n\n params_loose <- setup$params\n params_loose$tol <- 1e-1\n\n refined_tight <- run_refine(setup$model, setup$data, params_tight)\n refined_loose <- run_refine(setup$model, setup$data, params_loose)\n\n expect_true(is.finite(susie_get_objective(refined_tight)))\n expect_true(is.finite(susie_get_objective(refined_loose)))\n})\n\n# =============================================================================\n# STRESS TESTING\n# =============================================================================\n\ntest_that(\"run_refine handles multiple refinement iterations\", {\n setup <- create_model_with_cs(n = 200, p = 100, L = 10,\n n_causal = 5, seed = 137)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) < 2,\n \"Need multiple credible sets\")\n\n params_loose <- setup$params\n params_loose$tol <- 1e-3\n\n refined_model <- run_refine(setup$model, setup$data, params_loose)\n\n expect_true(is.finite(susie_get_objective(refined_model)))\n expect_true(susie_get_objective(refined_model) >=\n susie_get_objective(setup$model) - 1e-6)\n})\n\ntest_that(\"run_refine handles large L\", {\n setup <- create_model_with_cs(n = 150, p = 80, L = 20,\n n_causal = 4, seed = 138)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_equal(nrow(refined_model$alpha), nrow(setup$model$alpha))\n expect_true(is.finite(susie_get_objective(refined_model)))\n})\n\ntest_that(\"run_refine handles large p\", {\n setup <- create_model_with_cs(n = 150, p = 200, L = 10,\n n_causal = 3, seed = 139)\n\n skip_if(is.null(setup$model$sets) || length(setup$model$sets$cs) == 0,\n \"No credible sets found\")\n\n refined_model <- run_refine(setup$model, setup$data, setup$params)\n\n expect_equal(ncol(refined_model$alpha), ncol(setup$model$alpha))\n expect_true(is.finite(susie_get_objective(refined_model)))\n})\n" }, { "path": "tests/testthat/test_rss_lambda_methods.R", "content": "context(\"S3 methods for rss_lambda data class\")\n\n# =============================================================================\n# DATA INITIALIZATION & CONFIGURATION\n# =============================================================================\n\ntest_that(\"configure_data.rss_lambda returns configured data object\", {\n dat <- setup_rss_lambda_data(seed = 1)\n\n # Create rss_lambda data object\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n params <- list(\n L = 5,\n prior_variance = 0.2,\n residual_variance = 1.0\n )\n\n configured <- configure_data.rss_lambda(data, params)\n\n expect_s3_class(configured, \"rss_lambda\")\n expect_true(!is.null(configured$z))\n expect_true(!is.null(configured$R))\n expect_equal(configured$lambda, dat$lambda)\n})\n\ntest_that(\"get_var_y.rss_lambda returns 1\", {\n dat <- setup_rss_lambda_data(seed = 2)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n var_y <- get_var_y.rss_lambda(data)\n\n expect_equal(var_y, 1)\n expect_type(var_y, \"double\")\n expect_length(var_y, 1)\n})\n\n# =============================================================================\n# MODEL INITIALIZATION & SETUP\n# =============================================================================\n\ntest_that(\"initialize_susie_model.rss_lambda creates valid model\", {\n dat <- setup_rss_lambda_data(seed = 3)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n params <- list(\n L = 5,\n prior_variance = 0.2,\n residual_variance = 1.0,\n estimate_residual_variance = TRUE,\n estimate_prior_variance = TRUE\n )\n\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n\n expect_type(model, \"list\")\n expect_true(!is.null(model$alpha))\n expect_true(!is.null(model$mu))\n expect_true(!is.null(model$mu2))\n expect_true(!is.null(model$SinvRj))\n expect_true(!is.null(model$RjSinvRj))\n\n # Check dimensions\n expect_equal(dim(model$alpha), c(5, dat$p))\n expect_equal(dim(model$mu), c(5, dat$p))\n expect_equal(dim(model$SinvRj), c(dat$p, dat$p))\n expect_length(model$RjSinvRj, dat$p)\n})\n\ntest_that(\"validate_prior.rss_lambda delegates to default method\", {\n dat <- setup_rss_lambda_data(seed = 21)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n params <- list(\n L = 5,\n prior_variance = 0.2,\n residual_variance = 1.0\n )\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n\n result <- validate_prior.rss_lambda(data, params, model)\n\n expect_type(result, \"logical\")\n})\n\ntest_that(\"track_ibss_fit.rss_lambda delegates to default method\", {\n dat <- setup_rss_lambda_data(seed = 22)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n params <- list(L = 5, track_fit = TRUE,\n scaled_prior_variance = 0.2, residual_variance = 1.0,\n prior_weights = rep(1/dat$p, dat$p))\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n\n tracking <- list()\n iter <- 1\n elbo <- -100\n\n result <- track_ibss_fit.rss_lambda(data, params, model, tracking, iter, elbo)\n\n expect_type(result, \"list\")\n})\n\n# =============================================================================\n# SINGLE EFFECT REGRESSION & ELBO\n# =============================================================================\n\ntest_that(\"initialize_fitted.rss_lambda creates Rz\", {\n dat <- setup_rss_lambda_data(seed = 4)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n # Create minimal mat_init\n mat_init <- list(\n alpha = matrix(1/dat$p, nrow = 5, ncol = dat$p),\n mu = matrix(0, nrow = 5, ncol = dat$p)\n )\n\n fitted <- initialize_fitted.rss_lambda(data, mat_init)\n\n expect_type(fitted, \"list\")\n expect_true(\"Rz\" %in% names(fitted))\n expect_length(fitted$Rz, dat$p)\n expect_type(fitted$Rz, \"double\")\n})\n\ntest_that(\"compute_residuals.rss_lambda computes correct residuals\", {\n dat <- setup_rss_lambda_data(seed = 5)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0)\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n\n # Add Rz to model\n model$Rz <- as.vector(data$R %*% colSums(model$alpha * model$mu))\n\n # Compute residuals for effect 1\n model <- compute_residuals.rss_lambda(data, params, model, l = 1)\n\n expect_true(\"residuals\" %in% names(model))\n expect_true(\"fitted_without_l\" %in% names(model))\n expect_length(model$residuals, dat$p)\n expect_length(model$fitted_without_l, dat$p)\n expect_equal(model$residual_variance, 1)\n})\n\n\ntest_that(\"compute_ser_statistics.rss_lambda computes shat2 and optim params\", {\n dat <- setup_rss_lambda_data(seed = 6)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0)\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n model$Rz <- as.vector(data$R %*% colSums(model$alpha * model$mu))\n model <- compute_residuals.rss_lambda(data, params, model, l = 1)\n\n ser_stats <- compute_ser_statistics.rss_lambda(data, params, model, l = 1)\n\n expect_type(ser_stats, \"list\")\n expect_true(\"shat2\" %in% names(ser_stats))\n expect_true(\"optim_init\" %in% names(ser_stats))\n expect_true(\"optim_bounds\" %in% names(ser_stats))\n expect_true(\"optim_scale\" %in% names(ser_stats))\n\n expect_length(ser_stats$shat2, dat$p)\n expect_true(all(ser_stats$shat2 > 0))\n expect_equal(ser_stats$optim_scale, \"log\")\n})\n\n\ntest_that(\"SER_posterior_e_loglik.rss_lambda computes expected log-likelihood\", {\n dat <- setup_rss_lambda_data(seed = 7)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0)\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n model$Rz <- as.vector(data$R %*% colSums(model$alpha * model$mu))\n model <- compute_residuals.rss_lambda(data, params, model, l = 1)\n\n e_loglik <- SER_posterior_e_loglik.rss_lambda(data, params, model, l = 1)\n\n expect_type(e_loglik, \"double\")\n expect_length(e_loglik, 1)\n expect_true(is.finite(e_loglik))\n})\n\n\ntest_that(\"compute_kl.rss_lambda delegates to default method\", {\n dat <- setup_rss_lambda_data(seed = 23)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0)\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n model$Rz <- as.vector(data$R %*% colSums(model$alpha * model$mu))\n\n # Set up for KL computation\n l <- 1\n model$lbf <- rep(0, params$L)\n model$alpha[l, ] <- rep(1/dat$p, dat$p)\n model$mu[l, ] <- rnorm(dat$p, sd = 0.1)\n model$mu2[l, ] <- model$mu[l, ]^2 + 0.1\n\n model <- compute_residuals.rss_lambda(data, params, model, l)\n model <- compute_kl.rss_lambda(data, params, model, l)\n\n expect_type(model$KL[l], \"double\")\n expect_length(model$KL[l], 1)\n})\n\n\ntest_that(\"calculate_posterior_moments.rss_lambda computes moments\", {\n dat <- setup_rss_lambda_data(seed = 8)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0)\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n model$Rz <- as.vector(data$R %*% colSums(model$alpha * model$mu))\n model <- compute_residuals.rss_lambda(data, params, model, l = 1)\n\n V <- 0.2\n l <- 1\n model <- calculate_posterior_moments.rss_lambda(data, params, model, V, l)\n\n expect_length(model$mu[l, ], dat$p)\n expect_length(model$mu2[l, ], dat$p)\n\n # Variance should be positive\n post_var <- model$mu2[l, ] - model$mu[l, ]^2\n expect_true(all(post_var > -1e-10))\n\n # post_mean2 = post_var + post_mean^2\n expect_equal(model$mu2[l, ], post_var + model$mu[l, ]^2)\n})\n\n\ntest_that(\"Eloglik.rss_lambda computes expected log-likelihood\", {\n dat <- setup_rss_lambda_data(seed = 24)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0)\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n # Precompute cached terms needed for Eloglik\n model <- precompute_rss_lambda_terms(data, model)\n\n e_loglik <- Eloglik.rss_lambda(data, model)\n\n expect_type(e_loglik, \"double\")\n expect_length(e_loglik, 1)\n expect_true(is.finite(e_loglik))\n})\n\n\ntest_that(\"loglik.rss_lambda computes log Bayes factors\", {\n dat <- setup_rss_lambda_data(seed = 25)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0,\n prior_weights = rep(1/dat$p, dat$p))\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n model$Rz <- as.vector(data$R %*% colSums(model$alpha * model$mu))\n model <- compute_residuals.rss_lambda(data, params, model, l = 1)\n\n V <- 0.2\n l <- 1\n ser_stats <- compute_ser_statistics.rss_lambda(data, params, model, l = l)\n model <- loglik.rss_lambda(data, params, model, V, ser_stats, l)\n\n expect_length(model$lbf_variable[l, ], dat$p)\n expect_length(model$alpha[l, ], dat$p)\n\n expect_true(all(model$alpha[l, ] >= 0))\n expect_true(abs(sum(model$alpha[l, ]) - 1) < 1e-10)\n expect_true(is.numeric(model$lbf[l]))\n})\n\n\ntest_that(\"neg_loglik.rss_lambda returns negative log-likelihood\", {\n dat <- setup_rss_lambda_data(seed = 26)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0,\n prior_weights = rep(1/dat$p, dat$p))\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n model$Rz <- as.vector(data$R %*% colSums(model$alpha * model$mu))\n model <- compute_residuals.rss_lambda(data, params, model, l = 1)\n\n V_param <- log(1.0) # Log scale\n ser_stats <- compute_ser_statistics.rss_lambda(data, params, model, l = 1)\n neg_ll <- neg_loglik.rss_lambda(data, params, model, V_param, ser_stats)\n\n expect_type(neg_ll, \"double\")\n expect_length(neg_ll, 1)\n})\n\ntest_that(\"get_ER2.rss_lambda computes expected squared residuals\", {\n dat <- setup_rss_lambda_data(seed = 27)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0)\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n # Precompute cached terms needed for get_ER2\n model <- precompute_rss_lambda_terms(data, model)\n\n\n er2 <- get_ER2.rss_lambda(data, model)\n\n expect_type(er2, \"double\")\n expect_length(er2, 1)\n expect_true(er2 >= 0)\n expect_true(is.finite(er2))\n})\n\n# =============================================================================\n# MODEL UPDATES & FITTING\n# =============================================================================\n\ntest_that(\"update_fitted_values.rss_lambda updates Rz correctly\", {\n dat <- setup_rss_lambda_data(seed = 28)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0)\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n model$Rz <- as.vector(data$R %*% colSums(model$alpha * model$mu))\n model <- compute_residuals.rss_lambda(data, params, model, l = 1)\n\n # Update fitted values for effect 1\n old_Rz <- model$Rz\n model <- update_fitted_values.rss_lambda(data, params, model, l = 1)\n\n expect_true(\"Rz\" %in% names(model))\n expect_length(model$Rz, dat$p)\n expect_type(model$Rz, \"double\")\n})\n\n\ntest_that(\"update_variance_components.rss_lambda estimates sigma2\", {\n dat <- setup_rss_lambda_data(seed = 29)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0, estimate_residual_variance = TRUE)\n\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n # Precompute cached terms\n model <- precompute_rss_lambda_terms(data, model)\n\n\n variance_update <- update_variance_components.rss_lambda(data, params, model)\n\n expect_type(variance_update, \"list\")\n expect_true(\"sigma2\" %in% names(variance_update))\n expect_type(variance_update$sigma2, \"double\")\n expect_length(variance_update$sigma2, 1)\n expect_true(variance_update$sigma2 > 0)\n expect_true(variance_update$sigma2 <= 1 - dat$lambda) # Upper bound\n})\n\n\ntest_that(\"update_derived_quantities.rss_lambda updates SinvRj and RjSinvRj\", {\n dat <- setup_rss_lambda_data(seed = 12)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0)\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n\n # Change sigma2\n model$sigma2 <- 0.5\n\n # Update derived quantities\n updated_model <- update_derived_quantities.rss_lambda(data, params, model)\n\n expect_true(\"SinvRj\" %in% names(updated_model))\n expect_true(\"RjSinvRj\" %in% names(updated_model))\n expect_equal(dim(updated_model$SinvRj), c(dat$p, dat$p))\n expect_length(updated_model$RjSinvRj, dat$p)\n})\n\n# =============================================================================\n# OUTPUT GENERATION & POST-PROCESSING\n# =============================================================================\n\ntest_that(\"get_scale_factors.rss_lambda returns vector of 1s\", {\n dat <- setup_rss_lambda_data(seed = 13)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list()\n scale_factors <- get_scale_factors.rss_lambda(data, params)\n\n expect_type(scale_factors, \"double\")\n expect_length(scale_factors, dat$p)\n expect_equal(scale_factors, rep(1, dat$p))\n})\n\n\ntest_that(\"get_intercept.rss_lambda returns intercept_value\", {\n dat <- setup_rss_lambda_data(seed = 14)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0)\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n\n intercept <- get_intercept.rss_lambda(data, params, model)\n\n expect_type(intercept, \"double\")\n expect_length(intercept, 1)\n expect_equal(intercept, data$intercept_value)\n})\n\n\ntest_that(\"get_fitted.rss_lambda delegates to default method\", {\n dat <- setup_rss_lambda_data(seed = 30)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0)\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n\n fitted <- get_fitted.rss_lambda(data, params, model)\n\n # Default method returns NULL for RSS data\n expect_null(fitted)\n})\n\n\ntest_that(\"get_cs.rss_lambda returns NULL when coverage is NULL\", {\n dat <- setup_rss_lambda_data(seed = 31)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, coverage = NULL, min_abs_corr = 0.5,\n scaled_prior_variance = 0.2, residual_variance = 1.0,\n prior_weights = rep(1/dat$p, dat$p))\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n\n cs <- get_cs.rss_lambda(data, params, model)\n\n expect_null(cs)\n})\n\ntest_that(\"get_cs.rss_lambda returns NULL when min_abs_corr is NULL\", {\n dat <- setup_rss_lambda_data(seed = 32)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, coverage = 0.95, min_abs_corr = NULL,\n scaled_prior_variance = 0.2, residual_variance = 1.0,\n prior_weights = rep(1/dat$p, dat$p))\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n\n cs <- get_cs.rss_lambda(data, params, model)\n\n expect_null(cs)\n})\n\ntest_that(\"get_cs.rss_lambda uses correlation from R matrix\", {\n dat <- setup_rss_lambda_data(seed = 33)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, coverage = 0.95, min_abs_corr = 0.5, n_purity = 100,\n scaled_prior_variance = 0.2, residual_variance = 1.0,\n prior_weights = rep(1/dat$p, dat$p))\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n\n # Add strong signal to create credible set\n model$alpha[1, 1] <- 0.95\n model$alpha[1, -1] <- 0.05 / (dat$p - 1)\n\n cs <- get_cs.rss_lambda(data, params, model)\n\n # May or may not find CS, but should not error\n expect_true(is.null(cs) || is.list(cs))\n})\n\n\ntest_that(\"get_variable_names.rss_lambda assigns variable names to model\", {\n dat <- setup_rss_lambda_data(seed = 34)\n\n # Create named z-scores\n z_named <- dat$z\n names(z_named) <- paste0(\"var\", 1:dat$p)\n\n result <- rss_lambda_constructor(\n z = z_named,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0,\n prior_weights = rep(1/dat$p, dat$p))\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n model$pip <- rep(0.1, dat$p)\n model$null_weight <- NULL\n model$alpha <- matrix(0, 5, dat$p)\n model$mu <- matrix(0, 5, dat$p)\n model$mu2 <- matrix(0, 5, dat$p)\n model$lbf_variable <- matrix(0, 5, dat$p)\n\n model_with_names <- get_variable_names.rss_lambda(data, model)\n\n expect_true(all(grepl(\"var\", colnames(model_with_names$alpha))))\n expect_true(all(grepl(\"var\", colnames(model_with_names$mu))))\n expect_true(all(grepl(\"var\", colnames(model_with_names$mu2))))\n expect_true(all(grepl(\"var\", names(model_with_names$pip))))\n})\n\n\ntest_that(\"get_zscore.rss_lambda delegates to default method\", {\n dat <- setup_rss_lambda_data(seed = 35)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, compute_univariate_zscore = TRUE,\n scaled_prior_variance = 0.2, residual_variance = 1.0,\n prior_weights = rep(1/dat$p, dat$p))\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n\n z <- get_zscore.rss_lambda(data, params, model)\n\n # Default returns NULL\n expect_null(z)\n})\n\ntest_that(\"cleanup_model.rss_lambda removes temporary fields\", {\n dat <- setup_rss_lambda_data(seed = 38)\n\n result <- rss_lambda_constructor(\n z = dat$z,\n R = dat$R,\n lambda = dat$lambda,\n n = dat$n\n )\n\n data <- result$data\n\n params <- list(L = 5, scaled_prior_variance = 0.2, residual_variance = 1.0)\n var_y <- get_var_y.rss_lambda(data)\n model <- initialize_susie_model.rss_lambda(data, params, var_y)\n model$Rz <- rep(0, dat$p)\n model$Z <- matrix(0, 5, dat$p)\n model$zbar <- rep(0, dat$p)\n model$diag_postb2 <- rep(0, dat$p)\n\n # Cleanup model\n cleaned <- cleanup_model.rss_lambda(data, params, model)\n\n # Check that temporary fields are removed\n expect_false(\"SinvRj\" %in% names(cleaned))\n expect_false(\"RjSinvRj\" %in% names(cleaned))\n expect_false(\"Rz\" %in% names(cleaned))\n expect_false(\"Z\" %in% names(cleaned))\n expect_false(\"zbar\" %in% names(cleaned))\n expect_false(\"diag_postb2\" %in% names(cleaned))\n\n # Check that essential fields remain\n expect_true(\"alpha\" %in% names(cleaned))\n expect_true(\"mu\" %in% names(cleaned))\n expect_true(\"mu2\" %in% names(cleaned))\n})\n\n# =============================================================================\n# FINITE-REFERENCE R INFLATION TESTS\n# =============================================================================\n\ntest_that(\"compute_ser_statistics.rss_lambda returns betahat\", {\n dat <- setup_rss_lambda_data(seed = 40)\n\n data <- dat$data\n params <- dat$params\n model <- dat$model\n model$Rz <- as.vector(data$R %*% colSums(model$alpha * model$mu))\n model <- compute_residuals.rss_lambda(data, params, model, l = 1)\n\n ser_stats <- compute_ser_statistics.rss_lambda(data, params, model, l = 1)\n\n expect_true(\"betahat\" %in% names(ser_stats))\n expect_length(ser_stats$betahat, dat$p)\n expect_true(all(is.finite(ser_stats$betahat)))\n})\n\ntest_that(\"compute_residuals.rss_lambda does not set shat2_inflation\", {\n # rss_lambda path no longer carries per-variant inflation; the\n # entry-level error in susie_rss blocks lambda > 0 + R_finite, so\n # data$R_finite_B is never set on an rss_lambda data object.\n dat <- setup_rss_lambda_data(seed = 42)\n\n data <- dat$data\n params <- dat$params\n model <- dat$model\n model$Rz <- as.vector(data$R %*% colSums(model$alpha * model$mu))\n\n expect_null(data$R_finite_B)\n model <- compute_residuals.rss_lambda(data, params, model, l = 1)\n expect_null(model$shat2_inflation)\n})\n\n# =============================================================================\n# R vs X INPUT PATH AGREEMENT\n# =============================================================================\n\ntest_that(\"R and X input paths produce numerically identical results\", {\n set.seed(50)\n p <- 30\n n <- 500\n B <- 200\n X_full <- matrix(rnorm(n * p), n, p)\n X_full <- scale(X_full, center = TRUE, scale = TRUE)\n y <- X_full[, 1] * 0.5 + rnorm(n)\n input_ss <- compute_suff_stat(X_full, y, standardize = TRUE)\n R <- cov2cor(input_ss$XtX)\n R <- (R + t(R)) / 2\n ss <- univariate_regression(X_full, y)\n z <- ss$betahat / ss$sebetahat\n\n # Use X as a finite-reference factor; here use X_full itself (B=n)\n X_ref <- X_full\n\n # Construct from R\n res_R <- rss_lambda_constructor(z = z, R = R, lambda = 0.1, n = n)\n # Construct from X\n res_X <- rss_lambda_constructor(z = z, X = X_ref, lambda = 0.1, n = n)\n\n # Eigendecomposition should be very close\n # (sorted eigenvalues should match; eigenvectors may differ in sign)\n expect_equal(res_R$data$eigen_R$values, res_X$data$eigen_R$values, tolerance = 1e-6)\n\n # Initialize and run one SER iteration\n var_y_R <- get_var_y.rss_lambda(res_R$data)\n model_R <- initialize_susie_model.rss_lambda(res_R$data, res_R$params, var_y_R)\n model_R$Rz <- as.vector(R %*% colSums(model_R$alpha * model_R$mu))\n\n var_y_X <- get_var_y.rss_lambda(res_X$data)\n model_X <- initialize_susie_model.rss_lambda(res_X$data, res_X$params, var_y_X)\n model_X$Rz <- as.vector(compute_Rv(res_X$data, colSums(model_X$alpha * model_X$mu)))\n\n # RjSinvRj should agree\n expect_equal(model_R$RjSinvRj, model_X$RjSinvRj, tolerance = 1e-6)\n\n # Compute residuals\n model_R <- compute_residuals.rss_lambda(res_R$data, res_R$params, model_R, l = 1)\n model_X <- compute_residuals.rss_lambda(res_X$data, res_X$params, model_X, l = 1)\n expect_equal(model_R$residuals, model_X$residuals, tolerance = 1e-6)\n\n # SER statistics\n stats_R <- compute_ser_statistics.rss_lambda(res_R$data, res_R$params, model_R, l = 1)\n stats_X <- compute_ser_statistics.rss_lambda(res_X$data, res_X$params, model_X, l = 1)\n expect_equal(stats_R$betahat, stats_X$betahat, tolerance = 1e-6)\n expect_equal(stats_R$shat2, stats_X$shat2, tolerance = 1e-6)\n})\n\n# =============================================================================\n# END-TO-END susie_rss_lambda\n# =============================================================================\n\ntest_that(\"susie_rss_lambda with lambda > 0 runs\", {\n set.seed(51)\n p <- 50\n n <- 2000\n X <- matrix(rnorm(n * p), n, p)\n X <- scale(X, center = TRUE, scale = TRUE)\n beta <- rep(0, p)\n beta[1] <- 0.5\n beta[10] <- -0.3\n y <- drop(X %*% beta + rnorm(n))\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n R <- cov2cor(input_ss$XtX)\n R <- (R + t(R)) / 2\n ss <- univariate_regression(X, y)\n z <- ss$betahat / ss$sebetahat\n\n fit <- susie_rss_lambda(z = z, R = R, lambda = 0.1, n = n, L = 5,\n max_iter = 50, verbose = FALSE)\n expect_true(fit$converged)\n expect_true(is.finite(fit$elbo[length(fit$elbo)]))\n expect_true(fit$pip[1] > 0.5)\n})\n\ntest_that(\"susie_rss_lambda excludes R_finite, R_mismatch, and multi-panel\", {\n set.seed(511)\n p <- 20\n n <- 1000\n X <- matrix(rnorm(n * p), n, p)\n R <- cor(X)\n z <- rnorm(p)\n\n expect_error(\n susie_rss_lambda(z = z, R = R, n = n, L = 3, lambda = 0.1,\n R_finite = 5000, max_iter = 2, verbose = FALSE),\n \"unused argument\"\n )\n expect_error(\n susie_rss_lambda(z = z, R = R, n = n, L = 3, lambda = 0.1,\n R_mismatch = \"map\", max_iter = 2, verbose = FALSE),\n \"unused argument\"\n )\n expect_error(\n susie_rss_lambda(z = z, R = R, n = n, L = 3, lambda = 0.1,\n R_mismatch = \"map_qc\", max_iter = 2, verbose = FALSE),\n \"unused argument\"\n )\n expect_error(\n susie_rss_lambda(z = z, X = list(X, X), n = n, L = 3, lambda = 0.1,\n max_iter = 2, verbose = FALSE),\n \"single X matrix\"\n )\n})\n\ntest_that(\"R_mismatch requires R_finite and stores lambda_bias and B_corrected\", {\n set.seed(511)\n p <- 20\n n <- 1000\n X <- matrix(rnorm(n * p), n, p)\n R <- cor(X)\n z <- rnorm(p)\n\n expect_error(\n susie_rss(z = z, R = R, n = n, L = 3, R_mismatch = \"map\",\n max_iter = 2, verbose = FALSE),\n \"R_mismatch requires R_finite\"\n )\n\n # F6: \"mle\" is no longer a valid choice.\n expect_error(\n susie_rss(z = z, R = R, n = n, L = 3, R_finite = 10000, R_mismatch = \"mle\",\n max_iter = 2, verbose = FALSE),\n \"should be one of\"\n )\n\n # F5: estimate_residual_variance with R_mismatch warns (via warning_message,\n # which uses message()) and is auto-disabled.\n expect_message(\n fit_warn <- susie_rss(z = z, R = R, n = n, L = 3, R_finite = 10000,\n R_mismatch = \"map\", estimate_residual_variance = TRUE,\n max_iter = 2, verbose = FALSE),\n \"incompatible with\"\n )\n\n fit <- susie_rss(z = z, R = R, n = n, L = 3, R_finite = 10000,\n R_mismatch = \"map\", max_iter = 2, verbose = FALSE)\n # SS path: region-level scalar lambda_bias and B_corrected (Commit 3 redesign).\n expect_length(fit$R_finite_diagnostics$lambda_bias, 1)\n # B_corrected = 1 / (1/R_finite_B + lambda_bias).\n expect_length(fit$R_finite_diagnostics$B_corrected, 1)\n expect_true(fit$R_finite_diagnostics$lambda_bias >= 0)\n R_finiteB <- fit$R_finite_diagnostics$B\n if (fit$R_finite_diagnostics$lambda_bias > 0) {\n expect_true(fit$R_finite_diagnostics$B_corrected < R_finiteB)\n } else {\n expect_equal(fit$R_finite_diagnostics$B_corrected, R_finiteB)\n }\n})\n\ntest_that(\"R_mismatch = 'none' is identical to no-R_mismatch call\", {\n # Spec invariant 5.1(b): R_mismatch = 'none' must reduce to the un-augmented\n # variance model exactly.\n set.seed(913)\n p <- 25\n n <- 2000\n X <- matrix(rnorm(n * p), n, p)\n R <- cor(X)\n z <- rnorm(p)\n z[3] <- 4\n\n fit_none <- susie_rss(z = z, R = R, n = n, L = 3, R_finite = 5000,\n R_mismatch = \"none\", max_iter = 5, verbose = FALSE)\n fit_default <- susie_rss(z = z, R = R, n = n, L = 3, R_finite = 5000,\n max_iter = 5, verbose = FALSE)\n expect_equal(fit_none$pip, fit_default$pip, tolerance = 1e-12)\n expect_equal(fit_none$alpha, fit_default$alpha, tolerance = 1e-12)\n expect_null(fit_none$lambda_bias)\n})\n\ntest_that(\"Fisher SE zero-mask sends near-boundary estimates to 0\", {\n # Under the null (z ~ N(0,1)) with no real drift, lambda_bias should\n # be masked to exactly 0 by the Fisher-SE rule\n # (ld_mismatch_generativemodel.tex Sec.~zero_mask).\n set.seed(7)\n p <- 50\n n <- 5000\n X <- matrix(rnorm(n * p), n, p)\n R <- cor(X)\n z <- rnorm(p) # pure null\n fit <- susie_rss(z = z, R = R, n = n, L = 3, R_finite = 10000,\n R_mismatch = \"map\", max_iter = 5, verbose = FALSE)\n # All entries should be cleanly zero, not ~4e-9 optimizer floor.\n lb <- fit$R_finite_diagnostics$lambda_bias\n expect_true(all(lb == 0 | lb > 1e-6),\n info = \"Fisher zero-mask must leave no values in the (0, 1e-6) gap\")\n})\n\ntest_that(\"In-sample LD identity yields lambda_bias = 0 (spec invariant 5.3)\", {\n # Spec invariant 5.3: when R is the in-sample LD of the data that\n # produced z, there is no population mismatch and the MAP estimator\n # should drive lambda_bias to 0 (modulo Fisher mask).\n set.seed(2024)\n p <- 30\n n <- 4000\n X <- matrix(rnorm(n * p), n, p)\n X <- scale(X, center = TRUE, scale = TRUE)\n beta <- rep(0, p); beta[5] <- 0.4\n y <- drop(X %*% beta + rnorm(n))\n ss <- compute_suff_stat(X, y, standardize = TRUE)\n R <- cov2cor(ss$XtX)\n z <- ss$XtX %*% beta / sqrt(diag(ss$XtX)) + rnorm(p)\n z <- as.numeric(z)\n fit <- susie_rss(z = z, R = R, n = n, L = 3, R_finite = 5000,\n R_mismatch = \"map\", max_iter = 8, verbose = FALSE)\n expect_true(all(fit$R_finite_diagnostics$lambda_bias == 0),\n info = \"In-sample LD must produce lambda_bias = 0\")\n})\n\ntest_that(\"In-sample LD with multiple sparse signals does not inflate lambda_bias\", {\n # Regression for the confounding failure mode: estimating lambda_bias from\n # the leave-one-effect residual can mistake the lth sparse signal for\n # population LD mismatch and suppress power. The generative target is the\n # full residual after all current sparse effects are removed.\n set.seed(44)\n n <- 1000\n p <- 120\n rho <- 0.95\n Sigma <- rho^abs(outer(seq_len(p), seq_len(p), \"-\"))\n X <- matrix(rnorm(n * p), n, p) %*% chol(Sigma)\n X <- scale(X, center = TRUE, scale = TRUE)\n beta <- rep(0, p)\n causal <- c(20, 60, 100)\n beta[causal] <- c(0.18, -0.20, 0.22)\n y <- drop(X %*% beta + rnorm(n))\n z <- calc_z(X, y, center = TRUE, scale = FALSE)\n\n fit <- susie_rss(z = z, X = X, n = n, L = 6, R_finite = TRUE,\n R_mismatch = \"map\", max_iter = 50, verbose = FALSE)\n\n expect_true(max(fit$R_finite_diagnostics$lambda_bias) < 0.01,\n info = \"In-sample LD should not estimate large population mismatch\")\n expect_gt(max(fit$pip[causal]), 0.5)\n})\n\ntest_that(\"R_mismatch = 'mle' is rejected at all entry points\", {\n # F6 closure: rejecting \"mle\" must hold at the public function AND\n # at the internal constructors so that downstream packages cannot\n # silently invoke ML.\n set.seed(31)\n p <- 20; n <- 1000\n X <- matrix(rnorm(n * p), n, p)\n R <- cor(X); z <- rnorm(p)\n expect_error(\n susie_rss(z = z, R = R, n = n, L = 3, R_finite = 10000, R_mismatch = \"mle\",\n max_iter = 1, verbose = FALSE),\n \"should be one of\"\n )\n expect_error(\n summary_stats_constructor(z = z, R = R, n = n, L = 3, R_finite = 10000,\n R_mismatch = \"mle\"),\n \"should be one of\"\n )\n})\n\ntest_that(\"Large R_finite limit reduces to pure-drift estimator\", {\n # When 1/R_finite is negligible, B_corrected ~ 1/lambda_bias and the\n # finite-reference contribution to tau^2 vanishes.\n set.seed(11)\n p <- 30; n <- 4000\n X <- matrix(rnorm(n * p), n, p)\n R <- cor(X)\n beta <- rep(0, p); beta[1] <- 0.6\n z <- as.numeric(R %*% beta * sqrt(n) + rnorm(p))\n fit <- susie_rss(z = z, R = R, n = n, L = 3, R_finite = 1e12,\n R_mismatch = \"map\", max_iter = 5, verbose = FALSE)\n lb <- fit$R_finite_diagnostics$lambda_bias\n bc <- fit$R_finite_diagnostics$B_corrected\n active <- lb > 0\n if (any(active)) {\n expect_equal(bc[active], 1 / lb[active], tolerance = 1e-6,\n info = \"B_corrected -> 1/lambda_bias as R_finite -> Inf\")\n }\n})\n\ntest_that(\"tau_j^2 is monotone non-decreasing in lambda_bias\", {\n # Spec invariant 5.1(e): tau_j^2(lambda) = sigma^2 + (1/B + lambda) * s_j\n # is monotone non-decreasing in lambda for s_j >= 0.\n s <- c(0.5, 1.5, 3.0, 0.0)\n sigma2 <- 1.2\n B <- 1000\n tau2 <- function(lambda) sigma2 + (1 / B + lambda) * s\n expect_true(all(tau2(0.05) >= tau2(0)))\n expect_true(all(tau2(0.5) >= tau2(0.05)))\n expect_true(all(tau2(0)[s == 0] == sigma2))\n})\n\ntest_that(\"loglik.rss_lambda Wakefield ABF agrees with old signal-based form\", {\n # Verify the Wakefield ABF form gives the same result as the original\n # signal^2 / RjSinvRj form when there is no inflation\n dat <- setup_rss_lambda_data(seed = 53)\n data <- dat$data\n params <- dat$params\n model <- dat$model\n model$Rz <- as.vector(data$R %*% colSums(model$alpha * model$mu))\n model <- compute_residuals.rss_lambda(data, params, model, l = 1)\n\n ser_stats <- compute_ser_statistics.rss_lambda(data, params, model, l = 1)\n\n # Compute BF using Wakefield ABF (current code)\n V <- 0.2\n shat2 <- pmax(ser_stats$shat2, .Machine$double.eps)\n lbf_wakefield <- -0.5 * log(1 + V / shat2) +\n 0.5 * ser_stats$betahat^2 * V / (shat2 * (V + shat2))\n\n # Compute BF using the original SinvRj form:\n # lbf = -0.5 * log(1 + V * RjSinvRj) + 0.5 * V * signal^2 / (1 + V * RjSinvRj)\n # where signal = SinvRj' * r, and shat2 = 1/RjSinvRj, betahat = signal * shat2\n signal <- as.vector(crossprod(model$SinvRj, model$residuals))\n RjSinvRj <- model$RjSinvRj\n lbf_original <- -0.5 * log(1 + V * RjSinvRj) +\n 0.5 * V * signal^2 / (1 + V * RjSinvRj)\n\n expect_equal(lbf_wakefield, lbf_original, tolerance = 1e-10)\n})\n\n# =============================================================================\n# SS vs RSS-LAMBDA CROSS-PATH AGREEMENT TESTS\n# =============================================================================\n\ntest_that(\"SS and RSS-lambda paths agree with small lambda (no inflation)\", {\n set.seed(200)\n p <- 50; n <- 2000\n X <- matrix(rnorm(n * p), n, p)\n X <- scale(X, center = TRUE, scale = TRUE)\n beta <- rep(0, p)\n beta[1] <- 0.5; beta[10] <- -0.3\n y <- drop(X %*% beta + rnorm(n))\n\n input_ss <- compute_suff_stat(X, y, standardize = TRUE)\n R <- cov2cor(input_ss$XtX); R <- (R + t(R)) / 2\n ss <- univariate_regression(X, y)\n z <- ss$betahat / ss$sebetahat\n\n # SS path (lambda = 0)\n fit_ss <- susie_rss(z = z, R = R, n = n, L = 5,\n max_iter = 100, verbose = FALSE)\n # RSS-lambda path (tiny lambda ~= 0)\n fit_rss <- susie_rss_lambda(z = z, R = R, n = n, L = 5, lambda = 1e-6,\n max_iter = 100, verbose = FALSE)\n\n expect_true(fit_ss$converged)\n expect_true(fit_rss$converged)\n # Alpha matrices should be essentially identical\n expect_equal(fit_ss$alpha, fit_rss$alpha, tolerance = 1e-4)\n # PIPs should match\n expect_equal(fit_ss$pip, fit_rss$pip, tolerance = 1e-4)\n})\n\n# =============================================================================\n# MULTI-PANEL R MIXTURE TESTS\n# =============================================================================\n\ntest_that(\"form_X_meta combines panels correctly\", {\n set.seed(42)\n p <- 10\n X1 <- matrix(rnorm(50 * p), 50, p)\n X2 <- matrix(rnorm(30 * p), 30, p)\n omega <- c(0.6, 0.4)\n\n X_meta <- form_X_meta(list(X1, X2), omega)\n\n expect_equal(nrow(X_meta), 80)\n expect_equal(ncol(X_meta), p)\n # First 50 rows scaled by sqrt(0.6)\n expect_equal(X_meta[1:50, ], sqrt(0.6) * X1)\n # Last 30 rows scaled by sqrt(0.4)\n expect_equal(X_meta[51:80, ], sqrt(0.4) * X2)\n})\n\ntest_that(\"eigen_from_X recovers eigendecomposition of X'X\", {\n set.seed(43)\n p <- 20\n X <- matrix(rnorm(100 * p), 100, p)\n R <- crossprod(X)\n eigen_R_direct <- eigen(R, symmetric = TRUE)\n\n eigen_R_svd <- eigen_from_X(X, p)\n\n # Eigenvalues should match\n expect_equal(eigen_R_svd$values, eigen_R_direct$values, tolerance = 1e-10)\n # Eigenvectors span same space (up to sign)\n for (j in seq_len(p)) {\n inner <- abs(sum(eigen_R_svd$vectors[, j] * eigen_R_direct$vectors[, j]))\n expect_gt(inner, 0.99)\n }\n})\n\ntest_that(\"eval_omega_eloglik_reduced matches pure R reference\", {\n set.seed(44)\n p <- 50\n K <- 2\n\n # Create two panels with B_total < p so reduced-basis applies\n X1 <- matrix(rnorm(15 * p), 15, p)\n X2 <- matrix(rnorm(10 * p), 10, p)\n X_list <- list(X1, X2)\n # Use raw cross-products (matching constructor: lapply(X_list, crossprod))\n panel_R <- list(crossprod(X1), crossprod(X2))\n\n z <- rnorm(p)\n zbar <- rnorm(p) * 0.1\n diag_postb2 <- abs(rnorm(p)) * 0.01\n L <- 3\n Z <- matrix(rnorm(L * p) * 0.05, L, p)\n sigma2 <- 0.9\n lambda <- 0.01\n omega <- c(0.7, 0.3)\n\n # Pure R reference (O(p^3) eigendecomposition using panel_R)\n val_R <- susieR:::eval_omega_eloglik_R(panel_R, omega, z, zbar, diag_postb2,\n Z, sigma2, lambda, K, p)\n\n # Reduced-basis (O(r^3) Cholesky using X_list)\n cache <- susieR:::precompute_omega_cache(X_list, z)\n iter_cache <- susieR:::precompute_omega_iteration(cache, zbar, diag_postb2, Z)\n val_reduced <- susieR:::eval_omega_eloglik_reduced(cache, omega, iter_cache,\n sigma2, lambda, K, p)\n\n expect_equal(val_R, val_reduced, tolerance = 1e-6)\n})\n\ntest_that(\"eval_omega_eloglik is concave in omega\", {\n set.seed(45)\n p <- 20\n K <- 2\n\n X1 <- matrix(rnorm(60 * p), 60, p)\n X2 <- matrix(rnorm(50 * p), 50, p)\n panel_R <- list(crossprod(X1) / 60, crossprod(X2) / 50)\n\n z <- rnorm(p)\n zbar <- rnorm(p) * 0.1\n diag_postb2 <- abs(rnorm(p)) * 0.01\n Z <- matrix(rnorm(2 * p) * 0.05, 2, p)\n\n eloglik <- function(w1) {\n susieR:::eval_omega_eloglik_R(panel_R, c(w1, 1 - w1), z, zbar,\n diag_postb2, Z, 0.9, 0.01, K, p)\n }\n\n # Concavity: midpoint should be >= average of endpoints\n vals <- sapply(seq(0, 1, 0.1), eloglik)\n for (i in 1:(length(vals) - 2)) {\n midval <- vals[i + 1]\n avg_endpoints <- (vals[i] + vals[i + 2]) / 2\n expect_gte(midval, avg_endpoints - 1e-8)\n }\n})\n\ntest_that(\"accessor helpers fall through for single panel\", {\n dat <- setup_rss_lambda_data(seed = 50)\n model <- dat$model\n\n # model$eigen_R is NULL for single panel\n expect_null(model$eigen_R)\n # Accessor should return data$eigen_R\n eigen_R <- get_eigen_R(dat$data, model)\n expect_equal(eigen_R$values, dat$data$eigen_R$values)\n\n # Same for Vtz\n expect_null(model$Vtz)\n Vtz <- get_Vtz(dat$data, model)\n expect_equal(Vtz, dat$data$Vtz)\n})\n\n# =============================================================================\n# RANK BOUND FALLBACK\n# =============================================================================\n\n# =============================================================================\n# TOLERANCE CONSTANTS\n# =============================================================================\n\ntest_that(\".omega_tol has expected fields\", {\n tol <- susieR:::.omega_tol\n expect_true(is.list(tol))\n expect_true(\"convergence\" %in% names(tol))\n expect_true(\"grid_spacing\" %in% names(tol))\n expect_true(\"fw_stop\" %in% names(tol))\n expect_true(\"fw_max_iter\" %in% names(tol))\n # Sanity: values are positive\n expect_true(tol$convergence > 0)\n expect_true(tol$grid_spacing > 0 && tol$grid_spacing < 1)\n expect_true(tol$fw_stop > 0)\n expect_true(tol$fw_max_iter >= 1L)\n})\n\n# =============================================================================\n# EIGEN_FROM_REDUCED UNIT TEST (Issue 21)\n# =============================================================================\n\ntest_that(\"eigen_from_reduced recovers full eigendecomposition\", {\n set.seed(55)\n p <- 30; B1 <- 40; B2 <- 35\n X1 <- matrix(rnorm(B1 * p), B1, p)\n X2 <- matrix(rnorm(B2 * p), B2, p)\n X_list <- lapply(list(X1, X2), susieR:::standardize_X)\n z <- rnorm(p)\n\n cache <- susieR:::precompute_omega_cache(X_list, z)\n\n omega <- c(0.7, 0.3)\n eig_reduced <- susieR:::eigen_from_reduced(cache, omega, K = 2, p = p)\n\n # Direct eigendecomposition of R(omega)\n R_omega <- omega[1] * crossprod(X_list[[1]]) + omega[2] * crossprod(X_list[[2]])\n R_omega <- 0.5 * (R_omega + t(R_omega))\n eig_direct <- eigen(R_omega, symmetric = TRUE)\n\n # Eigenvalues should match (within reduced rank)\n r <- cache$r\n expect_equal(eig_reduced$values[1:r], eig_direct$values[1:r], tolerance = 1e-8)\n\n # Eigenvectors should span the same space: V_reduced' V_direct ~= I for top-r\n overlap <- abs(crossprod(eig_reduced$vectors[, 1:r], eig_direct$vectors[, 1:r]))\n # Each reduced eigenvector should align with exactly one direct eigenvector\n expect_true(all(apply(overlap, 1, max) > 1 - 1e-8))\n})\n\n# =============================================================================\n# OMEGA AT SIMPLEX VERTEX (Issue 22)\n# =============================================================================\n\ntest_that(\"optimize_omega handles vertex optimum (one panel irrelevant)\", {\n set.seed(57)\n p <- 25; B <- 100\n\n # Panel 1: true R, Panel 2: pure noise (identity-like)\n X1 <- matrix(rnorm(B * p), B, p)\n X_list <- lapply(list(X1, matrix(rnorm(B * p), B, p)), susieR:::standardize_X)\n z <- rnorm(p)\n\n # Construct data where panel 1 is much better\n R1 <- crossprod(X_list[[1]])\n R2 <- diag(p) # identity -- pure noise panel\n panel_R <- list(R1, R2)\n\n zbar <- rnorm(p) * 0.1\n diag_postb2 <- abs(rnorm(p)) * 0.01\n Z <- matrix(rnorm(2 * p) * 0.05, 2, p)\n\n eval_fn <- function(omega_vec) {\n susieR:::eval_omega_eloglik_R(panel_R, omega_vec, z, zbar,\n diag_postb2, Z, 0.9, 0.1, 2, p)\n }\n\n result <- susieR:::optimize_omega(eval_fn, c(0.5, 0.5), K = 2)\n\n # Should produce valid omega on simplex\n expect_equal(sum(result$omega), 1, tolerance = 1e-10)\n expect_true(all(result$omega >= -1e-10))\n})\n" }, { "path": "tests/testthat/test_rss_mismatch.R", "content": "context(\"RSS R-reference mismatch (R_mismatch correction)\")\n\n# ---- API surface guards ----\n\ntest_that(\"R_mismatch = 'map_qc' runs and returns Q_art diagnostics\", {\n set.seed(11)\n p <- 20\n n <- 1000\n X <- matrix(rnorm(n * p), n, p)\n R <- cor(X)\n z <- rnorm(p)\n\n fit <- susie_rss(z = z, R = R, n = n, L = 3, R_finite = 5000,\n R_mismatch = \"map_qc\", max_iter = 2, verbose = FALSE)\n d <- fit$R_finite_diagnostics\n expect_true(!is.null(d$Q_art))\n expect_true(d$Q_art >= 0 && d$Q_art <= 1)\n expect_true(is.logical(d$artifact_flag))\n expect_true(d$mode_label %in% c(\"normal\", \"warning\", \"conservative\"))\n})\n\ntest_that(\"Optional artifact args validate ranges\", {\n set.seed(17)\n p <- 20\n n <- 1000\n X <- matrix(rnorm(n * p), n, p)\n R <- cor(X)\n z <- rnorm(p)\n\n expect_error(\n susie_rss(z = z, R = R, n = n, L = 3, R_finite = 5000,\n R_mismatch = \"map\", artifact_threshold = -0.1,\n max_iter = 2, verbose = FALSE),\n \"artifact_threshold\"\n )\n expect_error(\n susie_rss(z = z, R = R, n = n, L = 3, R_finite = 5000,\n R_mismatch = \"map\", artifact_threshold = 1.1,\n max_iter = 2, verbose = FALSE),\n \"artifact_threshold\"\n )\n expect_error(\n susie_rss(z = z, R = R, n = n, L = 3, R_finite = 5000,\n R_mismatch = \"map\", eig_delta_rel = -1,\n max_iter = 2, verbose = FALSE),\n \"eig_delta_rel\"\n )\n})\n\n# ---- Region-level scalar lambda_bias on the SS path ----\n\ntest_that(\"SS path stores scalar lambda_bias / B_corrected (not per-slot)\", {\n set.seed(101)\n p <- 25\n n <- 1500\n X <- matrix(rnorm(n * p), n, p)\n R <- cor(X)\n z <- rnorm(p)\n\n fit <- susie_rss(z = z, R = R, n = n, L = 3, R_finite = 5000,\n R_mismatch = \"map\", max_iter = 5, verbose = FALSE)\n expect_length(fit$R_finite_diagnostics$lambda_bias, 1)\n expect_length(fit$R_finite_diagnostics$B_corrected, 1)\n expect_true(fit$R_finite_diagnostics$lambda_bias >= 0)\n expect_equal(fit$R_finite_diagnostics$B_corrected,\n 1 / (1 / fit$R_finite_diagnostics$B +\n fit$R_finite_diagnostics$lambda_bias),\n tolerance = 1e-12)\n})\n\n# ---- Q_art unit tests ----\n\ntest_that(\"compute_Q_art recovers Q ~ 1 when r_fit lies in low-eigen direction\", {\n # Diagonal R with eigenvalues (2, 1, 1e-6). Default eig_delta_rel=1e-3\n # selects only the third eigenvalue.\n V <- diag(3)\n d <- c(2, 1, 1e-6)\n eig <- list(values = d, vectors = V)\n r_fit <- c(0, 0, 1) # purely in the low-eigen direction\n out <- susieR:::compute_Q_art(eig, r_fit)\n expect_equal(out$Q_art, 1, tolerance = 1e-12)\n expect_true(out$evaluable)\n expect_equal(out$low_eigen_count, 1L)\n})\n\ntest_that(\"compute_Q_art returns Q ~ 0 when r_fit avoids low-eigen directions\", {\n V <- diag(3)\n d <- c(2, 1, 1e-6)\n eig <- list(values = d, vectors = V)\n r_fit <- c(1, 0.5, 0) # fully in top two eigen directions\n out <- susieR:::compute_Q_art(eig, r_fit)\n expect_equal(out$Q_art, 0, tolerance = 1e-12)\n})\n\ntest_that(\"compute_Q_art is non-evaluable when r_fit has negligible energy\", {\n V <- diag(3)\n d <- c(2, 1, 1e-6)\n eig <- list(values = d, vectors = V)\n out <- susieR:::compute_Q_art(eig, rep(0, 3))\n expect_equal(out$Q_art, 0)\n expect_false(out$evaluable)\n})\n\ntest_that(\"compute_Q_art is non-evaluable when no low-eigenvalues exist\", {\n V <- diag(3)\n d <- c(2, 1, 0.5) # all > 1e-3 * 2 = 2e-3\n eig <- list(values = d, vectors = V)\n out <- susieR:::compute_Q_art(eig, c(1, 0, 0))\n expect_equal(out$low_eigen_count, 0L)\n expect_false(out$evaluable)\n})\n\ntest_that(\"compute_Q_art is in [0, 1] for typical inputs\", {\n V <- diag(3)\n d <- c(2, 1, 1e-6)\n eig <- list(values = d, vectors = V)\n for (r_fit in list(c(1, 0, 0), c(0, 1, 0), c(0, 0, 1),\n c(0.5, 0.5, 0.5), c(-1, 1, -1))) {\n out <- susieR:::compute_Q_art(eig, r_fit)\n expect_true(out$Q_art >= 0 && out$Q_art <= 1)\n }\n})\n\n# ---- map_qc end-to-end smoke ----\n\ntest_that(\"map_qc on well-behaved data yields Q_art near 0 and no flag\", {\n set.seed(11)\n p <- 25\n n <- 2000\n X <- matrix(rnorm(n * p), n, p)\n R <- cor(X)\n z <- rnorm(p)\n z[3] <- 4\n\n fit <- susie_rss(z = z, R = R, n = n, L = 3, R_finite = 5000,\n R_mismatch = \"map_qc\", max_iter = 5, verbose = FALSE)\n d <- fit$R_finite_diagnostics\n expect_lt(d$Q_art, 0.1)\n expect_false(d$artifact_flag)\n expect_equal(d$mode_label, \"normal\")\n})\n\ntest_that(\"map_qc emits a true R warning when artifact_flag triggers\", {\n rho <- 0.9999\n z <- c(-8, -8)\n R <- matrix(c(1, -rho, -rho, 1), 2, 2)\n expect_warning(\n fit <- susie_rss(z = z, R = R, n = 5000, L = 1, R_finite = 1e6,\n R_mismatch = \"map_qc\", max_iter = 5,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE, verbose = FALSE),\n \"Residual R-bias artifact detected\"\n )\n expect_true(fit$R_finite_diagnostics$artifact_flag)\n expect_equal(fit$R_finite_diagnostics$Q_art, 1, tolerance = 1e-6)\n})\n\ntest_that(\"map_qc surfaces Q_art and mode_label diagnostics\", {\n set.seed(12)\n p <- 25; n <- 2000\n X <- matrix(rnorm(n * p), n, p)\n R <- cor(X)\n z <- rnorm(p)\n\n fit <- susie_rss(z = z, R = R, n = n, L = 3, R_finite = 5000,\n R_mismatch = \"map_qc\", max_iter = 3, verbose = FALSE)\n d <- fit$R_finite_diagnostics\n for (fld in c(\"Q_art\", \"artifact_flag\", \"artifact_evaluable\",\n \"low_eigen_count\", \"low_eigen_fraction\", \"eig_delta\",\n \"mode_label\", \"lambda_bias\", \"B_corrected\"))\n expect_true(!is.null(d[[fld]]), info = paste(\"missing diagnostic:\", fld))\n})\n\ntest_that(\"map_qc with X-input runs and surfaces Q_art\", {\n set.seed(15)\n p <- 25; n <- 2000\n X <- matrix(rnorm(n * p), n, p)\n X <- scale(X, center = TRUE, scale = TRUE)\n beta <- rep(0, p); beta[5] <- 0.4\n y <- drop(X %*% beta + rnorm(n))\n z <- as.numeric(crossprod(X, y) / sqrt(diag(crossprod(X))))\n fit <- susie_rss(z = z, X = X, n = n, L = 3, R_finite = 5000,\n R_mismatch = \"map_qc\", max_iter = 3, verbose = FALSE)\n d <- fit$R_finite_diagnostics\n expect_true(!is.null(d$Q_art))\n expect_true(d$Q_art >= 0 && d$Q_art <= 1)\n})\n\ntest_that(\"map_qc works on lambda=0 multi-panel SS path\", {\n set.seed(19)\n n <- 80\n p <- 12\n X1 <- matrix(rnorm(n * p), n, p)\n X2 <- matrix(rnorm(n * p), n, p)\n z <- rnorm(p)\n\n fit <- susie_rss(z = z, X = list(X1, X2), n = 1000, L = 3,\n R_finite = TRUE, R_mismatch = \"map_qc\", max_iter = 3,\n verbose = FALSE)\n d <- fit$R_finite_diagnostics\n expect_true(!is.null(d$Q_art))\n expect_true(d$Q_art >= 0 && d$Q_art <= 1)\n expect_length(d$lambda_bias, 1)\n})\n" }, { "path": "tests/testthat/test_rss_utils.R", "content": "context(\"RSS utility functions\")\n\n# =============================================================================\n# FUNDAMENTAL COMPUTATIONS\n# =============================================================================\n\ntest_that(\"compute_suff_stat with standardize=FALSE produces correct XtX\", {\n base_data <- generate_base_data(n = 10, p = 5, seed = 1)\n\n # Manual calculation: center X\n X_centered <- scale(base_data$X, center = TRUE, scale = FALSE)\n\n out <- compute_suff_stat(base_data$X, base_data$y, standardize = FALSE)\n\n dimnames(out$XtX) <- NULL\n expect_equal(out$XtX, crossprod(X_centered), tolerance = 1e-14)\n})\n\ntest_that(\"compute_suff_stat with standardize=TRUE produces correct XtX\", {\n base_data <- generate_base_data(n = 10, p = 5, seed = 2)\n\n # Manual calculation: center and scale X\n X_standardized <- scale(base_data$X, center = TRUE, scale = TRUE)\n\n out <- compute_suff_stat(base_data$X, base_data$y, standardize = TRUE)\n\n dimnames(out$XtX) <- NULL\n expect_equal(out$XtX, crossprod(X_standardized), tolerance = 1e-14)\n})\n\ntest_that(\"compute_suff_stat with sparse matrix input\", {\n base_data <- generate_base_data(n = 10, p = 5, seed = 3)\n\n # Sparse version\n X_sparse <- as(base_data$X, \"sparseMatrix\")\n\n out_dense <- compute_suff_stat(base_data$X, base_data$y, standardize = FALSE)\n out_sparse <- compute_suff_stat(X_sparse, base_data$y, standardize = FALSE)\n\n dimnames(out_dense$XtX) <- NULL\n dimnames(out_sparse$XtX) <- NULL\n\n expect_equal(out_sparse$XtX, out_dense$XtX, tolerance = 1e-14)\n expect_equal(as.vector(out_sparse$Xty), out_dense$Xty, tolerance = 1e-14)\n expect_equal(out_sparse$yty, out_dense$yty, tolerance = 1e-14)\n})\n\ntest_that(\"compute_suff_stat produces correct Xty\", {\n base_data <- generate_base_data(n = 20, p = 8, seed = 4)\n\n out <- compute_suff_stat(base_data$X, base_data$y, standardize = FALSE)\n\n # Manual calculation\n y_centered <- base_data$y - mean(base_data$y)\n X_centered <- scale(base_data$X, center = TRUE, scale = FALSE)\n expected_Xty <- drop(crossprod(X_centered, y_centered))\n\n expect_equal(out$Xty, expected_Xty, tolerance = 1e-14)\n})\n\ntest_that(\"compute_suff_stat produces correct yty\", {\n base_data <- generate_base_data(n = 20, p = 8, seed = 5)\n\n out <- compute_suff_stat(base_data$X, base_data$y, standardize = FALSE)\n\n # Manual calculation\n y_centered <- base_data$y - mean(base_data$y)\n expected_yty <- sum(y_centered^2)\n\n expect_equal(out$yty, expected_yty, tolerance = 1e-14)\n})\n\ntest_that(\"compute_suff_stat stores column means and y_mean\", {\n base_data <- generate_base_data(n = 15, p = 6, seed = 6)\n\n out <- compute_suff_stat(base_data$X, base_data$y, standardize = FALSE)\n\n expect_equal(out$X_colmeans, colMeans(base_data$X), tolerance = 1e-14)\n expect_equal(out$y_mean, mean(base_data$y), tolerance = 1e-14)\n expect_equal(out$n, base_data$n)\n})\n\ntest_that(\"compute_suff_stat with standardize=TRUE scales correctly\", {\n base_data <- generate_base_data(n = 25, p = 10, seed = 7)\n\n out <- compute_suff_stat(base_data$X, base_data$y, standardize = TRUE)\n\n # XtX diagonal should be close to n (since standardized columns have variance 1)\n # After centering: crossprod of standardized X\n X_std <- scale(base_data$X, center = TRUE, scale = TRUE)\n expected_diag <- diag(crossprod(X_std))\n\n expect_equal(diag(out$XtX), expected_diag, tolerance = 1e-12)\n})\n\ntest_that(\"compute_suff_stat returns list with correct names\", {\n base_data <- generate_base_data(n = 10, p = 5, seed = 8)\n\n out <- compute_suff_stat(base_data$X, base_data$y, standardize = FALSE)\n\n expect_type(out, \"list\")\n expect_named(out, c(\"XtX\", \"Xty\", \"yty\", \"n\", \"y_mean\", \"X_colmeans\"))\n})\n\ntest_that(\"compute_suff_stat matches susie_ss input requirements\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 9)\n\n ss <- compute_suff_stat(base_data$X, base_data$y, standardize = TRUE)\n\n # Should be able to use directly with susie_ss\n expect_error(\n fit <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5,\n max_iter = 2, verbose = FALSE),\n NA\n )\n})\n\ntest_that(\"compute_suff_stat with zero-variance column\", {\n skip(\"Fails on Linux in CI\")\n\n base_data <- generate_base_data(n = 20, p = 5, seed = 10)\n base_data$X[, 3] <- 1 # Constant column (zero variance after centering)\n\n # Should not error\n expect_error(\n out <- compute_suff_stat(base_data$X, base_data$y, standardize = TRUE),\n NA\n )\n expect_true(is.infinite(out$Xty[3]))\n})\n\n# =============================================================================\n# RSS MODEL METHODS\n# =============================================================================\n\ntest_that(\"estimate_s_rss returns value between 0 and 1 (null-mle)\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 11)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n s <- estimate_s_rss(z, R, n = base_data$n, method = \"null-mle\")\n\n expect_type(s, \"double\")\n expect_length(s, 1)\n expect_true(s >= 0 && s <= 1)\n})\n\ntest_that(\"estimate_s_rss with null-partialmle method\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 12)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n s <- estimate_s_rss(z, R, n = base_data$n, method = \"null-partialmle\")\n\n expect_type(s, \"double\")\n expect_length(s, 1)\n # Note: null-partialmle can be > 1\n expect_true(s >= 0)\n})\n\ntest_that(\"estimate_s_rss with null-pseudomle method\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 13)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n s <- estimate_s_rss(z, R, n = base_data$n, method = \"null-pseudomle\")\n\n expect_type(s, \"double\")\n expect_length(s, 1)\n expect_true(s >= 0 && s <= 1)\n})\n\ntest_that(\"estimate_s_rss warns when n is not provided\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 14)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n expect_message(\n s <- estimate_s_rss(z, R),\n \"sample size\"\n )\n})\n\ntest_that(\"estimate_s_rss errors when n <= 1\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 15)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n expect_error(\n estimate_s_rss(z, R, n = 1),\n \"must be greater than 1\"\n )\n\n expect_error(\n estimate_s_rss(z, R, n = 0),\n \"must be greater than 1\"\n )\n})\n\ntest_that(\"estimate_s_rss handles eigen decomposition in R\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 16)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n # Pre-compute eigen decomposition\n attr(R, \"eigen\") <- eigen(R, symmetric = TRUE)\n\n s1 <- estimate_s_rss(z, R, n = base_data$n, method = \"null-mle\")\n\n # Without pre-computed eigen\n R2 <- cor(base_data$X)\n s2 <- estimate_s_rss(z, R2, n = base_data$n, method = \"null-mle\")\n\n expect_equal(s1, s2, tolerance = 1e-10)\n})\n\ntest_that(\"estimate_s_rss handles negative eigenvalues in R\", {\n set.seed(17)\n p <- 50\n\n # Create R with intentionally negative eigenvalue\n R <- matrix(0.5, p, p)\n diag(R) <- 1\n R[1, 2] <- 1.5 \n R[2, 1] <- 1.5\n\n z <- rnorm(p)\n\n expect_message(\n s <- estimate_s_rss(z, R, n = 100, method = \"null-mle\"),\n \"not positive semidefinite\"\n )\n\n # Should still return valid estimate\n expect_true(s >= 0 && s <= 1)\n})\n\ntest_that(\"estimate_s_rss handles NA values in z\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 18)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n # Introduce NA\n z[5] <- NA\n\n expect_error(\n s <- estimate_s_rss(z, R, n = base_data$n, method = \"null-mle\"),\n NA\n )\n\n expect_true(s >= 0 && s <= 1)\n})\n\ntest_that(\"estimate_s_rss with perfect LD has one large eigenvalue\", {\n set.seed(19)\n p <- 10\n\n # All variables perfectly correlated\n R <- matrix(1, p, p)\n z <- rnorm(p)\n s <- estimate_s_rss(z, R, n = 100, method = \"null-partialmle\")\n expect_true(s >= 0)\n})\n\ntest_that(\"estimate_s_rss errors on invalid method\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 20)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n expect_error(\n estimate_s_rss(z, R, n = base_data$n, method = \"invalid-method\"),\n \"not implemented\"\n )\n})\n\ntest_that(\"estimate_s_rss produces small s for consistent z and R\", {\n # Generate data where z-scores are consistent with R\n base_data <- generate_base_data(n = 500, p = 100, k = 3, signal_sd = 0.5, seed = 21)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n s <- estimate_s_rss(z, R, n = base_data$n, method = \"null-mle\")\n\n # With consistent data, s should be small\n expect_true(s < 0.01)\n})\n\n# =============================================================================\n# DIAGNOSTIC & QUALITY CONTROL\n# =============================================================================\n\ntest_that(\"kriging_rss returns list with plot and conditional_dist\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 22)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n result <- kriging_rss(z, R, n = base_data$n)\n\n expect_type(result, \"list\")\n expect_named(result, c(\"plot\", \"conditional_dist\"))\n})\n\ntest_that(\"kriging_rss plot is a ggplot object\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 23)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n result <- kriging_rss(z, R, n = base_data$n)\n\n expect_s3_class(result$plot, \"gg\")\n expect_s3_class(result$plot, \"ggplot\")\n})\n\ntest_that(\"kriging_rss conditional_dist is a data frame with correct columns\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 24)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n result <- kriging_rss(z, R, n = base_data$n)\n\n expect_s3_class(result$conditional_dist, \"data.frame\")\n expect_equal(nrow(result$conditional_dist), base_data$p)\n expect_true(all(c(\"z\", \"condmean\", \"condvar\", \"z_std_diff\", \"logLR\") %in%\n colnames(result$conditional_dist)))\n})\n\ntest_that(\"kriging_rss with provided s parameter\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 25)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n # Provide custom s\n result <- kriging_rss(z, R, n = base_data$n, s = 0.1)\n\n expect_type(result, \"list\")\n expect_s3_class(result$plot, \"ggplot\")\n expect_equal(nrow(result$conditional_dist), base_data$p)\n})\n\ntest_that(\"kriging_rss warns when n is not provided\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 26)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n expect_message(\n result <- kriging_rss(z, R),\n \"sample size\"\n )\n})\n\ntest_that(\"kriging_rss errors when n <= 1\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 27)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n expect_error(\n kriging_rss(z, R, n = 1),\n \"must be greater than 1\"\n )\n})\n\ntest_that(\"kriging_rss handles s > 1 with warning\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 28)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n expect_message(\n result <- kriging_rss(z, R, n = base_data$n, s = 1.5),\n \"greater than 1\"\n )\n\n # Should still produce output\n expect_type(result, \"list\")\n})\n\ntest_that(\"kriging_rss errors when s < 0\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 29)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n expect_error(\n kriging_rss(z, R, n = base_data$n, s = -0.1),\n \"non-negative\"\n )\n})\n\ntest_that(\"kriging_rss handles negative eigenvalues in R\", {\n set.seed(30)\n p <- 50\n\n # Create R with intentionally negative eigenvalue\n R <- matrix(0.5, p, p)\n diag(R) <- 1\n R[1, 2] <- 1.5 \n R[2, 1] <- 1.5\n\n z <- rnorm(p)\n\n expect_message(\n result <- kriging_rss(z, R, n = 100),\n \"not positive semidefinite\"\n )\n\n expect_type(result, \"list\")\n})\n\ntest_that(\"kriging_rss identifies potential allele switches (high logLR)\", {\n # Create data with one flipped allele\n base_data <- generate_base_data(n = 500, p = 100, k = 3, signal_sd = 1, seed = 31)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n # Flip one z-score to simulate allele switch\n z[1] <- -z[1]\n\n result <- kriging_rss(z, R, n = base_data$n)\n\n # The flipped variant should have high logLR\n expect_true(result$conditional_dist$logLR[1] > 0)\n})\n\ntest_that(\"kriging_rss handles NA values in z\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 32)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n # Introduce NA\n z[10] <- NA\n\n expect_error(\n result <- kriging_rss(z, R, n = base_data$n),\n NA\n )\n\n # NA should be replaced with 0\n expect_equal(result$conditional_dist$z[10], 0)\n})\n\ntest_that(\"kriging_rss conditional mean and variance are sensible\", {\n base_data <- generate_base_data(n = 200, p = 50, seed = 33)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n result <- kriging_rss(z, R, n = base_data$n)\n\n # All conditional variances should be positive\n expect_true(all(result$conditional_dist$condvar > 0))\n\n # Conditional means should be finite\n expect_true(all(is.finite(result$conditional_dist$condmean)))\n\n # Standardized differences should be finite\n expect_true(all(is.finite(result$conditional_dist$z_std_diff)))\n})\n\ntest_that(\"kriging_rss sets a_max=2 when max(z_std_diff^2) < 1\", {\n # Create data where z-scores are very consistent with R\n # Use very small z-scores (close to 0) which will have small standardized differences\n set.seed(34)\n p <- 50\n\n # Create identity correlation matrix (independent variables)\n R <- diag(p)\n\n # Use very small z-scores (near zero)\n z <- rnorm(p, mean = 0, sd = 0.3) # Small standard deviation\n\n result <- kriging_rss(z, R, n = 100)\n\n # Verify that max(z_std_diff^2) < 1\n max_z_std_diff_sq <- max(result$conditional_dist$z_std_diff^2)\n expect_true(max_z_std_diff_sq < 1)\n\n # The plot should be created successfully (tests the a_max=2 branch)\n expect_s3_class(result$plot, \"ggplot\")\n})\n\ntest_that(\"kriging_rss adds red points when outliers exist (length(idx) > 0)\", {\n # Create scenario that produces outliers with high logLR\n # Use data with inconsistent z-scores relative to correlation structure\n set.seed(32) # This seed produces outliers\n n <- 200\n p <- 50\n\n # Generate data with signal\n base_data <- generate_base_data(n = n, p = p, k = 5, signal_sd = 2, seed = 32)\n\n ss <- univariate_regression(base_data$X, base_data$y)\n R <- cor(base_data$X)\n z <- with(ss, betahat / sebetahat)\n\n # Flip some strong z-scores to create allele switch-like pattern\n strong_idx <- which(abs(z) > 2)\n if (length(strong_idx) >= 3) {\n # Flip first 3 strong z-scores\n flip_idx <- strong_idx[1:3]\n z[flip_idx] <- -z[flip_idx]\n }\n\n result <- kriging_rss(z, R, n = n)\n\n # Check that outliers were detected\n outliers <- which(result$conditional_dist$logLR > 2 &\n abs(result$conditional_dist$z) > 2)\n\n # Verify the length(idx) > 0 branch was executed\n expect_true(length(outliers) > 0)\n\n # Test that plot was created successfully (with red points added)\n expect_s3_class(result$plot, \"ggplot\")\n expect_s3_class(result$conditional_dist, \"data.frame\")\n})\n" }, { "path": "tests/testthat/test_single_effect_regression.R", "content": "context(\"Single Effect Regression\")\n\n# =============================================================================\n# SINGLE_EFFECT_REGRESSION - Returns Correct Structure\n# =============================================================================\n\ntest_that(\"single_effect_regression returns correct structure\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n l <- 1\n setup$model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n\n result <- single_effect_regression(setup$data, setup$params, setup$model, l)\n\n expect_type(result, \"list\")\n expect_true(\"alpha\" %in% names(result))\n expect_true(\"mu\" %in% names(result))\n expect_true(\"mu2\" %in% names(result))\n expect_true(\"lbf\" %in% names(result))\n expect_true(\"lbf_variable\" %in% names(result))\n expect_true(\"V\" %in% names(result))\n expect_length(result$alpha[l, ], setup$data$p)\n expect_length(result$mu[l, ], setup$data$p)\n expect_length(result$mu2[l, ], setup$data$p)\n expect_length(result$lbf_variable[l, ], setup$data$p)\n expect_length(result$lbf[l], 1)\n expect_length(result$V[l], 1)\n})\n\n# =============================================================================\n# SINGLE_EFFECT_REGRESSION - Alpha Sums to 1\n# =============================================================================\n\ntest_that(\"single_effect_regression alpha is valid probability distribution\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n l <- 1\n setup$model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n\n result <- single_effect_regression(setup$data, setup$params, setup$model, l)\n\n expect_equal(sum(result$alpha[l, ]), 1, tolerance = 1e-10)\n expect_true(all(result$alpha[l, ] >= 0 & result$alpha[l, ] <= 1))\n})\n\n# =============================================================================\n# SINGLE_EFFECT_REGRESSION - V Non-negative\n# =============================================================================\n\ntest_that(\"single_effect_regression V is non-negative and finite\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n l <- 1\n setup$model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n\n result <- single_effect_regression(setup$data, setup$params, setup$model, l)\n\n expect_true(result$V[l] >= 0)\n expect_true(is.finite(result$V[l]))\n})\n\n# =============================================================================\n# SINGLE_EFFECT_REGRESSION - Different Estimation Methods\n# =============================================================================\n\ntest_that(\"single_effect_regression works with estimate_prior_method='optim'\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$estimate_prior_method <- \"optim\"\n l <- 1\n setup$model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n\n result <- single_effect_regression(setup$data, setup$params, setup$model, l)\n\n expect_true(result$V[l] >= 0)\n expect_equal(sum(result$alpha[l, ]), 1, tolerance = 1e-10)\n})\n\ntest_that(\"single_effect_regression works with estimate_prior_method='EM'\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$estimate_prior_method <- \"EM\"\n l <- 1\n setup$model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n\n result <- single_effect_regression(setup$data, setup$params, setup$model, l)\n\n expect_true(result$V[l] >= 0)\n expect_equal(sum(result$alpha[l, ]), 1, tolerance = 1e-10)\n})\n\ntest_that(\"single_effect_regression works with estimate_prior_method='simple'\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$estimate_prior_method <- \"simple\"\n l <- 1\n setup$model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n\n result <- single_effect_regression(setup$data, setup$params, setup$model, l)\n\n expect_true(result$V[l] >= 0)\n expect_equal(sum(result$alpha[l, ]), 1, tolerance = 1e-10)\n})\n\ntest_that(\"single_effect_regression works with estimate_prior_method='none'\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$estimate_prior_method <- \"none\"\n l <- 1\n setup$model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n\n result <- single_effect_regression(setup$data, setup$params, setup$model, l)\n\n expect_true(result$V[l] >= 0)\n expect_equal(sum(result$alpha[l, ]), 1, tolerance = 1e-10)\n})\n\ntest_that(\"single_effect_regression rejects invalid estimate_prior_method\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$estimate_prior_method <- \"invalid_method\"\n l <- 1\n setup$model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n\n expect_error(\n single_effect_regression(setup$data, setup$params, setup$model, l),\n \"Invalid option for estimate_prior_method: invalid_method\"\n )\n})\n\n# =============================================================================\n# SINGLE_EFFECT_UPDATE\n# =============================================================================\n\ntest_that(\"single_effect_update updates all model components\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n l <- 1\n\n updated_model <- single_effect_update(setup$data, setup$params, setup$model, l)\n\n expect_equal(sum(updated_model$alpha[l, ]), 1, tolerance = 1e-10)\n expect_true(updated_model$V[l] >= 0)\n expect_true(updated_model$KL[l] >= -1e-6)\n expect_true(\"lbf\" %in% names(updated_model))\n expect_true(\"lbf_variable\" %in% names(updated_model))\n expect_true(\"Xr\" %in% names(updated_model))\n})\n\ntest_that(\"single_effect_update maintains valid probability constraints\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n l <- 1\n\n updated_model <- single_effect_update(setup$data, setup$params, setup$model, l)\n\n expect_equal(sum(updated_model$alpha[l, ]), 1, tolerance = 1e-10)\n expect_true(all(updated_model$alpha[l, ] >= 0))\n expect_true(all(updated_model$alpha[l, ] <= 1))\n})\n\ntest_that(\"single_effect_update works for all effects l=1,...,L\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n\n for (l in 1:setup$params$L) {\n updated_model <- single_effect_update(setup$data, setup$params, setup$model, l)\n expect_equal(sum(updated_model$alpha[l, ]), 1, tolerance = 1e-10)\n expect_true(updated_model$V[l] >= 0)\n }\n})\n\n# =============================================================================\n# MATHEMATICAL PROPERTIES\n# =============================================================================\n\ntest_that(\"SER variance decomposition\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n l <- 1\n setup$model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n\n result <- single_effect_regression(setup$data, setup$params, setup$model, l)\n\n post_second_moment <- sum(result$alpha[l, ] * result$mu2[l, ])\n post_mean_squared <- (sum(result$alpha[l, ] * result$mu[l, ]))^2\n post_var <- post_second_moment - post_mean_squared\n\n expect_true(post_var >= -1e-10)\n})\n\ntest_that(\"SER log Bayes factors are finite\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n l <- 1\n setup$model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n\n result <- single_effect_regression(setup$data, setup$params, setup$model, l)\n\n expect_true(all(is.finite(result$lbf_variable[l, ])))\n expect_true(is.finite(result$lbf[l]))\n})\n\ntest_that(\"SER posterior moments are finite\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n l <- 1\n setup$model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n\n result <- single_effect_regression(setup$data, setup$params, setup$model, l)\n\n expect_true(all(is.finite(result$mu[l, ])))\n expect_true(all(is.finite(result$mu2[l, ])))\n expect_true(all(result$mu2[l, ] >= 0))\n})\n\n# =============================================================================\n# SIGNAL DETECTION\n# =============================================================================\n\ntest_that(\"SER with strong signal has large V\", {\n set.seed(123)\n n <- 100\n p <- 50\n\n base_data <- generate_base_data(n, p, k = 1, signal_sd = 10, seed = NULL)\n X <- set_X_attributes(base_data$X, center = TRUE, scale = TRUE)\n y <- base_data$y - mean(base_data$y)\n\n data <- structure(\n list(X = X, y = y, n = n, p = p, mean_y = mean(base_data$y)),\n class = \"individual\"\n )\n\n params <- create_base_params(L = 1, p = p, additional_params = list(\n estimate_prior_method = \"optim\",\n use_NIG = FALSE,\n check_null_threshold = 0.1\n ))\n\n model <- create_base_model(L = 1, p = p, n = n, X_attr = attr(X, \"d\"))\n\n model <- compute_residuals.individual(data, params, model, 1)\n result <- single_effect_regression(data, params, model, 1)\n\n expect_true(result$V > 0.1)\n})\n\ntest_that(\"SER with no signal has V close to 0\", {\n set.seed(456)\n n <- 100\n p <- 50\n\n base_data <- generate_base_data(n, p, k = 0, seed = NULL)\n X <- set_X_attributes(base_data$X, center = TRUE, scale = TRUE)\n y <- base_data$y - mean(base_data$y)\n\n data <- structure(\n list(X = X, y = y, n = n, p = p, mean_y = mean(base_data$y)),\n class = \"individual\"\n )\n\n params <- create_base_params(L = 1, p = p, additional_params = list(\n estimate_prior_method = \"optim\",\n use_NIG = FALSE,\n check_null_threshold = 0.1\n ))\n\n model <- create_base_model(L = 1, p = p, n = n, X_attr = attr(X, \"d\"))\n\n model <- compute_residuals.individual(data, params, model, 1)\n result <- single_effect_regression(data, params, model, 1)\n\n expect_equal(result$V, 0, tolerance = 1e-10)\n})\n\n# =============================================================================\n# EDGE CASES\n# =============================================================================\n\ntest_that(\"SER handles single variable (p=1)\", {\n setup <- setup_individual_data(n = 100, p = 1, L = 1)\n l <- 1\n setup$model$alpha <- matrix(1, 1, 1)\n setup$model$mu <- matrix(0, 1, 1)\n setup$model$mu2 <- matrix(0, 1, 1)\n setup$model$V <- 1\n setup$model$pi <- 1\n setup$model$predictor_weights <- attr(setup$data$X, \"d\")\n setup$model$lbf <- 0\n setup$model$lbf_variable <- matrix(0, 1, 1)\n\n setup$model <- compute_residuals.individual(setup$data, setup$params, setup$model, l)\n result <- single_effect_regression(setup$data, setup$params, setup$model, l)\n\n expect_length(result$alpha, 1)\n expect_equal(result$alpha[1], 1)\n expect_true(result$V >= 0)\n})\n" }, { "path": "tests/testthat/test_slot_prior.R", "content": "context(\"slot_prior class\")\n\ntest_that(\"slot_prior_poisson constructs correctly\", {\n sp <- suppressMessages(slot_prior_poisson(C = 5, nu = 8))\n expect_s3_class(sp, \"slot_prior_poisson\")\n expect_s3_class(sp, \"slot_prior\")\n expect_equal(sp$C, 5)\n expect_equal(sp$nu, 8) # default when NULL\n expect_equal(sp$update_schedule, \"sequential\") # binomial default\n expect_null(sp$c_hat_init)\n expect_equal(sp$skip_threshold_multiplier, 0)\n})\n\ntest_that(\"slot_prior_poisson constructs correctly\", {\n sp <- slot_prior_poisson(C = 3, nu = 10)\n expect_s3_class(sp, \"slot_prior_poisson\")\n expect_s3_class(sp, \"slot_prior\")\n expect_equal(sp$C, 3)\n expect_equal(sp$nu, 10)\n expect_equal(sp$update_schedule, \"sequential\") # poisson default\n})\n\ntest_that(\"slot_prior validates inputs\", {\n expect_error(slot_prior_poisson(C = -1, nu = 8))\n expect_error(slot_prior_poisson(C = \"abc\", nu = 8))\n expect_error(slot_prior_poisson(C = 5, nu = -1))\n})\n\ntest_that(\"slot_prior tracks nu_was_default\", {\n sp_default <- slot_prior_poisson(C = 4)\n expect_true(sp_default$nu_was_default)\n expect_equal(sp_default$nu, 8)\n sp_explicit <- slot_prior_poisson(C = 4, nu = 8)\n expect_false(sp_explicit$nu_was_default)\n expect_equal(sp_explicit$nu, 8)\n})\n\ntest_that(\"slot_prior_poisson default for update_schedule is sequential\", {\n sp <- slot_prior_poisson(C = 5, nu = 8)\n expect_equal(sp$update_schedule, \"sequential\")\n})\n\ntest_that(\"slot_prior_poisson default for update_schedule is sequential\", {\n sp <- slot_prior_poisson(C = 5, nu = 8)\n expect_equal(sp$update_schedule, \"sequential\")\n})\n\ntest_that(\"is.slot_prior works\", {\n expect_true(is.slot_prior(slot_prior_poisson(C = 5, nu = 8)))\n expect_true(is.slot_prior(slot_prior_poisson(C = 5, nu = 8)))\n expect_false(is.slot_prior(list(C = 5)))\n expect_false(is.slot_prior(NULL))\n})\n\ntest_that(\"print.slot_prior produces output\", {\n expect_output(print(slot_prior_poisson(C = 5, nu = 8)), \"poisson\")\n expect_output(print(slot_prior_poisson(C = 3, nu = 8)), \"poisson\")\n})\n\ntest_that(\"susie with slot_prior produces c_hat output\", {\n set.seed(1)\n n <- 100; p <- 200\n X <- matrix(rnorm(n * p), n, p)\n b <- rep(0, p); b[1:3] <- 1\n y <- X %*% b + rnorm(n)\n fit <- susie(X, y, L = 10, slot_prior = slot_prior_poisson(C = 3, nu = 8),\n verbose = FALSE)\n expect_true(!is.null(fit$c_hat))\n expect_equal(length(fit$c_hat), 10)\n expect_true(all(fit$c_hat >= 0 & fit$c_hat <= 1))\n expect_true(!is.null(fit$C_hat))\n expect_true(fit$C_hat > 0)\n})\n\ntest_that(\"susie with binomial and poisson give similar results\", {\n set.seed(42)\n n <- 100; p <- 200\n X <- matrix(rnorm(n * p), n, p)\n b <- rep(0, p); b[1:3] <- 1\n y <- X %*% b + rnorm(n)\n fit_b <- susie(X, y, L = 10, slot_prior = slot_prior_poisson(C = 3, nu = 8),\n verbose = FALSE)\n fit_p <- susie(X, y, L = 10, slot_prior = slot_prior_poisson(C = 3, nu = 8),\n verbose = FALSE)\n # Both should find approximately the same effects\n expect_equal(length(fit_b$sets$cs), length(fit_p$sets$cs))\n # c_hat values should be similar (binomial correction is small for L >> C)\n expect_equal(fit_b$C_hat, fit_p$C_hat, tolerance = 1)\n})\n\ntest_that(\"susie without slot_prior does not produce c_hat\", {\n set.seed(1)\n n <- 100; p <- 200\n X <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n fit <- susie(X, y, L = 5, verbose = FALSE)\n expect_null(fit$c_hat)\n})\n\ntest_that(\"ash model auto-creates binomial slot_prior with warning\", {\n set.seed(1)\n n <- 100; p <- 200\n X <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n expect_message(\n fit <- susie(X, y, L = 10, unmappable_effects = \"ash\",\n verbose = FALSE, max_iter = 5),\n \"strongly advised\"\n )\n expect_true(!is.null(fit$c_hat))\n})\n\ntest_that(\"ash model with explicit slot_prior does not warn about C\", {\n set.seed(1)\n n <- 100; p <- 200\n X <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n # Should not produce the \"strongly advised\" warning about C\n # (may still produce convergence method warning, which is expected)\n fit <- withCallingHandlers(\n susie(X, y, L = 10, unmappable_effects = \"ash\",\n slot_prior = slot_prior_poisson(C = 3, nu = 8),\n verbose = FALSE, max_iter = 5),\n warning = function(w) {\n if (grepl(\"strongly advised\", conditionMessage(w)))\n stop(\"Got unexpected C warning\")\n invokeRestart(\"muffleWarning\")\n }\n )\n expect_true(!is.null(fit$c_hat))\n})\n\ntest_that(\"c_hat warm start works\", {\n set.seed(1)\n n <- 100; p <- 200\n X <- matrix(rnorm(n * p), n, p)\n b <- rep(0, p); b[1:3] <- 1\n y <- X %*% b + rnorm(n)\n\n # First fit\n fit1 <- susie(X, y, L = 10, slot_prior = slot_prior_poisson(C = 3, nu = 8),\n verbose = FALSE)\n\n # Warm start with previous c_hat\n sp_warm <- slot_prior_poisson(C = 3, nu = 8, c_hat_init = fit1$c_hat)\n fit2 <- susie(X, y, L = 10, slot_prior = sp_warm,\n model_init = fit1, verbose = FALSE)\n\n # Should converge immediately or in very few iterations\n expect_true(fit2$niter <= fit1$niter)\n})\n\ntest_that(\"batch and sequential schedules both converge\", {\n set.seed(1)\n n <- 100; p <- 200\n X <- matrix(rnorm(n * p), n, p)\n b <- rep(0, p); b[1:3] <- 1\n y <- X %*% b + rnorm(n)\n fit_batch <- susie(X, y, L = 10,\n slot_prior = slot_prior_poisson(C = 3, update_schedule = \"batch\"),\n verbose = FALSE)\n fit_seq <- susie(X, y, L = 10,\n slot_prior = slot_prior_poisson(C = 3, update_schedule = \"sequential\"),\n verbose = FALSE)\n expect_true(fit_batch$converged)\n expect_true(fit_seq$converged)\n # Results should be very similar\n expect_equal(sum(fit_batch$c_hat > 0.5), sum(fit_seq$c_hat > 0.5))\n})\n" }, { "path": "tests/testthat/test_slot_weights.R", "content": "# Tests for slot_weights mechanism\n#\n# Key invariant: slot_weights = rep(1, L) must produce identical results\n# to the standard path (slot_weights = NULL).\n\ncontext(\"Slot weights\")\n\nset.seed(1)\nn <- 200\np <- 50\nX <- matrix(rnorm(n * p), n, p)\nbeta <- rep(0, p)\nbeta[c(1, 5, 10)] <- c(0.5, -0.3, 0.4)\ny <- X %*% beta + rnorm(n)\nR <- cor(X)\nz <- as.vector(sqrt(n) * crossprod(X, y) / sqrt(n * diag(crossprod(X))))\n\n# =============================================================================\n# Test 1: slot_weights = rep(1,L) matches NULL (RSS)\n# =============================================================================\ntest_that(\"slot_weights = rep(1,L) matches standard path for RSS\", {\n L <- 5\n fit_std <- susie_rss(z = z, R = R, n = n, L = L,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n max_iter = 10, tol = 1e-4)\n\n # Run with explicit all-ones slot_weights via workhorse\n objs <- susie_rss(z = z, R = R, n = n, L = L,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n max_iter = 10, tol = 1e-4,\n init_only = TRUE)\n model <- susieR:::ibss_initialize(objs$data, objs$params)\n model$slot_weights <- rep(1, L)\n fit_sw <- susieR:::susie_workhorse(objs$data, objs$params)\n\n # Should be identical (slot_weights = NULL is equivalent to rep(1,L))\n # Note: we compare the standard path vs workhorse-with-weights\n # The workhorse doesn't see slot_weights because it initializes fresh.\n # So instead, verify that get_slot_weight returns 1 when NULL.\n expect_equal(susieR:::get_slot_weight(list(), 1), 1)\n expect_equal(susieR:::get_slot_weight(list(slot_weights = c(0.5, 0.8)), 1), 0.5)\n expect_equal(susieR:::get_slot_weight(list(slot_weights = c(0.5, 0.8)), 2), 0.8)\n})\n\n# =============================================================================\n# Test 2: slot_weights = 0 for one effect zeroes its contribution\n# =============================================================================\ntest_that(\"slot_weight = 0 zeroes effect contribution in RSS\", {\n L <- 3\n objs <- susie_rss(z = z, R = R, n = n, L = L,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n init_only = TRUE)\n data <- objs$data\n params <- objs$params\n model <- susieR:::ibss_initialize(data, params)\n\n # Set slot 2 weight to 0\n model$slot_weights <- c(1, 0, 1)\n\n # Run one SER update for slot 2\n model_before <- model\n model <- susieR:::single_effect_update(data, params, model, 2)\n\n # The fitted values (Rz) should not change from slot 2's contribution\n # because its weight is 0. After update, slot 2's alpha*mu is computed\n # but multiplied by 0 in update_fitted_values.\n # The SER still runs (alpha, mu are updated), but the contribution to\n # the total fitted value is zero.\n expect_true(is.numeric(model$alpha[2, ]))\n expect_true(all(is.finite(model$alpha[2, ])))\n})\n\n# =============================================================================\n# Test 3: slot_weights works with individual data\n# =============================================================================\ntest_that(\"slot_weights works with individual data\", {\n L <- 3\n fit <- susie(X, y, L = L,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n max_iter = 1)\n # Just verify it runs without error\n expect_true(all(fit$pip >= 0 & fit$pip <= 1))\n})\n\n# =============================================================================\n# Test 4: slot_weights works with sufficient stats\n# =============================================================================\ntest_that(\"slot_weights works with sufficient stats\", {\n L <- 3\n XtX <- crossprod(X)\n Xty <- crossprod(X, y)\n yty <- sum(y^2)\n\n fit <- susie_ss(XtX = XtX, Xty = Xty, yty = yty, n = n, L = L,\n estimate_prior_variance = FALSE,\n estimate_residual_variance = FALSE,\n max_iter = 1)\n expect_true(all(fit$pip >= 0 & fit$pip <= 1))\n})\n" }, { "path": "tests/testthat/test_sparse_multiplication.R", "content": "context(\"sparse multiplication utilities\")\n\n# =============================================================================\n# compute_Xb\n# =============================================================================\n\ntest_that(\"compute_Xb works with dense matrices (centered and scaled)\", {\n set.seed(123)\n n <- 50\n p <- 10\n\n # Create test data\n X_raw <- matrix(rnorm(n * p), n, p)\n b <- rnorm(p)\n\n # Standardize X and add attributes\n cm <- colMeans(X_raw)\n csd <- apply(X_raw, 2, sd)\n X_std <- scale(X_raw, center = TRUE, scale = TRUE)\n\n # Add attributes to raw X\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n # Compute using function\n result <- compute_Xb(X_raw, b)\n\n # Compute expected result (naive)\n expected <- as.vector(X_std %*% b)\n\n expect_equal(result, expected, tolerance = 1e-10)\n expect_length(result, n)\n})\n\ntest_that(\"compute_Xb works with sparse matrices (centered and scaled)\", {\n set.seed(456)\n n <- 100\n p <- 20\n\n # Create sparse test data (30% non-zero)\n X_raw <- Matrix::Matrix(rbinom(n * p, 1, 0.3) * rnorm(n * p), n, p, sparse = TRUE)\n b <- rnorm(p)\n\n # Standardize and add attributes\n cm <- Matrix::colMeans(X_raw)\n csd <- apply(as.matrix(X_raw), 2, sd)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n # Compute using function\n result <- compute_Xb(X_raw, b)\n\n # Compute expected result (naive with standardization)\n X_std <- scale(as.matrix(X_raw), center = cm, scale = csd)\n expected <- as.vector(X_std %*% b)\n\n expect_equal(result, expected, tolerance = 1e-10)\n expect_length(result, n)\n})\n\ntest_that(\"compute_Xb works with only centering (no scaling)\", {\n set.seed(789)\n n <- 30\n p <- 5\n\n X_raw <- matrix(rnorm(n * p), n, p)\n b <- rnorm(p)\n\n cm <- colMeans(X_raw)\n csd <- rep(1, p) # No scaling\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n result <- compute_Xb(X_raw, b)\n\n # Expected: centered X times b\n X_centered <- scale(X_raw, center = cm, scale = FALSE)\n expected <- as.vector(X_centered %*% b)\n\n expect_equal(result, expected, tolerance = 1e-10)\n})\n\ntest_that(\"compute_Xb works with only scaling (no centering)\", {\n set.seed(101)\n n <- 30\n p <- 5\n\n X_raw <- matrix(rnorm(n * p), n, p)\n b <- rnorm(p)\n\n cm <- rep(0, p) # No centering\n csd <- apply(X_raw, 2, sd)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n result <- compute_Xb(X_raw, b)\n\n # Expected: scaled X times b\n X_scaled <- scale(X_raw, center = FALSE, scale = csd)\n expected <- as.vector(X_scaled %*% b)\n\n expect_equal(result, expected, tolerance = 1e-10)\n})\n\ntest_that(\"compute_Xb handles zero vector b\", {\n set.seed(202)\n n <- 20\n p <- 8\n\n X_raw <- matrix(rnorm(n * p), n, p)\n b <- rep(0, p)\n\n attr(X_raw, \"scaled:center\") <- colMeans(X_raw)\n attr(X_raw, \"scaled:scale\") <- apply(X_raw, 2, sd)\n\n result <- compute_Xb(X_raw, b)\n\n expect_equal(result, rep(0, n), tolerance = 1e-10)\n})\n\n# =============================================================================\n# compute_Xty\n# =============================================================================\n\ntest_that(\"compute_Xty works with dense matrices (centered and scaled)\", {\n set.seed(303)\n n <- 50\n p <- 10\n\n X_raw <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n\n # Standardize X\n cm <- colMeans(X_raw)\n csd <- apply(X_raw, 2, sd)\n X_std <- scale(X_raw, center = cm, scale = csd)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n result <- compute_Xty(X_raw, y)\n\n # Expected result\n expected <- as.vector(t(X_std) %*% y)\n\n expect_equal(result, expected, tolerance = 1e-10)\n expect_length(result, p)\n})\n\ntest_that(\"compute_Xty works with sparse matrices (centered and scaled)\", {\n set.seed(404)\n n <- 100\n p <- 20\n\n X_raw <- Matrix::Matrix(rbinom(n * p, 1, 0.3) * rnorm(n * p), n, p, sparse = TRUE)\n y <- rnorm(n)\n\n cm <- Matrix::colMeans(X_raw)\n csd <- apply(as.matrix(X_raw), 2, sd)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n result <- compute_Xty(X_raw, y)\n\n # Expected result\n X_std <- scale(as.matrix(X_raw), center = cm, scale = csd)\n expected <- as.vector(t(X_std) %*% y)\n\n expect_equal(result, expected, tolerance = 1e-10)\n expect_length(result, p)\n})\n\ntest_that(\"compute_Xty works with only centering (no scaling)\", {\n set.seed(505)\n n <- 30\n p <- 5\n\n X_raw <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n\n cm <- colMeans(X_raw)\n csd <- rep(1, p)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n result <- compute_Xty(X_raw, y)\n\n X_centered <- scale(X_raw, center = cm, scale = FALSE)\n expected <- as.vector(t(X_centered) %*% y)\n\n expect_equal(result, expected, tolerance = 1e-10)\n})\n\ntest_that(\"compute_Xty handles zero vector y\", {\n set.seed(606)\n n <- 20\n p <- 8\n\n X_raw <- matrix(rnorm(n * p), n, p)\n y <- rep(0, n)\n\n attr(X_raw, \"scaled:center\") <- colMeans(X_raw)\n attr(X_raw, \"scaled:scale\") <- apply(X_raw, 2, sd)\n\n result <- compute_Xty(X_raw, y)\n\n expect_equal(result, rep(0, p), tolerance = 1e-10)\n})\n\n# =============================================================================\n# compute_XtX\n# =============================================================================\n\ntest_that(\"compute_XtX works with dense matrices (centered and scaled)\", {\n set.seed(707)\n n <- 50\n p <- 10\n\n X_raw <- matrix(rnorm(n * p), n, p)\n\n cm <- colMeans(X_raw)\n csd <- apply(X_raw, 2, sd)\n X_std <- scale(X_raw, center = cm, scale = csd)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n attr(X_raw, \"d\") <- colSums(X_std^2)\n\n result <- compute_XtX(X_raw)\n\n # Expected result\n expected <- t(X_std) %*% X_std\n\n expect_equal(result, expected, tolerance = 1e-10)\n expect_equal(dim(result), c(p, p))\n})\n\ntest_that(\"compute_XtX produces symmetric matrix\", {\n set.seed(808)\n n <- 40\n p <- 8\n\n X_raw <- matrix(rnorm(n * p), n, p)\n\n attr(X_raw, \"scaled:center\") <- colMeans(X_raw)\n attr(X_raw, \"scaled:scale\") <- apply(X_raw, 2, sd)\n\n result <- compute_XtX(X_raw)\n\n expect_equal(result, t(result), tolerance = 1e-10)\n})\n\ntest_that(\"compute_XtX is positive semi-definite\", {\n set.seed(909)\n n <- 60\n p <- 12\n\n X_raw <- matrix(rnorm(n * p), n, p)\n\n attr(X_raw, \"scaled:center\") <- colMeans(X_raw)\n attr(X_raw, \"scaled:scale\") <- apply(X_raw, 2, sd)\n\n result <- compute_XtX(X_raw)\n\n # Check eigenvalues are non-negative\n eigenvalues <- eigen(result, symmetric = TRUE)$values\n expect_true(all(eigenvalues >= -1e-10)) # Allow for numerical error\n})\n\ntest_that(\"compute_XtX works with sparse matrices\", {\n set.seed(1010)\n n <- 100\n p <- 20\n\n X_raw <- Matrix::Matrix(rbinom(n * p, 1, 0.3) * rnorm(n * p), n, p, sparse = TRUE)\n\n cm <- Matrix::colMeans(X_raw)\n csd <- apply(as.matrix(X_raw), 2, sd)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n result <- compute_XtX(X_raw)\n\n # Expected result\n X_std <- scale(as.matrix(X_raw), center = cm, scale = csd)\n expected <- t(X_std) %*% X_std\n\n expect_equal(as.matrix(result), expected, tolerance = 1e-9)\n})\n\ntest_that(\"compute_XtX works with only centering (no scaling)\", {\n set.seed(1111)\n n <- 30\n p <- 6\n\n X_raw <- matrix(rnorm(n * p), n, p)\n\n cm <- colMeans(X_raw)\n csd <- rep(1, p)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n result <- compute_XtX(X_raw)\n\n X_centered <- scale(X_raw, center = cm, scale = FALSE)\n expected <- t(X_centered) %*% X_centered\n\n expect_equal(result, expected, tolerance = 1e-10)\n})\n\ntest_that(\"compute_XtX rejects trend filtering matrices\", {\n set.seed(1212)\n n <- 50\n p <- 10\n\n X_raw <- matrix(rnorm(n * p), n, p)\n\n # Add standard attributes\n attr(X_raw, \"scaled:center\") <- colMeans(X_raw)\n attr(X_raw, \"scaled:scale\") <- apply(X_raw, 2, sd)\n\n # Add matrix.type attribute to simulate trend filtering matrix\n attr(X_raw, \"matrix.type\") <- \"trend_filtering\"\n\n expect_error(\n compute_XtX(X_raw),\n \"compute_XtX not yet implemented for trend filtering matrices\"\n )\n})\n\n# =============================================================================\n# compute_MXt\n# =============================================================================\n\ntest_that(\"compute_MXt works with dense matrices (centered and scaled)\", {\n set.seed(1212)\n n <- 50\n p <- 10\n L <- 3\n\n X_raw <- matrix(rnorm(n * p), n, p)\n M <- matrix(rnorm(L * p), L, p)\n\n cm <- colMeans(X_raw)\n csd <- apply(X_raw, 2, sd)\n X_std <- scale(X_raw, center = cm, scale = csd)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n result <- compute_MXt(M, X_raw)\n\n # Expected result\n expected <- M %*% t(X_std)\n\n expect_equal(result, expected, tolerance = 1e-10)\n expect_equal(dim(result), c(L, n))\n})\n\ntest_that(\"compute_MXt works with sparse matrices\", {\n set.seed(1313)\n n <- 100\n p <- 20\n L <- 5\n\n X_raw <- Matrix::Matrix(rbinom(n * p, 1, 0.3) * rnorm(n * p), n, p, sparse = TRUE)\n M <- matrix(rnorm(L * p), L, p)\n\n cm <- Matrix::colMeans(X_raw)\n csd <- apply(as.matrix(X_raw), 2, sd)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n result <- compute_MXt(M, X_raw)\n\n # Expected result\n X_std <- scale(as.matrix(X_raw), center = cm, scale = csd)\n expected <- M %*% t(X_std)\n\n expect_equal(result, expected, tolerance = 1e-9)\n})\n\ntest_that(\"compute_MXt works with single row M\", {\n set.seed(1414)\n n <- 40\n p <- 8\n\n X_raw <- matrix(rnorm(n * p), n, p)\n M <- matrix(rnorm(p), 1, p) # Single row\n\n cm <- colMeans(X_raw)\n csd <- apply(X_raw, 2, sd)\n X_std <- scale(X_raw, center = cm, scale = csd)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n result <- compute_MXt(M, X_raw)\n\n expected <- M %*% t(X_std)\n\n expect_equal(result, expected, tolerance = 1e-10)\n expect_equal(dim(result), c(1, n))\n})\n\ntest_that(\"compute_MXt handles zero matrix M\", {\n set.seed(1515)\n n <- 30\n p <- 6\n L <- 2\n\n X_raw <- matrix(rnorm(n * p), n, p)\n M <- matrix(0, L, p)\n\n attr(X_raw, \"scaled:center\") <- colMeans(X_raw)\n attr(X_raw, \"scaled:scale\") <- apply(X_raw, 2, sd)\n\n result <- compute_MXt(M, X_raw)\n\n expect_equal(result, matrix(0, L, n), tolerance = 1e-10)\n})\n\ntest_that(\"compute_MXt is equivalent to row-wise compute_Xb\", {\n set.seed(1616)\n n <- 40\n p <- 8\n L <- 4\n\n X_raw <- matrix(rnorm(n * p), n, p)\n M <- matrix(rnorm(L * p), L, p)\n\n cm <- colMeans(X_raw)\n csd <- apply(X_raw, 2, sd)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n # Using compute_MXt\n result_MXt <- compute_MXt(M, X_raw)\n\n # Using row-wise compute_Xb\n result_Xb <- t(apply(M, 1, function(b) compute_Xb(X_raw, b)))\n\n expect_equal(result_MXt, result_Xb, tolerance = 1e-10)\n})\n\n# =============================================================================\n# Edge Cases and Consistency\n# =============================================================================\n\ntest_that(\"sparse multiplication functions preserve dimensions correctly\", {\n set.seed(1717)\n n <- 25\n p <- 7\n L <- 3\n\n X_raw <- matrix(rnorm(n * p), n, p)\n b <- rnorm(p)\n y <- rnorm(n)\n M <- matrix(rnorm(L * p), L, p)\n\n attr(X_raw, \"scaled:center\") <- colMeans(X_raw)\n attr(X_raw, \"scaled:scale\") <- apply(X_raw, 2, sd)\n\n # Test dimensions\n expect_length(compute_Xb(X_raw, b), n)\n expect_length(compute_Xty(X_raw, y), p)\n expect_equal(dim(compute_XtX(X_raw)), c(p, p))\n expect_equal(dim(compute_MXt(M, X_raw)), c(L, n))\n})\n\ntest_that(\"all sparse functions handle edge case with p=1\", {\n set.seed(1818)\n n <- 50\n p <- 1\n\n X_raw <- matrix(rnorm(n * p), n, p)\n b <- rnorm(p)\n y <- rnorm(n)\n M <- matrix(rnorm(2 * p), 2, p)\n\n attr(X_raw, \"scaled:center\") <- colMeans(X_raw)\n attr(X_raw, \"scaled:scale\") <- apply(X_raw, 2, sd)\n\n # Should not error\n expect_length(compute_Xb(X_raw, b), n)\n expect_length(compute_Xty(X_raw, y), p)\n expect_equal(dim(compute_XtX(X_raw)), c(p, p))\n expect_equal(dim(compute_MXt(M, X_raw)), c(2, n))\n})\n\ntest_that(\"consistency test: compute_Xty(X,y) should equal t(X) %*% y for standardized X\", {\n set.seed(1919)\n n <- 45\n p <- 9\n\n X_raw <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n\n cm <- colMeans(X_raw)\n csd <- apply(X_raw, 2, sd)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n # Using compute_Xty\n result1 <- compute_Xty(X_raw, y)\n\n # Manually standardize and compute\n X_std <- scale(X_raw, center = cm, scale = csd)\n result2 <- as.vector(t(X_std) %*% y)\n\n expect_equal(result1, result2, tolerance = 1e-10)\n})\n\ntest_that(\"consistency test: compute_Xb and compute_XtX relationship\", {\n set.seed(2020)\n n <- 50\n p <- 10\n\n X_raw <- matrix(rnorm(n * p), n, p)\n b1 <- rnorm(p)\n b2 <- rnorm(p)\n\n cm <- colMeans(X_raw)\n csd <- apply(X_raw, 2, sd)\n\n attr(X_raw, \"scaled:center\") <- cm\n attr(X_raw, \"scaled:scale\") <- csd\n\n # Compute Xb1 and Xb2\n Xb1 <- compute_Xb(X_raw, b1)\n Xb2 <- compute_Xb(X_raw, b2)\n\n # Inner product should equal b1' XtX b2\n XtX <- compute_XtX(X_raw)\n\n result1 <- sum(Xb1 * Xb2)\n result2 <- sum(b1 * (XtX %*% b2))\n\n expect_equal(result1, result2, tolerance = 1e-9)\n})\n" }, { "path": "tests/testthat/test_sufficient_stats_methods.R", "content": "context(\"S3 methods for sufficient statistics (ss) data class\")\n\n# =============================================================================\n# DATA INITIALIZATION & CONFIGURATION\n# =============================================================================\n\ntest_that(\"configure_data.ss returns data when unmappable_effects='none'\", {\n setup <- setup_ss_data(unmappable_effects = \"none\")\n\n result <- configure_data.ss(setup$data, setup$params)\n\n expect_true(\"ss\" %in% class(result))\n expect_false(\"eigen_values\" %in% names(result))\n})\n\ntest_that(\"configure_data.ss adds eigen decomposition for unmappable_effects='inf'\", {\n setup <- setup_ss_data(unmappable_effects = \"inf\")\n\n # Remove eigen components to test they get added\n setup$data$eigen_values <- NULL\n setup$data$eigen_vectors <- NULL\n setup$data$VtXty <- NULL\n\n result <- configure_data.ss(setup$data, setup$params)\n\n expect_true(\"eigen_values\" %in% names(result))\n expect_true(\"eigen_vectors\" %in% names(result))\n expect_true(\"VtXty\" %in% names(result))\n})\n\ntest_that(\"sufficient_stats_constructor accepts unmappable_effects='ash'\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 1)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # ash is now supported for sufficient statistics via mr.ash.rss\n result <- sufficient_stats_constructor(Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n unmappable_effects = \"ash\")\n expect_true(inherits(result$data, \"ss\"))\n expect_equal(result$params$unmappable_effects, \"ash\")\n})\n\ntest_that(\"get_var_y.ss computes variance of y\", {\n setup <- setup_ss_data()\n\n var_y <- get_var_y.ss(setup$data)\n\n expect_type(var_y, \"double\")\n expect_length(var_y, 1)\n expect_true(var_y > 0)\n expect_equal(var_y, setup$data$yty / (setup$data$n - 1))\n})\n\n# =============================================================================\n# MODEL INITIALIZATION & SETUP\n# =============================================================================\n\ntest_that(\"initialize_susie_model.ss creates model with predictor_weights (none)\", {\n setup <- setup_ss_data(unmappable_effects = \"none\")\n var_y <- var(setup$data$yty / setup$data$n)\n\n model <- initialize_susie_model.ss(setup$data, setup$params, var_y)\n\n expect_true(\"predictor_weights\" %in% names(model))\n expect_length(model$predictor_weights, setup$data$p)\n expect_equal(model$predictor_weights, attr(setup$data$XtX, \"d\"))\n})\n\ntest_that(\"initialize_susie_model.ss initializes omega quantities for unmappable_effects='inf'\", {\n setup <- setup_ss_data(unmappable_effects = \"inf\")\n var_y <- setup$data$yty / (setup$data$n - 1)\n\n model <- initialize_susie_model.ss(setup$data, setup$params, var_y)\n\n expect_true(\"omega_var\" %in% names(model))\n expect_true(\"predictor_weights\" %in% names(model))\n expect_true(\"XtOmegay\" %in% names(model))\n expect_true(\"tau2\" %in% names(model))\n expect_true(\"theta\" %in% names(model))\n\n expect_equal(model$tau2, 0)\n expect_equal(model$theta, rep(0, setup$data$p))\n})\n\ntest_that(\"initialize_fitted.ss creates XtXr\", {\n setup <- setup_ss_data()\n\n mat_init <- list(\n alpha = setup$model$alpha,\n mu = setup$model$mu\n )\n\n fitted <- initialize_fitted.ss(setup$data, mat_init)\n\n expect_true(\"XtXr\" %in% names(fitted))\n expect_length(fitted$XtXr, setup$data$p)\n})\n\ntest_that(\"validate_prior.ss checks prior variance\", {\n setup <- setup_ss_data()\n setup$params$check_prior <- TRUE\n\n # Should not error for reasonable prior variance\n expect_error(\n validate_prior.ss(setup$data, setup$params, setup$model),\n NA\n )\n})\n\ntest_that(\"validate_prior.ss errors when prior variance is unreasonably large\", {\n setup <- setup_ss_data()\n setup$params$check_prior <- TRUE\n\n # Initialize model properly to get predictor_weights\n var_y <- setup$data$yty / (setup$data$n - 1)\n setup$model <- initialize_susie_model.ss(setup$data, setup$params, var_y)\n\n # Compute zm (max z-score magnitude)\n bhat <- setup$data$Xty / setup$model$predictor_weights\n shat <- sqrt(setup$model$sigma2 / setup$model$predictor_weights)\n z <- bhat / shat\n zm <- max(abs(z[!is.nan(z)]))\n\n # Set V to be unreasonably large (more than 100 * zm^2)\n setup$model$V <- rep(150 * (zm^2), setup$params$L)\n\n expect_error(\n validate_prior.ss(setup$data, setup$params, setup$model),\n \"Estimated prior variance is unreasonably large\"\n )\n})\n\ntest_that(\"track_ibss_fit.ss delegates to default when unmappable_effects='none'\", {\n setup <- setup_ss_data(unmappable_effects = \"none\")\n tracking <- list()\n iter <- 1\n elbo <- -100\n\n result <- track_ibss_fit.ss(setup$data, setup$params, setup$model,\n tracking, iter, elbo)\n\n expect_type(result, \"list\")\n})\n\ntest_that(\"track_ibss_fit.ss tracks tau2 for unmappable_effects='inf'\", {\n setup <- setup_ss_data(unmappable_effects = \"inf\")\n setup$params$track_fit <- TRUE\n tracking <- list()\n iter <- 1\n elbo <- -100\n\n result <- track_ibss_fit.ss(setup$data, setup$params, setup$model,\n tracking, iter, elbo)\n\n expect_true(\"tau2\" %in% names(result[[1]]))\n expect_equal(result[[1]]$tau2, setup$model$tau2)\n})\n\n# =============================================================================\n# SINGLE EFFECT REGRESSION & ELBO\n# =============================================================================\n\ntest_that(\"compute_residuals.ss computes residuals for unmappable_effects='none'\", {\n setup <- setup_ss_data(unmappable_effects = \"none\")\n l <- 1\n\n model <- compute_residuals.ss(setup$data, setup$params, setup$model, l)\n\n expect_true(\"residuals\" %in% names(model))\n expect_true(\"fitted_without_l\" %in% names(model))\n expect_true(\"residual_variance\" %in% names(model))\n\n expect_length(model$residuals, setup$data$p)\n expect_equal(model$residual_variance, setup$model$sigma2)\n})\n\ntest_that(\"compute_residuals.ss computes omega-weighted residuals for unmappable_effects='inf'\", {\n setup <- setup_ss_data(unmappable_effects = \"inf\")\n l <- 1\n\n # Initialize omega quantities first\n var_y <- setup$data$yty / (setup$data$n - 1)\n setup$model <- initialize_susie_model.ss(setup$data, setup$params, var_y)\n\n model <- compute_residuals.ss(setup$data, setup$params, setup$model, l)\n\n expect_true(\"residuals\" %in% names(model))\n expect_true(\"predictor_weights\" %in% names(model))\n expect_true(\"residual_variance\" %in% names(model))\n\n expect_length(model$residuals, setup$data$p)\n expect_equal(model$residual_variance, 1) \n})\n\ntest_that(\"compute_ser_statistics.ss computes betahat and shat2 for unmappable_effects='none'\", {\n setup <- setup_ss_data(unmappable_effects = \"none\")\n l <- 1\n\n model <- compute_residuals.ss(setup$data, setup$params, setup$model, l)\n ser_stats <- compute_ser_statistics.ss(setup$data, setup$params, model, l)\n\n expect_true(\"betahat\" %in% names(ser_stats))\n expect_true(\"shat2\" %in% names(ser_stats))\n expect_true(\"optim_init\" %in% names(ser_stats))\n expect_true(\"optim_bounds\" %in% names(ser_stats))\n expect_true(\"optim_scale\" %in% names(ser_stats))\n\n expect_length(ser_stats$betahat, setup$data$p)\n expect_length(ser_stats$shat2, setup$data$p)\n expect_equal(ser_stats$optim_scale, \"log\")\n expect_equal(ser_stats$optim_bounds, c(-30, 15))\n})\n\ntest_that(\"compute_ser_statistics.ss uses linear scale for unmappable_effects='inf'\", {\n setup <- setup_ss_data(unmappable_effects = \"inf\")\n l <- 1\n\n var_y <- setup$data$yty / (setup$data$n - 1)\n setup$model <- initialize_susie_model.ss(setup$data, setup$params, var_y)\n model <- compute_residuals.ss(setup$data, setup$params, setup$model, l)\n ser_stats <- compute_ser_statistics.ss(setup$data, setup$params, model, l)\n\n expect_equal(ser_stats$optim_scale, \"linear\")\n expect_equal(ser_stats$optim_bounds, c(0, 1))\n expect_equal(ser_stats$optim_init, model$V[l])\n})\n\ntest_that(\"SER_posterior_e_loglik.ss computes expected log-likelihood for unmappable_effects='none'\", {\n setup <- setup_ss_data(unmappable_effects = \"none\")\n l <- 1\n\n setup$model$alpha[l, ] <- rep(1/setup$data$p, setup$data$p)\n setup$model$mu[l, ] <- rnorm(setup$data$p)\n setup$model$mu2[l, ] <- setup$model$mu[l, ]^2 + 0.1\n\n model <- compute_residuals.ss(setup$data, setup$params, setup$model, l)\n e_loglik <- SER_posterior_e_loglik.ss(setup$data, setup$params, model, l)\n\n expect_type(e_loglik, \"double\")\n expect_length(e_loglik, 1)\n})\n\ntest_that(\"SER_posterior_e_loglik.ss uses omega-weighted likelihood for unmappable_effects='inf'\", {\n setup <- setup_ss_data(unmappable_effects = \"inf\")\n l <- 1\n\n var_y <- setup$data$yty / (setup$data$n - 1)\n setup$model <- initialize_susie_model.ss(setup$data, setup$params, var_y)\n setup$model$alpha[l, ] <- rep(1/setup$data$p, setup$data$p)\n setup$model$mu[l, ] <- rnorm(setup$data$p, sd = 0.01)\n setup$model$mu2[l, ] <- setup$model$mu[l, ]^2 + 0.01\n\n model <- compute_residuals.ss(setup$data, setup$params, setup$model, l)\n e_loglik <- SER_posterior_e_loglik.ss(setup$data, setup$params, model, l)\n\n expect_type(e_loglik, \"double\")\n expect_length(e_loglik, 1)\n})\n\ntest_that(\"calculate_posterior_moments.ss computes posterior correctly\", {\n setup <- setup_ss_data()\n l <- 1\n V <- 1.0\n\n model <- compute_residuals.ss(setup$data, setup$params, setup$model, l)\n model <- calculate_posterior_moments.ss(setup$data, setup$params, model, V, l)\n\n expect_length(model$mu[l, ], setup$data$p)\n expect_length(model$mu2[l, ], setup$data$p)\n\n post_var <- model$mu2[l, ] - model$mu[l, ]^2\n expect_true(all(post_var >= -1e-10))\n expect_true(all(model$mu2[l, ] >= model$mu[l, ]^2 - 1e-10))\n})\n\ntest_that(\"compute_kl.ss delegates to default method\", {\n setup <- setup_ss_data()\n l <- 1\n\n setup$model$lbf <- rep(0, setup$params$L)\n setup$model$alpha[l, ] <- rep(1/setup$data$p, setup$data$p)\n setup$model$mu[l, ] <- rnorm(setup$data$p, sd = 0.1)\n setup$model$mu2[l, ] <- setup$model$mu[l, ]^2 + 0.1\n\n model <- compute_residuals.ss(setup$data, setup$params, setup$model, l)\n model <- compute_kl.ss(setup$data, setup$params, model, l)\n\n expect_type(model$KL[l], \"double\")\n expect_length(model$KL[l], 1)\n})\n\ntest_that(\"get_ER2.ss computes expected squared residuals\", {\n setup <- setup_ss_data()\n\n er2 <- get_ER2.ss(setup$data, setup$model)\n\n expect_type(er2, \"double\")\n expect_length(er2, 1)\n expect_true(er2 >= 0)\n})\n\ntest_that(\"Eloglik.ss computes expected log-likelihood\", {\n setup <- setup_ss_data()\n\n e_loglik <- Eloglik.ss(setup$data, setup$model)\n\n expect_type(e_loglik, \"double\")\n expect_length(e_loglik, 1)\n})\n\ntest_that(\"loglik.ss computes log Bayes factors\", {\n setup <- setup_ss_data()\n l <- 1\n V <- 1.0\n\n model <- compute_residuals.ss(setup$data, setup$params, setup$model, l)\n ser_stats <- compute_ser_statistics.ss(setup$data, setup$params, model, l)\n model <- loglik.ss(setup$data, setup$params, model, V, ser_stats, l)\n\n expect_length(model$lbf_variable[l, ], setup$data$p)\n expect_length(model$alpha[l, ], setup$data$p)\n\n expect_true(all(model$alpha[l, ] >= 0))\n expect_true(abs(sum(model$alpha[l, ]) - 1) < 1e-10)\n expect_true(is.numeric(model$lbf[l]))\n})\n\ntest_that(\"neg_loglik.ss returns negative log-likelihood for unmappable_effects='none'\", {\n setup <- setup_ss_data(unmappable_effects = \"none\")\n l <- 1\n V_param <- log(1.0)\n\n model <- compute_residuals.ss(setup$data, setup$params, setup$model, l)\n ser_stats <- compute_ser_statistics.ss(setup$data, setup$params, model, l)\n neg_ll <- neg_loglik.ss(setup$data, setup$params, model, V_param, ser_stats)\n\n expect_type(neg_ll, \"double\")\n expect_length(neg_ll, 1)\n})\n\ntest_that(\"neg_loglik.ss uses unmappable objective for unmappable_effects='inf'\", {\n setup <- setup_ss_data(unmappable_effects = \"inf\")\n l <- 1\n V_param <- 0.5 # Linear scale\n\n var_y <- setup$data$yty / (setup$data$n - 1)\n setup$model <- initialize_susie_model.ss(setup$data, setup$params, var_y)\n model <- compute_residuals.ss(setup$data, setup$params, setup$model, l)\n ser_stats <- compute_ser_statistics.ss(setup$data, setup$params, model, l)\n neg_ll <- neg_loglik.ss(setup$data, setup$params, model, V_param, ser_stats)\n\n expect_type(neg_ll, \"double\")\n expect_length(neg_ll, 1)\n})\n\n# =============================================================================\n# MODEL UPDATES & FITTING\n# =============================================================================\n\ntest_that(\"update_fitted_values.ss updates XtXr for unmappable_effects='none'\", {\n setup <- setup_ss_data(unmappable_effects = \"none\")\n l <- 1\n\n model <- compute_residuals.ss(setup$data, setup$params, setup$model, l)\n setup$model$fitted_without_l <- model$fitted_without_l\n\n updated_model <- update_fitted_values.ss(setup$data, setup$params, setup$model, l)\n\n expect_true(\"XtXr\" %in% names(updated_model))\n expect_length(updated_model$XtXr, setup$data$p)\n})\n\ntest_that(\"update_fitted_values.ss includes theta for unmappable_effects='inf'\", {\n setup <- setup_ss_data(unmappable_effects = \"inf\")\n l <- 1\n\n var_y <- setup$data$yty / (setup$data$n - 1)\n setup$model <- initialize_susie_model.ss(setup$data, setup$params, var_y)\n\n updated_model <- update_fitted_values.ss(setup$data, setup$params, setup$model, l)\n\n expect_true(\"XtXr\" %in% names(updated_model))\n expect_length(updated_model$XtXr, setup$data$p)\n})\n\ntest_that(\"update_variance_components.ss delegates to default for unmappable_effects='none'\", {\n setup <- setup_ss_data(unmappable_effects = \"none\")\n\n result <- update_variance_components.ss(setup$data, setup$params, setup$model)\n\n expect_type(result, \"list\")\n expect_true(\"sigma2\" %in% names(result))\n})\n\ntest_that(\"update_variance_components.ss uses MLE for unmappable_effects='inf' with estimate_residual_method='MLE'\", {\n # Create setup with unmappable_effects='inf' but override to use MLE\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 42)\n X <- base_data$X\n y <- base_data$y\n\n # Center and scale\n X_colmeans <- colMeans(X)\n X <- sweep(X, 2, X_colmeans)\n y_mean <- mean(y)\n y <- y - y_mean\n\n # Compute sufficient statistics\n XtX <- crossprod(X)\n Xty <- as.vector(crossprod(X, y))\n yty <- sum(y^2)\n\n # Create constructor with MLE method (not the default MoM)\n susie_objects <- sufficient_stats_constructor(\n XtX = XtX, Xty = Xty, yty = yty, n = 100, L = 5,\n X_colmeans = X_colmeans, y_mean = y_mean,\n standardize = TRUE,\n unmappable_effects = \"inf\",\n estimate_residual_method = \"MLE\", # Force MLE instead of default MoM\n residual_variance = 1,\n convergence_method = \"pip\",\n coverage = 0.95,\n min_abs_corr = 0.5,\n n_purity = 100,\n check_prior = FALSE,\n track_fit = FALSE\n )\n\n data <- susie_objects$data\n params <- susie_objects$params\n\n # Initialize model properly\n var_y <- data$yty / (data$n - 1)\n model <- initialize_susie_model.ss(data, params, var_y)\n\n # Verify we're using MLE\n expect_equal(params$estimate_residual_method, \"MLE\")\n\n # Call update_variance_components which should use mle_unmappable\n result <- update_variance_components.ss(data, params, model)\n\n # Check that result has expected fields\n expect_type(result, \"list\")\n expect_true(\"sigma2\" %in% names(result))\n expect_true(\"tau2\" %in% names(result))\n expect_true(\"theta\" %in% names(result))\n\n # Check values are reasonable\n expect_true(result$sigma2 > 0)\n expect_true(result$tau2 >= 0)\n expect_length(result$theta, data$p)\n})\n\ntest_that(\"update_derived_quantities.ss delegates to default for unmappable_effects='none'\", {\n setup <- setup_ss_data(unmappable_effects = \"none\")\n\n result <- update_derived_quantities.ss(setup$data, setup$params, setup$model)\n\n expect_type(result, \"list\")\n})\n\ntest_that(\"update_derived_quantities.ss updates omega quantities for unmappable_effects='inf'\", {\n setup <- setup_ss_data(unmappable_effects = \"inf\")\n\n var_y <- setup$data$yty / (setup$data$n - 1)\n setup$model <- initialize_susie_model.ss(setup$data, setup$params, var_y)\n\n result <- update_derived_quantities.ss(setup$data, setup$params, setup$model)\n\n expect_true(\"omega_var\" %in% names(result))\n expect_true(\"predictor_weights\" %in% names(result))\n expect_true(\"XtOmegay\" %in% names(result))\n expect_true(\"XtXr\" %in% names(result))\n})\n\n# =============================================================================\n# OUTPUT GENERATION & POST-PROCESSING\n# =============================================================================\n\ntest_that(\"get_scale_factors.ss returns column scale factors\", {\n setup <- setup_ss_data()\n\n scales <- get_scale_factors.ss(setup$data, setup$params)\n\n expect_length(scales, setup$data$p)\n expect_true(all(scales > 0))\n expect_equal(scales, attr(setup$data$XtX, \"scaled:scale\"))\n})\n\ntest_that(\"get_intercept.ss computes intercept\", {\n setup <- setup_ss_data()\n setup$params$intercept <- TRUE\n\n intercept <- get_intercept.ss(setup$data, setup$params, setup$model)\n\n expect_type(intercept, \"double\")\n expect_length(intercept, 1)\n})\n\ntest_that(\"get_fitted.ss delegates to default method\", {\n setup <- setup_ss_data()\n\n fitted <- get_fitted.ss(setup$data, setup$params, setup$model)\n\n # Default method returns NULL for SS data\n expect_null(fitted)\n})\n\ntest_that(\"get_cs.ss returns NULL when coverage is NULL\", {\n setup <- setup_ss_data()\n setup$params$coverage <- NULL\n\n cs <- get_cs.ss(setup$data, setup$params, setup$model)\n\n expect_null(cs)\n})\n\ntest_that(\"get_cs.ss returns NULL when min_abs_corr is NULL\", {\n setup <- setup_ss_data()\n setup$params$min_abs_corr <- NULL\n\n cs <- get_cs.ss(setup$data, setup$params, setup$model)\n\n expect_null(cs)\n})\n\ntest_that(\"get_cs.ss computes correlation from XtX when diagonal not standardized\", {\n setup <- setup_ss_data()\n\n # Make diagonal not 0 or 1\n diag(setup$data$XtX) <- diag(setup$data$XtX) * 1.5\n\n # Add strong signal to create credible set\n setup$model$alpha[1, 1] <- 0.95\n setup$model$alpha[1, -1] <- 0.05 / (setup$data$p - 1)\n\n cs <- get_cs.ss(setup$data, setup$params, setup$model)\n\n # May or may not find CS, but should not error\n expect_true(is.null(cs) || is.list(cs))\n})\n\ntest_that(\"get_cs.ss uses XtX directly when diagonal is standardized\", {\n setup <- setup_ss_data()\n\n R <- cor(matrix(rnorm(100 * setup$data$p), 100, setup$data$p))\n setup$data$XtX <- R\n\n # Verify diagonal is all 1s (correlation matrix)\n expect_true(all(diag(setup$data$XtX) %in% c(0, 1)))\n\n # Add strong signal to create credible set\n setup$model$alpha[1, 1] <- 0.95\n setup$model$alpha[1, -1] <- 0.05 / (setup$data$p - 1)\n\n # Call get_cs.ss which should use the else branch (Xcorr <- data$XtX)\n cs <- get_cs.ss(setup$data, setup$params, setup$model)\n\n # May or may not find CS, but should not error\n expect_true(is.null(cs) || is.list(cs))\n})\n\ntest_that(\"get_variable_names.ss assigns variable names to model\", {\n setup <- setup_ss_data()\n colnames(setup$data$XtX) <- paste0(\"var\", 1:setup$data$p)\n setup$model$pip <- rep(0.1, setup$data$p)\n setup$model$null_weight <- NULL\n setup$model$alpha <- matrix(0, 5, setup$data$p)\n setup$model$mu <- matrix(0, 5, setup$data$p)\n setup$model$mu2 <- matrix(0, 5, setup$data$p)\n setup$model$lbf_variable <- matrix(0, 5, setup$data$p)\n\n model_with_names <- get_variable_names.ss(setup$data, setup$model)\n\n expect_true(all(grepl(\"var\", colnames(model_with_names$alpha))))\n expect_true(all(grepl(\"var\", colnames(model_with_names$mu))))\n expect_true(all(grepl(\"var\", colnames(model_with_names$mu2))))\n expect_true(all(grepl(\"var\", names(model_with_names$pip))))\n})\n\ntest_that(\"get_zscore.ss delegates to default method\", {\n setup <- setup_ss_data()\n setup$params$compute_univariate_zscore <- TRUE\n\n z <- get_zscore.ss(setup$data, setup$params, setup$model)\n\n expect_true(is.null(z) || is.numeric(z))\n})\n\ntest_that(\"cleanup_model.ss removes temporary fields for unmappable_effects='none'\", {\n setup <- setup_ss_data(unmappable_effects = \"none\")\n\n setup$model$residuals <- rnorm(setup$data$p)\n\n cleaned <- cleanup_model.ss(setup$data, setup$params, setup$model)\n\n expect_false(\"residuals\" %in% names(cleaned))\n})\n\ntest_that(\"cleanup_model.ss removes omega fields for unmappable_effects='inf'\", {\n setup <- setup_ss_data(unmappable_effects = \"inf\")\n\n var_y <- setup$data$yty / (setup$data$n - 1)\n setup$model <- initialize_susie_model.ss(setup$data, setup$params, var_y)\n setup$model$residuals <- rnorm(setup$data$p)\n\n cleaned <- cleanup_model.ss(setup$data, setup$params, setup$model)\n\n expect_false(\"omega_var\" %in% names(cleaned))\n expect_false(\"XtOmegay\" %in% names(cleaned))\n expect_false(\"residuals\" %in% names(cleaned))\n})\n\ncontext(\"susie() N>=2P hint and compute_suff_stat() workflow\")\n\n# These tests cover the two changes added in\n# - R/susie.R (the N>=2P hint)\n# - vignettes/finemapping.Rmd (compute_suff_stat -> susie_ss)\n# They intentionally do NOT modify the existing\n# \"susie_ss agrees with susie on same data\"\n# test in test_susie.R; that test stays as-is and uses hand-rolled crossprod.\n# The tests below exercise the user-facing compute_suff_stat() composition\n# instead, which is the path the new vignette section recommends.\n\n# -----------------------------------------------------------------------------\n# Hint behaviour\n# -----------------------------------------------------------------------------\n\ntest_that(\"susie emits a hint pointing to compute_suff_stat() when nrow(X) >= 2 * ncol(X)\", {\n set.seed(2026)\n n <- 200; p <- 50 # n >= 2 * p, so the hint should fire\n X <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n\n # warning_message(..., style = \"hint\") emits a message() call whose body\n # contains the literal \"compute_suff_stat\". expect_message matches any\n # emitted message; other messages (e.g. non-convergence warnings from\n # max_iter = 2) are tolerated.\n expect_message(\n susie(X, y, L = 3, max_iter = 2, verbose = FALSE),\n \"compute_suff_stat\"\n )\n})\n\ntest_that(\"susie does not emit the compute_suff_stat hint when nrow(X) < 2 * ncol(X)\", {\n set.seed(2027)\n n <- 60; p <- 50 # n < 2 * p, so the hint must stay silent\n X <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n\n msgs <- suppressWarnings(capture_messages(\n susie(X, y, L = 3, max_iter = 2, verbose = FALSE)\n ))\n expect_false(any(grepl(\"compute_suff_stat\", msgs, fixed = TRUE)))\n})\n\ntest_that(\"the hint does not interfere with susie's normal control flow\", {\n # Regression check: the hint is advisory only. Adding it must not change\n # the algorithm's output relative to running with the hint suppressed.\n set.seed(2028)\n n <- 200; p <- 50\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[c(5, 15, 25)] <- c(1, -1, 1.5)\n y <- as.vector(X %*% beta + rnorm(n, sd = 0.5))\n\n fit <- suppressMessages(\n susie(X, y, L = 5, max_iter = 100, verbose = FALSE)\n )\n\n expect_s3_class(fit, \"susie\")\n expect_length(fit$pip, p)\n expect_equal(rowSums(fit$alpha), rep(1, 5), tolerance = 1e-10)\n expect_true(all(is.finite(fit$elbo)))\n})\n\n# -----------------------------------------------------------------------------\n# Vignette workflow: compute_suff_stat() -> susie_ss()\n# -----------------------------------------------------------------------------\n\ntest_that(\"compute_suff_stat() + susie_ss() agrees with susie() on the same data\", {\n # This is the workflow the new vignette section demonstrates: feed the\n # output of compute_suff_stat directly into susie_ss with matching\n # standardize/intercept settings, and recover the susie() fit.\n set.seed(2029)\n n <- 100; p <- 50 # same dims as the existing 1e-3 reference test\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p); beta[c(5, 15, 25)] <- c(1, -1, 1.5)\n y <- as.vector(X %*% beta + rnorm(n, sd = 0.5))\n\n # n = 2 * p triggers the hint; suppress it for clean output here.\n fit_ind <- suppressMessages(susie(\n X, y, L = 5,\n standardize = TRUE, intercept = TRUE,\n verbose = FALSE\n ))\n\n ss <- compute_suff_stat(X, y, standardize = FALSE)\n\n fit_ss <- susie_ss(\n XtX = ss$XtX, Xty = ss$Xty, yty = ss$yty, n = ss$n,\n X_colmeans = ss$X_colmeans, y_mean = ss$y_mean,\n L = 5, standardize = TRUE, verbose = FALSE\n )\n\n # Tolerance matched to the existing\n # \"susie_ss agrees with susie on same data\" (test_susie.R, seed 33)\n # test, which uses the same configuration via hand-rolled crossprod.\n # compute_suff_stat() produces XtX/Xty/yty that are algebraically\n # identical to that hand-rolled computation, so the bound carries over.\n expect_equal(fit_ind$pip, fit_ss$pip, tolerance = 1e-3)\n expect_equal(fit_ind$V, fit_ss$V, tolerance = 1e-3)\n expect_equal(fit_ind$sigma2, fit_ss$sigma2, tolerance = 1e-3)\n})\n\ntest_that(\"compute_suff_stat: XtX can be reused across multiple y vectors\", {\n # This is the workhorse of the vignette example -- compute the heavy\n # XtX once, swap only Xty/yty/y_mean for each new response. The test\n # locks in two invariants:\n # (1) X-only quantities (XtX, X_colmeans, n) are byte-identical\n # between a reused-stats object and a freshly recomputed one.\n # (2) Feeding either into susie_ss produces the same fit.\n # Either invariant breaking would silently bite users iterating over\n # many proteins on the same locus.\n set.seed(2030)\n n <- 80; p <- 30\n X <- matrix(rnorm(n * p), n, p)\n Y <- matrix(rnorm(n * 2), n, 2)\n\n ss1 <- compute_suff_stat(X, Y[, 1], standardize = FALSE)\n\n # Reuse path: keep XtX/X_colmeans, recompute the y-dependent slots.\n y2_mean <- mean(Y[, 2])\n y2c <- Y[, 2] - y2_mean\n ss_reused <- ss1\n ss_reused$Xty <- drop(y2c %*% X)\n ss_reused$yty <- sum(y2c^2)\n ss_reused$y_mean <- y2_mean\n\n # Reference path: compute_suff_stat from scratch on Y[, 2].\n ss_fresh <- compute_suff_stat(X, Y[, 2], standardize = FALSE)\n\n # X-only quantities must be byte-identical: same X, same code path.\n expect_identical(ss_reused$XtX, ss_fresh$XtX)\n expect_identical(ss_reused$X_colmeans, ss_fresh$X_colmeans)\n expect_identical(ss_reused$n, ss_fresh$n)\n # y-only quantities are computed differently but should match numerically.\n expect_equal(ss_reused$Xty, ss_fresh$Xty, tolerance = 1e-12)\n expect_equal(ss_reused$yty, ss_fresh$yty, tolerance = 1e-12)\n expect_equal(ss_reused$y_mean, ss_fresh$y_mean, tolerance = 1e-12)\n\n # End-to-end: fits from the two stat sets must be the same.\n fit_reused <- susie_ss(\n XtX = ss_reused$XtX, Xty = ss_reused$Xty, yty = ss_reused$yty,\n n = ss_reused$n,\n X_colmeans = ss_reused$X_colmeans, y_mean = ss_reused$y_mean,\n L = 5, verbose = FALSE\n )\n fit_fresh <- susie_ss(\n XtX = ss_fresh$XtX, Xty = ss_fresh$Xty, yty = ss_fresh$yty,\n n = ss_fresh$n,\n X_colmeans = ss_fresh$X_colmeans, y_mean = ss_fresh$y_mean,\n L = 5, verbose = FALSE\n )\n expect_equal(fit_reused$pip, fit_fresh$pip, tolerance = 1e-10)\n expect_equal(fit_reused$V, fit_fresh$V, tolerance = 1e-10)\n})" }, { "path": "tests/testthat/test_summary_print.R", "content": "context(\"summary and print S3 methods\")\n\n# =============================================================================\n# summary.susie - Summary Statistics\n# =============================================================================\n\ntest_that(\"summary.susie creates correct structure\", {\n set.seed(1)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n summ <- summary(fit)\n\n expect_type(summ, \"list\")\n expect_s3_class(summ, \"summary.susie\")\n expect_named(summ, c(\"vars\", \"cs\"))\n})\n\ntest_that(\"summary.susie variables data frame has correct structure\", {\n set.seed(2)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n summ <- summary(fit)\n\n expect_s3_class(summ$vars, \"data.frame\")\n expect_true(all(c(\"variable\", \"variable_prob\", \"cs\") %in% colnames(summ$vars)))\n expect_equal(nrow(summ$vars), dat$p)\n})\n\ntest_that(\"summary.susie CS data frame has correct structure when CS exist\", {\n set.seed(3)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n summ <- summary(fit)\n\n if (!is.null(fit$sets$cs)) {\n expect_s3_class(summ$cs, \"data.frame\")\n expect_true(all(c(\"cs\", \"cs_log10bf\", \"cs_avg_r2\", \"cs_min_r2\", \"variable\") %in%\n colnames(summ$cs)))\n expect_equal(nrow(summ$cs), length(fit$sets$cs))\n }\n})\n\ntest_that(\"summary.susie variables sorted by PIP descending\", {\n set.seed(4)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n summ <- summary(fit)\n\n if (!is.null(fit$sets$cs)) {\n expect_true(all(diff(summ$vars$variable_prob) <= 0))\n }\n})\n\ntest_that(\"summary.susie cs column maps variables to credible sets\", {\n set.seed(5)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n summ <- summary(fit)\n\n if (!is.null(fit$sets$cs)) {\n for (i in 1:length(fit$sets$cs)) {\n cs_vars <- fit$sets$cs[[i]]\n cs_idx <- fit$sets$cs_index[i]\n expect_true(all(summ$vars$cs[summ$vars$variable %in% cs_vars] == cs_idx))\n }\n }\n})\n\ntest_that(\"summary.susie handles null_index correctly\", {\n set.seed(6)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, null_weight = 0.1, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n summ <- summary(fit)\n\n if (!is.null(fit$null_index) && fit$null_index > 0) {\n expect_equal(nrow(summ$vars), dat$p)\n } else {\n expect_equal(nrow(summ$vars), ncol(fit$alpha))\n }\n})\n\ntest_that(\"summary.susie errors when sets is NULL\", {\n set.seed(7)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n fit$sets <- NULL\n\n expect_error(\n summary(fit),\n \"credible set information\"\n )\n})\n\ntest_that(\"summary.susie handles no credible sets\", {\n set.seed(8)\n dat <- simulate_regression(n = 100, p = 50, k = 3, signal_sd = 0.1)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95, min_abs_corr = 0.99)\n\n summ <- summary(fit)\n\n expect_null(summ$cs)\n expect_s3_class(summ$vars, \"data.frame\")\n})\n\ntest_that(\"summary.susie log10BF calculation is correct\", {\n set.seed(9)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n summ <- summary(fit)\n\n if (!is.null(summ$cs)) {\n for (i in 1:nrow(summ$cs)) {\n cs_idx <- summ$cs$cs[i]\n expected_log10bf <- fit$lbf[cs_idx] / log(10)\n expect_equal(summ$cs$cs_log10bf[i], expected_log10bf)\n }\n }\n})\n\ntest_that(\"summary.susie r2 calculations are correct\", {\n set.seed(10)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n summ <- summary(fit)\n\n if (!is.null(summ$cs) && !is.null(fit$sets$purity)) {\n for (i in 1:nrow(summ$cs)) {\n expect_equal(summ$cs$cs_avg_r2[i], fit$sets$purity$mean.abs.corr[i]^2)\n expect_equal(summ$cs$cs_min_r2[i], fit$sets$purity$min.abs.corr[i]^2)\n }\n }\n})\n\n# =============================================================================\n# print.summary.susie - Console Output\n# =============================================================================\n\ntest_that(\"print.summary.susie produces output\", {\n set.seed(11)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n summ <- summary(fit)\n\n expect_message(capture.output(print(summ)), \"Variables in credible sets\")\n expect_message(capture.output(print(summ)), \"Credible sets summary\")\n})\n\ntest_that(\"print.summary.susie handles no CS\", {\n set.seed(12)\n dat <- simulate_regression(n = 100, p = 50, k = 3, signal_sd = 0.1)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95, min_abs_corr = 0.99)\n\n summ <- summary(fit)\n\n expect_message(capture.output(print(summ)))\n})\n\ntest_that(\"print.summary.susie shows variables in CS\", {\n set.seed(13)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n summ <- summary(fit)\n\n output <- capture.output(print(summ))\n output_text <- paste(output, collapse = \"\\n\")\n\n if (!is.null(fit$sets$cs)) {\n cs_vars <- summ$vars[summ$vars$cs > 0, ]\n for (i in 1:nrow(cs_vars)) {\n expect_true(grepl(as.character(cs_vars$variable[i]), output_text))\n }\n }\n})\n\ntest_that(\"summary and print work together\", {\n set.seed(14)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n expect_message(capture.output({\n summ <- summary(fit)\n print(summ)\n }))\n})\n\ntest_that(\"summary.susie variable column is sequential indices\", {\n set.seed(15)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n summ <- summary(fit)\n\n expect_equal(sort(unique(summ$vars$variable)), 1:dat$p)\n})\n\ntest_that(\"summary.susie variable_prob matches PIP\", {\n set.seed(16)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n summ <- summary(fit)\n\n expect_equal(sort(summ$vars$variable_prob, decreasing = TRUE),\n sort(fit$pip, decreasing = TRUE))\n})\n" }, { "path": "tests/testthat/test_susie.R", "content": "context(\"Main susie interface functions\")\n\n# =============================================================================\n# SUSIE() - BASIC FUNCTIONALITY\n# =============================================================================\n\ntest_that(\"susie returns valid susie object\", {\n set.seed(1)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n expect_true(\"alpha\" %in% names(fit))\n expect_true(\"mu\" %in% names(fit))\n expect_true(\"mu2\" %in% names(fit))\n expect_true(\"V\" %in% names(fit))\n expect_true(\"sigma2\" %in% names(fit))\n expect_true(\"pip\" %in% names(fit))\n expect_true(\"sets\" %in% names(fit))\n expect_true(\"elbo\" %in% names(fit))\n})\n\ntest_that(\"susie has correct dimensions\", {\n set.seed(2)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n expect_equal(dim(fit$alpha), c(5, 50))\n expect_equal(dim(fit$mu), c(5, 50))\n expect_equal(dim(fit$mu2), c(5, 50))\n expect_length(fit$V, 5)\n expect_length(fit$pip, 50)\n expect_length(fit$fitted, 100)\n})\n\ntest_that(\"susie maintains valid probability distributions\", {\n set.seed(3)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Alpha rows sum to 1\n expect_equal(rowSums(fit$alpha), rep(1, 5), tolerance = 1e-10)\n\n # Alpha values are valid probabilities\n expect_true(all(fit$alpha >= 0 & fit$alpha <= 1))\n\n # PIPs are valid probabilities\n expect_true(all(fit$pip >= 0 & fit$pip <= 1))\n})\n\ntest_that(\"susie ELBO is monotonically increasing\", {\n set.seed(4)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n elbo_diff <- diff(fit$elbo)\n expect_true(all(elbo_diff > -1e-6))\n})\n\ntest_that(\"susie converges within max_iter\", {\n set.seed(5)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 5, max_iter = 100, verbose = FALSE)\n\n expect_true(fit$niter <= 100)\n expect_true(\"converged\" %in% names(fit))\n})\n\n# =============================================================================\n# SUSIE() - PARAMETER HANDLING\n# =============================================================================\n\ntest_that(\"susie respects L parameter\", {\n set.seed(6)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit_L3 <- susie(dat$X, dat$y, L = 3, verbose = FALSE)\n fit_L7 <- susie(dat$X, dat$y, L = 7, verbose = FALSE)\n\n expect_equal(nrow(fit_L3$alpha), 3)\n expect_equal(nrow(fit_L7$alpha), 7)\n})\n\ntest_that(\"susie adjusts L when L > p\", {\n set.seed(7)\n dat <- simulate_regression(n = 100, p = 20, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 50, verbose = FALSE)\n\n expect_equal(nrow(fit$alpha), 20)\n})\n\ntest_that(\"susie handles standardize parameter\", {\n set.seed(8)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit_std <- susie(dat$X, dat$y, L = 5, standardize = TRUE, verbose = FALSE)\n fit_nostd <- susie(dat$X, dat$y, L = 5, standardize = FALSE, verbose = FALSE)\n\n expect_s3_class(fit_std, \"susie\")\n expect_s3_class(fit_nostd, \"susie\")\n expect_true(all(fit_std$X_column_scale_factors > 0))\n})\n\ntest_that(\"susie handles intercept parameter\", {\n set.seed(9)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit_int <- susie(dat$X, dat$y, L = 5, intercept = TRUE, verbose = FALSE)\n fit_noint <- susie(dat$X, dat$y, L = 5, intercept = FALSE, verbose = FALSE)\n\n expect_true(is.finite(fit_int$intercept))\n expect_equal(fit_noint$intercept, 0)\n})\n\ntest_that(\"susie handles prior_weights parameter\", {\n set.seed(10)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n # Uniform weights\n fit_uniform <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Custom weights (favor first 10 variables)\n custom_weights <- c(rep(10, 10), rep(1, 40))\n fit_custom <- susie(dat$X, dat$y, L = 5, prior_weights = custom_weights, verbose = FALSE)\n\n expect_s3_class(fit_uniform, \"susie\")\n expect_s3_class(fit_custom, \"susie\")\n})\n\ntest_that(\"susie handles null_weight parameter\", {\n set.seed(11)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit_nonull <- susie(dat$X, dat$y, L = 5, null_weight = 0, verbose = FALSE)\n fit_null <- susie(dat$X, dat$y, L = 5, null_weight = 0.1, verbose = FALSE)\n\n expect_equal(ncol(fit_nonull$alpha), 50)\n expect_equal(ncol(fit_null$alpha), 51)\n})\n\ntest_that(\"susie handles estimate_residual_variance parameter\", {\n set.seed(12)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fixed_sigma2 <- 1.5\n fit_fixed <- susie(dat$X, dat$y, L = 5,\n estimate_residual_variance = FALSE,\n residual_variance = fixed_sigma2,\n verbose = FALSE)\n\n fit_est <- susie(dat$X, dat$y, L = 5,\n estimate_residual_variance = TRUE,\n verbose = FALSE)\n\n expect_equal(fit_fixed$sigma2, fixed_sigma2)\n expect_true(fit_est$sigma2 != var(dat$y))\n})\n\ntest_that(\"susie handles estimate_prior_variance parameter\", {\n set.seed(13)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit_fixed <- susie(dat$X, dat$y, L = 5,\n estimate_prior_variance = FALSE,\n scaled_prior_variance = 0.5,\n verbose = FALSE)\n\n fit_est <- susie(dat$X, dat$y, L = 5,\n estimate_prior_variance = TRUE,\n verbose = FALSE)\n\n expect_s3_class(fit_fixed, \"susie\")\n expect_s3_class(fit_est, \"susie\")\n})\n\ntest_that(\"susie handles convergence_method parameter\", {\n set.seed(14)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit_elbo <- susie(dat$X, dat$y, L = 5, convergence_method = \"elbo\", verbose = FALSE)\n fit_pip <- susie(dat$X, dat$y, L = 5, convergence_method = \"pip\", verbose = FALSE)\n\n expect_s3_class(fit_elbo, \"susie\")\n expect_s3_class(fit_pip, \"susie\")\n})\n\ntest_that(\"susie handles compute_univariate_zscore parameter\", {\n set.seed(15)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit_noz <- susie(dat$X, dat$y, L = 5, compute_univariate_zscore = FALSE, verbose = FALSE)\n fit_z <- susie(dat$X, dat$y, L = 5, compute_univariate_zscore = TRUE, verbose = FALSE)\n\n expect_null(fit_noz$z)\n expect_true(!is.null(fit_z$z))\n expect_length(fit_z$z, 50)\n})\n\n# =============================================================================\n# SUSIE() - VARIANCE ESTIMATION METHODS\n# =============================================================================\n\ntest_that(\"susie handles estimate_residual_method = MoM\", {\n set.seed(16)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 5,\n estimate_residual_method = \"MoM\",\n verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n expect_true(fit$sigma2 > 0)\n})\n\ntest_that(\"susie handles estimate_residual_method = MLE\", {\n set.seed(17)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 5,\n estimate_residual_method = \"MLE\",\n verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n expect_true(fit$sigma2 > 0)\n})\n\ntest_that(\"susie handles estimate_residual_method = NIG\", {\n set.seed(18)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 1,\n estimate_residual_method = \"NIG\",\n verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n expect_true(fit$sigma2 > 0)\n})\n\ntest_that(\"susie errors clearly for invalid NIG alpha0/beta0\", {\n # Regression test for GitHub issue: NIG SER with alpha0 = 0 and beta0 > 0\n # using L = 1 previously produced an infinite ELBO crash. The fix is to\n # reject improper Inverse-Gamma priors at parameter validation, before the\n # ELBO is ever computed.\n set.seed(18)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n # Original failing case from the issue (L = 1, alpha0 = 0, beta0 > 0)\n expect_error(\n susie(dat$X, dat$y, L = 1,\n min_abs_corr = 0, check_null_threshold = -1000,\n estimate_residual_method = \"NIG\",\n alpha0 = 0, beta0 = 0.5,\n verbose = FALSE),\n \"alpha0 > 0 and beta0 > 0\"\n )\n\n # Both zero -- previously produced silent NaN; should now error\n expect_error(\n susie(dat$X, dat$y, L = 1,\n min_abs_corr = 0, check_null_threshold = -1000,\n estimate_residual_method = \"NIG\",\n alpha0 = 0, beta0 = 0,\n verbose = FALSE),\n \"alpha0 > 0 and beta0 > 0\"\n )\n\n # Same guard fires for L > 1 (the L=2 path no longer silently succeeds\n # with improper priors)\n expect_error(\n susie(dat$X, dat$y, L = 2,\n min_abs_corr = 0, check_null_threshold = -1000,\n estimate_residual_method = \"NIG\",\n alpha0 = 0, beta0 = 0.5,\n verbose = FALSE),\n \"alpha0 > 0 and beta0 > 0\"\n )\n\n # Sanity check: valid alpha0/beta0 still work for L=1 and L=2\n fit_l1 <- susie(dat$X, dat$y, L = 1,\n min_abs_corr = 0, check_null_threshold = -1000,\n estimate_residual_method = \"NIG\",\n alpha0 = 0.1, beta0 = 0.1,\n verbose = FALSE)\n expect_s3_class(fit_l1, \"susie\")\n\n fit_l2 <- susie(dat$X, dat$y, L = 2,\n min_abs_corr = 0, check_null_threshold = -1000,\n estimate_residual_method = \"NIG\",\n alpha0 = 0.1, beta0 = 0.1,\n verbose = FALSE)\n expect_s3_class(fit_l2, \"susie\")\n})\n\ntest_that(\"susie handles estimate_prior_method options\", {\n set.seed(19)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit_optim <- susie(dat$X, dat$y, L = 5, estimate_prior_method = \"optim\", verbose = FALSE)\n fit_em <- susie(dat$X, dat$y, L = 5, estimate_prior_method = \"EM\", verbose = FALSE)\n fit_simple <- susie(dat$X, dat$y, L = 5, estimate_prior_method = \"simple\", verbose = FALSE)\n\n expect_s3_class(fit_optim, \"susie\")\n expect_s3_class(fit_em, \"susie\")\n expect_s3_class(fit_simple, \"susie\")\n})\n\n# =============================================================================\n# SUSIE() - UNMAPPABLE EFFECTS\n# =============================================================================\n\ntest_that(\"susie handles unmappable_effects = none\", {\n set.seed(20)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 5, unmappable_effects = \"none\", verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n expect_false(\"theta\" %in% names(fit))\n expect_false(\"tau2\" %in% names(fit))\n})\n\ntest_that(\"susie handles unmappable_effects = inf\", {\n set.seed(21)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 5, unmappable_effects = \"inf\", verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n expect_true(\"theta\" %in% names(fit))\n expect_true(\"tau2\" %in% names(fit))\n expect_length(fit$theta, 50)\n})\n\ntest_that(\"susie handles unmappable_effects = ash\", {\n\n set.seed(22)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 5, unmappable_effects = \"ash\", verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n expect_true(\"theta\" %in% names(fit))\n expect_true(\"tau2\" %in% names(fit))\n})\n\n# =============================================================================\n# SUSIE() - SIGNAL RECOVERY\n# =============================================================================\n\ntest_that(\"susie identifies true causal variables\", {\n set.seed(23)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n # Top PIPs should include true causal variables\n top_vars <- order(fit$pip, decreasing = TRUE)[1:10]\n overlap <- length(intersect(top_vars, dat$causal_idx))\n\n expect_true(overlap >= 1)\n})\n\ntest_that(\"susie maintains low PIPs for null variables\", {\n set.seed(24)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n null_vars <- setdiff(1:dat$p, dat$causal_idx)\n null_pips <- fit$pip[null_vars]\n\n expect_true(median(null_pips) < 0.3)\n})\n\n# =============================================================================\n# SUSIE() - EDGE CASES\n# =============================================================================\n\ntest_that(\"susie handles L = 1\", {\n set.seed(25)\n dat <- simulate_regression(n = 100, p = 50, k = 1)\n\n fit <- susie(dat$X, dat$y, L = 1, verbose = FALSE)\n\n expect_equal(nrow(fit$alpha), 1)\n expect_equal(sum(fit$alpha), 1, tolerance = 1e-10)\n})\n\ntest_that(\"susie handles small p\", {\n set.seed(26)\n dat <- simulate_regression(n = 100, p = 5, k = 2)\n\n fit <- susie(dat$X, dat$y, L = 3, verbose = FALSE)\n\n expect_equal(ncol(fit$alpha), 5)\n})\n\ntest_that(\"susie errors on NA values when na.rm = FALSE\", {\n set.seed(28)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n dat$y[5] <- NA\n\n expect_error(\n susie(dat$X, dat$y, L = 5, na.rm = FALSE, verbose = FALSE),\n \"must not contain missing values\"\n )\n})\n\n# =============================================================================\n# SUSIE_SS() - BASIC FUNCTIONALITY\n# =============================================================================\n\ntest_that(\"susie_ss returns valid susie object\", {\n set.seed(29)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n X_centered <- scale(dat$X, center = TRUE, scale = FALSE)\n y_centered <- dat$y - mean(dat$y)\n\n XtX <- crossprod(X_centered)\n Xty <- as.vector(crossprod(X_centered, y_centered))\n yty <- sum(y_centered^2)\n\n fit <- susie_ss(XtX, Xty, yty, n = 100, L = 5, verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n expect_true(\"alpha\" %in% names(fit))\n expect_true(\"mu\" %in% names(fit))\n expect_true(\"V\" %in% names(fit))\n expect_true(\"sigma2\" %in% names(fit))\n expect_true(\"pip\" %in% names(fit))\n})\n\ntest_that(\"susie_ss has correct dimensions\", {\n set.seed(30)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_summary_stats(dat$X, dat$y)\n\n fit <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5, verbose = FALSE)\n\n expect_equal(dim(fit$alpha), c(5, 50))\n expect_equal(dim(fit$mu), c(5, 50))\n expect_length(fit$V, 5)\n expect_length(fit$pip, 50)\n})\n\ntest_that(\"susie_ss maintains valid probability distributions\", {\n set.seed(31)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_summary_stats(dat$X, dat$y)\n\n fit <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5, verbose = FALSE)\n\n expect_equal(rowSums(fit$alpha), rep(1, 5), tolerance = 1e-10)\n expect_true(all(fit$alpha >= 0 & fit$alpha <= 1))\n expect_true(all(fit$pip >= 0 & fit$pip <= 1))\n})\n\ntest_that(\"susie_ss ELBO is monotonically increasing\", {\n set.seed(32)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_summary_stats(dat$X, dat$y)\n\n fit <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5, verbose = FALSE)\n\n elbo_diff <- diff(fit$elbo)\n expect_true(all(elbo_diff > -1e-6))\n})\n\n# =============================================================================\n# SUSIE_SS() - CONSISTENCY WITH SUSIE()\n# =============================================================================\n\ntest_that(\"susie_ss agrees with susie on same data\", {\n set.seed(33)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n # Fit with individual data\n fit_ind <- susie(dat$X, dat$y, L = 5, standardize = TRUE, verbose = FALSE)\n\n # Compute sufficient statistics\n X_centered <- scale(dat$X, center = TRUE, scale = FALSE)\n y_centered <- dat$y - mean(dat$y)\n XtX <- crossprod(X_centered)\n Xty <- as.vector(crossprod(X_centered, y_centered))\n yty <- sum(y_centered^2)\n\n # Fit with sufficient statistics\n fit_ss <- susie_ss(XtX, Xty, yty, n = 100, L = 5,\n X_colmeans = colMeans(dat$X),\n y_mean = mean(dat$y),\n standardize = TRUE, verbose = FALSE)\n\n # Results should be very similar\n expect_equal(fit_ind$pip, fit_ss$pip, tolerance = 1e-3)\n expect_equal(fit_ind$V, fit_ss$V, tolerance = 1e-3)\n expect_equal(fit_ind$sigma2, fit_ss$sigma2, tolerance = 1e-3)\n})\n\n# =============================================================================\n# SUSIE_SS() - PARAMETER HANDLING\n# =============================================================================\n\ntest_that(\"susie_ss handles X_colmeans and y_mean for intercept\", {\n set.seed(34)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_summary_stats(dat$X, dat$y)\n\n fit_noint <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5, verbose = FALSE)\n\n fit_int <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5,\n X_colmeans = colMeans(dat$X),\n y_mean = mean(dat$y),\n verbose = FALSE)\n\n expect_true(is.na(fit_noint$intercept))\n expect_true(is.finite(fit_int$intercept))\n})\n\ntest_that(\"susie_ss handles maf filtering\", {\n set.seed(35)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_summary_stats(dat$X, dat$y)\n\n maf <- runif(50, 0, 0.5)\n\n fit <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5,\n maf = maf, maf_thresh = 0.1,\n verbose = FALSE)\n\n n_filtered <- sum(maf > 0.1)\n expect_equal(ncol(fit$alpha), n_filtered)\n})\n\ntest_that(\"susie_ss handles check_input parameter\", {\n set.seed(36)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_summary_stats(dat$X, dat$y)\n\n fit <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5,\n check_input = TRUE,\n verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n})\n\ntest_that(\"susie_ss handles unmappable_effects = inf\", {\n set.seed(37)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_summary_stats(dat$X, dat$y)\n\n fit <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5,\n unmappable_effects = \"inf\",\n verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n expect_true(\"theta\" %in% names(fit))\n expect_true(\"tau2\" %in% names(fit))\n})\n\n# =============================================================================\n# SUSIE_RSS() - BASIC FUNCTIONALITY (lambda = 0)\n# =============================================================================\n\ntest_that(\"susie_rss with lambda = 0 returns valid susie object\", {\n set.seed(39)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n ss <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss, cov2cor(XtX))\n\n fit <- susie_rss(z = z_scores, R = R, n = 100, L = 5 , verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n expect_true(\"alpha\" %in% names(fit))\n expect_true(\"mu\" %in% names(fit))\n expect_true(\"V\" %in% names(fit))\n expect_true(\"pip\" %in% names(fit))\n})\n\ntest_that(\"susie_rss with lambda = 0 has correct dimensions\", {\n set.seed(40)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n ss <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss, cov2cor(XtX))\n\n fit <- susie_rss(z = z_scores, R = R, n = 100, L = 5 , verbose = FALSE)\n\n expect_equal(dim(fit$alpha), c(5, 50))\n expect_equal(dim(fit$mu), c(5, 50))\n expect_length(fit$V, 5)\n expect_length(fit$pip, 50)\n})\n\ntest_that(\"susie_rss with lambda = 0 maintains valid probability distributions\", {\n set.seed(41)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n ss <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss, cov2cor(XtX))\n\n fit <- susie_rss(z = z_scores, R = R, n = 100, L = 5 , verbose = FALSE)\n\n expect_equal(rowSums(fit$alpha), rep(1, 5), tolerance = 1e-10)\n expect_true(all(fit$alpha >= 0 & fit$alpha <= 1))\n expect_true(all(fit$pip >= 0 & fit$pip <= 1))\n})\n\ntest_that(\"susie_rss with lambda = 0 accepts bhat and shat instead of z\", {\n set.seed(42)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n ss <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n univar <- univariate_regression(dat$X, dat$y)\n R <- with(ss, cov2cor(XtX))\n\n fit <- susie_rss(bhat = univar$betahat, shat = univar$sebetahat,\n R = R, n = 100, L = 5 , verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n expect_equal(dim(fit$alpha), c(5, 50))\n})\n\ntest_that(\"susie_rss with lambda = 0 handles maf filtering\", {\n set.seed(43)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n ss <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss, cov2cor(XtX))\n maf <- runif(50, 0, 0.5)\n\n fit <- susie_rss(z = z_scores, R = R, n = 100, L = 5 , maf = maf, maf_thresh = 0.1,\n verbose = FALSE)\n\n n_filtered <- sum(maf > 0.1)\n expect_equal(ncol(fit$alpha), n_filtered)\n})\n\n# =============================================================================\n# SUSIE_RSS() - BASIC FUNCTIONALITY (lambda > 0)\n# =============================================================================\n\ntest_that(\"susie_rss_lambda with lambda > 0 returns valid susie object\", {\n set.seed(44)\n setup <- setup_rss_lambda_data(n = 500, p = 50, k = 3, lambda = 1e-5, seed = NULL)\n\n fit <- susie_rss_lambda(z = setup$z, R = setup$R, L = 5,\n lambda = 1e-5, verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n expect_true(\"alpha\" %in% names(fit))\n expect_true(\"mu\" %in% names(fit))\n expect_true(\"V\" %in% names(fit))\n expect_true(\"pip\" %in% names(fit))\n})\n\ntest_that(\"susie_rss_lambda with lambda > 0 has correct dimensions\", {\n set.seed(45)\n setup <- setup_rss_lambda_data(n = 500, p = 50, k = 3, lambda = 1e-5, seed = NULL)\n\n fit <- susie_rss_lambda(z = setup$z, R = setup$R, L = 5,\n lambda = 1e-5, verbose = FALSE)\n\n expect_equal(dim(fit$alpha), c(5, 50))\n expect_equal(dim(fit$mu), c(5, 50))\n expect_length(fit$V, 5)\n expect_length(fit$pip, 50)\n})\n\ntest_that(\"susie_rss_lambda with lambda > 0 maintains valid probability distributions\", {\n set.seed(46)\n setup <- setup_rss_lambda_data(n = 500, p = 50, k = 3, lambda = 1e-5, seed = NULL)\n\n fit <- susie_rss_lambda(z = setup$z, R = setup$R, L = 5,\n lambda = 1e-5, verbose = FALSE)\n\n expect_equal(rowSums(fit$alpha), rep(1, 5), tolerance = 1e-10)\n expect_true(all(fit$alpha >= 0 & fit$alpha <= 1))\n expect_true(all(fit$pip >= 0 & fit$pip <= 1))\n})\n\ntest_that(\"susie_rss_lambda with lambda > 0 handles maf filtering\", {\n set.seed(47)\n setup <- setup_rss_lambda_data(n = 500, p = 50, k = 3, lambda = 1e-5, seed = NULL)\n maf <- runif(50, 0, 0.5)\n\n fit <- susie_rss_lambda(z = setup$z, R = setup$R, L = 5,\n lambda = 1e-5, maf = maf, maf_thresh = 0.1,\n verbose = FALSE)\n\n n_filtered <- sum(maf > 0.1)\n expect_equal(ncol(fit$alpha), n_filtered)\n})\n\ntest_that(\"susie_rss_lambda with lambda > 0 ELBO is monotonically increasing\", {\n set.seed(48)\n setup <- setup_rss_lambda_data(n = 500, p = 50, k = 3, lambda = 1e-5, seed = NULL)\n\n fit <- susie_rss_lambda(z = setup$z, R = setup$R, L = 5,\n lambda = 1e-5, verbose = FALSE)\n\n elbo_diff <- diff(fit$elbo)\n expect_true(all(elbo_diff > -1e-6))\n})\n\ntest_that(\"susie_rss_lambda with lambda > 0 identifies causal variables\", {\n set.seed(49)\n setup <- setup_rss_lambda_data(n = 500, p = 50, k = 3, lambda = 1e-5,\n signal_sd = 1, seed = NULL)\n\n fit <- susie_rss_lambda(z = setup$z, R = setup$R, L = 10,\n lambda = 1e-5, verbose = FALSE)\n\n # Top PIPs should include at least one true causal variable\n top_vars <- order(fit$pip, decreasing = TRUE)[1:10]\n overlap <- length(intersect(top_vars, setup$causal_idx))\n\n expect_true(overlap >= 1)\n})\n\n# =============================================================================\n# SUSIE_RSS() - LAMBDA PARAMETER HANDLING\n# =============================================================================\n\ntest_that(\"susie_rss switches data type based on lambda\", {\n set.seed(50)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss, cov2cor(XtX))\n\n # lambda = 0 should use sufficient statistics\n fit_lambda0 <- susie_rss(z = z_scores, R = R, n = 100, L = 5 , verbose = FALSE)\n\n # lambda > 0 should use rss_lambda class\n fit_lambda_pos <- susie_rss_lambda(z = z_scores, R = R, L = 5,\n lambda = 1e-5, verbose = FALSE)\n\n expect_s3_class(fit_lambda0, \"susie\")\n expect_s3_class(fit_lambda_pos, \"susie\")\n})\n\ntest_that(\"susie_rss_lambda with lambda > 0 accepts n parameter for PVE adjustment\", {\n set.seed(51)\n setup <- setup_rss_lambda_data(n = 500, p = 50, k = 3, lambda = 1e-5, seed = NULL)\n\n # n is now used for PVE adjustment in all paths; no \"n is not used\" warning\n fit <- susie_rss_lambda(z = setup$z, R = setup$R, n = 100, L = 5,\n lambda = 1e-5, verbose = FALSE)\n expect_s3_class(fit, \"susie\")\n})\n\ntest_that(\"susie_rss_lambda does not expose bhat/shat\", {\n set.seed(52)\n setup <- setup_rss_lambda_data(n = 500, p = 50, k = 3, lambda = 1e-5, seed = NULL)\n\n expect_error(\n susie_rss_lambda(z = setup$z, R = setup$R, L = 5,\n\t bhat = rnorm(50), shat = runif(50, 0.5, 1),\n\t lambda = 1e-5, verbose = FALSE),\n \"unused argument\"\n )\n})\n\ntest_that(\"susie_rss_lambda does not expose var_y\", {\n set.seed(53)\n setup <- setup_rss_lambda_data(n = 500, p = 50, k = 3, lambda = 1e-5, seed = NULL)\n\n expect_error(\n susie_rss_lambda(z = setup$z, R = setup$R, L = 5,\n\t var_y = 1.5, lambda = 1e-5, verbose = FALSE),\n \"unused argument\"\n )\n})\n\ntest_that(\"susie_rss does not expose intercept_value\", {\n set.seed(54)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss, cov2cor(XtX))\n\n expect_error(\n susie_rss(z = z_scores, R = R, n = 100, L = 5 , intercept_value = 0.5, verbose = FALSE),\n \"unused argument\"\n )\n})\n\n# =============================================================================\n# SUSIE_RSS() - INPUT VALIDATION\n# =============================================================================\n\ntest_that(\"susie_rss requires either z or bhat/shat\", {\n R <- diag(50)\n\n expect_error(\n susie_rss(R = R, n = 100, L = 5 , verbose = FALSE),\n \"Please provide either z or \\\\(bhat, shat\\\\)\"\n )\n})\n\ntest_that(\"susie_rss rejects both z and bhat/shat\", {\n z <- rnorm(50)\n bhat <- rnorm(50)\n shat <- runif(50, 0.5, 1)\n R <- diag(50)\n\n expect_error(\n susie_rss(z = z, bhat = bhat, shat = shat, R = R, n = 100,\n L = 5 , verbose = FALSE),\n \"Please provide either z or \\\\(bhat, shat\\\\), but not both\"\n )\n})\n\ntest_that(\"susie_rss does not expose check_R\", {\n set.seed(55)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss, cov2cor(XtX))\n\n expect_error(\n susie_rss(z = z_scores, R = R, n = 100, L = 5,\n check_R = TRUE, verbose = FALSE),\n \"unused argument\"\n )\n})\n\n# =============================================================================\n# INTEGRATION TESTS - CROSS-METHOD COMPARISONS\n# =============================================================================\n\ntest_that(\"susie, susie_ss, and susie_rss give similar PIPs\", {\n set.seed(56)\n dat <- simulate_regression(n = 100, p = 50, k = 3, signal_sd = 2)\n\n # Fit with individual data\n fit_ind <- susie(dat$X, dat$y, L = 5, standardize = TRUE,\n intercept = TRUE, verbose = FALSE)\n\n # Fit with sufficient statistics\n X_centered <- scale(dat$X, center = TRUE, scale = FALSE)\n y_centered <- dat$y - mean(dat$y)\n XtX <- crossprod(X_centered)\n Xty <- as.vector(crossprod(X_centered, y_centered))\n yty <- sum(y_centered^2)\n\n fit_ss <- susie_ss(XtX, Xty, yty, n = 100, L = 5,\n X_colmeans = colMeans(dat$X),\n y_mean = mean(dat$y),\n standardize = TRUE, verbose = FALSE)\n\n # Fit with RSS (lambda = 0)\n ss <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss, cov2cor(XtX))\n\n fit_rss <- susie_rss(z = z_scores, R = R, n = 100, L = 5 , verbose = FALSE, estimate_residual_variance = TRUE)\n\n # PIPs should be very similar\n expect_equal(fit_ind$pip, fit_ss$pip, tolerance = 1e-3)\n expect_equal(fit_ind$pip, fit_rss$pip, tolerance = 1e-2)\n})\n\ntest_that(\"All three interfaces find credible sets\", {\n set.seed(57)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n\n fit_ind <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n ss <- compute_summary_stats(dat$X, dat$y)\n fit_ss <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 10, verbose = FALSE)\n\n ss_full <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss_full, cov2cor(XtX))\n fit_rss <- susie_rss(z = z_scores, R = R, n = 200, L = 10 , verbose = FALSE)\n\n # At least one method should find credible sets\n has_cs <- (!is.null(fit_ind$sets$cs) && length(fit_ind$sets$cs) > 0) ||\n (!is.null(fit_ss$sets$cs) && length(fit_ss$sets$cs) > 0) ||\n (!is.null(fit_rss$sets$cs) && length(fit_rss$sets$cs) > 0)\n\n expect_true(has_cs)\n})\n\n# =============================================================================\n# REFINE PARAMETER\n# =============================================================================\n\ntest_that(\"susie handles refine = TRUE\", {\n set.seed(58)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n\n fit_norefine <- susie(dat$X, dat$y, L = 10, refine = FALSE, verbose = FALSE)\n fit_refine <- susie(dat$X, dat$y, L = 10, refine = TRUE, verbose = FALSE)\n\n expect_s3_class(fit_norefine, \"susie\")\n expect_s3_class(fit_refine, \"susie\")\n\n # Refined model should have equal or better ELBO\n elbo_norefine <- susie_get_objective(fit_norefine, last_only = TRUE)\n elbo_refine <- susie_get_objective(fit_refine, last_only = TRUE)\n\n expect_true(elbo_refine >= elbo_norefine - 1e-6)\n})\n\ntest_that(\"susie_ss handles refine = TRUE\", {\n set.seed(59)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n ss <- compute_summary_stats(dat$X, dat$y)\n\n fit <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 10,\n refine = TRUE, verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n})\n\ntest_that(\"susie_rss handles refine = TRUE\", {\n set.seed(60)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n ss <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss, cov2cor(XtX))\n\n fit <- susie_rss(z = z_scores, R = R, n = 200, L = 10 , refine = TRUE, verbose = FALSE)\n\n expect_s3_class(fit, \"susie\")\n})\n\n# =============================================================================\n# TRACK_FIT PARAMETER\n# =============================================================================\n\ntest_that(\"susie handles track_fit = TRUE\", {\n set.seed(61)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit <- susie(dat$X, dat$y, L = 5, track_fit = TRUE, verbose = FALSE)\n\n expect_true(\"trace\" %in% names(fit))\n expect_type(fit$trace, \"list\")\n})\n\ntest_that(\"susie_ss handles track_fit = TRUE\", {\n set.seed(62)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_summary_stats(dat$X, dat$y)\n\n fit <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5,\n track_fit = TRUE, verbose = FALSE)\n\n expect_true(\"trace\" %in% names(fit))\n expect_type(fit$trace, \"list\")\n})\n\ntest_that(\"susie_rss handles track_fit = TRUE\", {\n set.seed(63)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss, cov2cor(XtX))\n\n fit <- susie_rss(z = z_scores, R = R, n = 100, L = 5 , track_fit = TRUE, verbose = FALSE)\n\n expect_true(\"trace\" %in% names(fit))\n expect_type(fit$trace, \"list\")\n})\n\n# =============================================================================\n# VERBOSE PARAMETER\n# =============================================================================\n\ntest_that(\"susie verbose output works\", {\n set.seed(64)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n expect_message(\n susie(dat$X, dat$y, L = 5, verbose = TRUE),\n \"ELBO\"\n )\n})\n\ntest_that(\"susie_ss verbose output works\", {\n set.seed(65)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_summary_stats(dat$X, dat$y)\n\n expect_message(\n susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5, verbose = TRUE),\n \"ELBO\"\n )\n})\n\ntest_that(\"susie_rss verbose output works\", {\n set.seed(66)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n ss <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss, cov2cor(XtX))\n\n expect_message(\n susie_rss(z = z_scores, R = R, n = 100, L = 5 , verbose = TRUE),\n \"ELBO\"\n )\n})\n\n# =============================================================================\n# MATHEMATICAL PROPERTIES - ALL INTERFACES\n# =============================================================================\n\ntest_that(\"All interfaces maintain non-negative prior variances\", {\n set.seed(67)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit_ind <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n expect_true(all(fit_ind$V >= 0))\n\n ss <- compute_summary_stats(dat$X, dat$y)\n fit_ss <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5, verbose = FALSE)\n expect_true(all(fit_ss$V >= 0))\n\n ss_full <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss_full, cov2cor(XtX))\n fit_rss <- susie_rss(z = z_scores, R = R, n = 100, L = 5 , verbose = FALSE)\n expect_true(all(fit_rss$V >= 0))\n})\n\ntest_that(\"All interfaces maintain positive residual variance\", {\n set.seed(68)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n fit_ind <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n expect_true(fit_ind$sigma2 > 0)\n\n ss <- compute_summary_stats(dat$X, dat$y)\n fit_ss <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5, verbose = FALSE)\n expect_true(fit_ss$sigma2 > 0)\n\n ss_full <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss_full, cov2cor(XtX))\n fit_rss <- susie_rss(z = z_scores, R = R, n = 100, L = 5 , verbose = FALSE)\n expect_true(fit_rss$sigma2 > 0)\n})\n\n# =============================================================================\n# OUTPUT COMPATIBILITY\n# =============================================================================\n\ntest_that(\"All interfaces produce output compatible with susie_get functions\", {\n set.seed(69)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n\n # Test susie\n fit_ind <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n expect_length(susie_get_pip(fit_ind), 50)\n expect_equal(susie_get_objective(fit_ind, last_only = TRUE),\n fit_ind$elbo[length(fit_ind$elbo)])\n\n # Test susie_ss\n ss <- compute_summary_stats(dat$X, dat$y)\n fit_ss <- susie_ss(ss$XtX, ss$Xty, ss$yty, n = ss$n, L = 5, verbose = FALSE)\n expect_length(susie_get_pip(fit_ss), 50)\n expect_equal(susie_get_objective(fit_ss, last_only = TRUE),\n fit_ss$elbo[length(fit_ss$elbo)])\n\n # Test susie_rss\n ss_full <- compute_suff_stat(dat$X, dat$y, standardize = TRUE)\n z_scores <- with(univariate_regression(dat$X, dat$y), betahat / sebetahat)\n R <- with(ss_full, cov2cor(XtX))\n fit_rss <- susie_rss(z = z_scores, R = R, n = 100, L = 5 , verbose = FALSE)\n expect_length(susie_get_pip(fit_rss), 50)\n expect_equal(susie_get_objective(fit_rss, last_only = TRUE),\n fit_rss$elbo[length(fit_rss$elbo)])\n})\n" }, { "path": "tests/testthat/test_susie_ash_ss_equivalence.R", "content": "# =============================================================================\n# Test: SuSiE-ash (filter-archived) Individual vs Summary Statistics Equivalence\n# =============================================================================\n#\n# Verifies that the archived filter-based masking path\n# (unmappable_effects=\"ash_filter_archived\") produces equivalent results\n# between individual-level (mr.ash) and summary stats (mr.ash.rss) paths.\n# Both share the masking logic via compute_ash_masking().\n# =============================================================================\n\n# Helper: prepare individual and SS data from a common dataset\nsetup_susie_ash_test <- function(n = 200, p = 50, k = 5, seed = 42) {\n set.seed(seed)\n X <- matrix(rnorm(n * p), n, p)\n X <- scale(X, center = TRUE, scale = TRUE)\n beta_true <- rep(0, p)\n causal <- sample(1:p, k)\n beta_true[causal] <- rnorm(k, sd = 2)\n y <- c(X %*% beta_true + rnorm(n))\n y <- y - mean(y)\n\n # Sufficient stats\n XtX <- crossprod(X)\n Xty <- crossprod(X, y)\n yty <- sum(y^2)\n\n # RSS inputs\n bhat <- sapply(1:p, function(j) sum(X[, j] * y) / sum(X[, j]^2))\n shat <- sapply(1:p, function(j) {\n resid <- y - X[, j] * bhat[j]\n sqrt(sum(resid^2) / ((n - 2) * sum(X[, j]^2)))\n })\n R_mat <- susieR:::safe_cor(X)\n\n list(X = X, y = y, n = n, p = p,\n XtX = XtX, Xty = Xty, yty = yty,\n bhat = bhat, shat = shat, R_mat = R_mat,\n beta_true = beta_true, causal = causal)\n}\n\ntest_that(\"susie_ss ash agrees with susie individual-level ash\", {\n d <- setup_susie_ash_test(n = 200, p = 50, k = 5, seed = 42)\n\n # Individual-level: uses mr.ash directly\n fit_ind <- susie(d$X, d$y, L = 5,\n unmappable_effects = \"ash_filter_archived\",\n estimate_residual_variance = TRUE,\n estimate_prior_method = \"optim\",\n intercept = FALSE, standardize = FALSE,\n max_iter = 20, verbose = FALSE\n )\n\n # SS path: uses mr.ash.rss\n fit_ss <- susie_ss(\n XtX = d$XtX, Xty = d$Xty, yty = d$yty, n = d$n, L = 5,\n unmappable_effects = \"ash_filter_archived\",\n estimate_residual_variance = TRUE,\n estimate_prior_method = \"optim\",\n max_iter = 20, verbose = FALSE\n )\n\n # mr.ash and mr.ash.rss agree to ~1e-5 tolerance\n expect_equal(fit_ss$theta, fit_ind$theta, tolerance = 1e-4,\n label = \"theta (mr.ash coefficients)\")\n expect_equal(fit_ss$sigma2, fit_ind$sigma2, tolerance = 1e-4,\n label = \"sigma2 (residual variance)\")\n\n # PIPs should be highly correlated\n pip_cor <- cor(susie_get_pip(fit_ss), susie_get_pip(fit_ind))\n expect_true(pip_cor > 0.999,\n label = \"PIP correlation > 0.999\")\n})\n\ntest_that(\"susie_ss ash works with different data sizes\", {\n for (params in list(\n list(n = 100, p = 30, k = 3, seed = 100),\n list(n = 300, p = 80, k = 8, seed = 200)\n )) {\n d <- setup_susie_ash_test(\n n = params$n, p = params$p,\n k = params$k, seed = params$seed\n )\n\n fit_ind <- susie(d$X, d$y, L = 5,\n unmappable_effects = \"ash_filter_archived\",\n estimate_residual_variance = TRUE,\n estimate_prior_method = \"optim\",\n intercept = FALSE, standardize = FALSE,\n max_iter = 15, verbose = FALSE\n )\n\n fit_ss <- susie_ss(\n XtX = d$XtX, Xty = d$Xty, yty = d$yty, n = d$n, L = 5,\n unmappable_effects = \"ash_filter_archived\",\n estimate_residual_variance = TRUE,\n estimate_prior_method = \"optim\",\n max_iter = 15, verbose = FALSE\n )\n\n expect_equal(fit_ss$theta, fit_ind$theta, tolerance = 1e-4,\n label = sprintf(\"theta (n=%d, p=%d)\", params$n, params$p))\n expect_equal(fit_ss$sigma2, fit_ind$sigma2, tolerance = 1e-4,\n label = sprintf(\"sigma2 (n=%d, p=%d)\", params$n, params$p))\n pip_cor <- cor(susie_get_pip(fit_ss), susie_get_pip(fit_ind))\n expect_true(pip_cor > 0.999,\n label = sprintf(\"PIP cor > 0.999 (n=%d, p=%d)\", params$n, params$p))\n }\n})\n\ntest_that(\"susie individual-level ash output has expected fields\", {\n d <- setup_susie_ash_test(n = 100, p = 30, k = 3, seed = 123)\n\n fit_ind <- susie(d$X, d$y, L = 5,\n unmappable_effects = \"ash_filter_archived\",\n estimate_residual_variance = TRUE,\n estimate_prior_method = \"optim\",\n intercept = FALSE, standardize = FALSE,\n max_iter = 10, verbose = FALSE\n )\n\n # Check key fields exist\n expect_true(is.numeric(fit_ind$theta))\n expect_true(is.numeric(fit_ind$sigma2))\n expect_true(is.numeric(fit_ind$tau2))\n expect_true(is.matrix(fit_ind$alpha))\n\n # Check dimensions\n expect_length(fit_ind$theta, d$p)\n expect_length(fit_ind$sigma2, 1)\n expect_equal(ncol(fit_ind$alpha), d$p)\n\n # X_theta should be cleaned up\n expect_null(fit_ind$X_theta)\n})\n\ntest_that(\"susie_ss ash output has expected fields\", {\n d <- setup_susie_ash_test(n = 100, p = 30, k = 3, seed = 123)\n\n fit_ss <- susie_ss(\n XtX = d$XtX, Xty = d$Xty, yty = d$yty, n = d$n, L = 5,\n unmappable_effects = \"ash_filter_archived\",\n estimate_residual_variance = TRUE,\n estimate_prior_method = \"optim\",\n max_iter = 10, verbose = FALSE\n )\n\n # Check key fields exist\n expect_true(is.numeric(fit_ss$theta))\n expect_true(is.numeric(fit_ss$sigma2))\n expect_true(is.numeric(fit_ss$tau2))\n expect_true(is.matrix(fit_ss$alpha))\n\n # Check dimensions\n expect_length(fit_ss$theta, d$p)\n expect_length(fit_ss$sigma2, 1)\n expect_equal(ncol(fit_ss$alpha), d$p)\n})\n\ntest_that(\"susie_rss ash works with correlation matrix input\", {\n d <- setup_susie_ash_test(n = 200, p = 50, k = 5, seed = 42)\n\n fit_rss <- susie_rss(\n bhat = d$bhat, shat = d$shat, R = d$R_mat, n = d$n, L = 5,\n unmappable_effects = \"ash_filter_archived\",\n estimate_residual_variance = TRUE,\n estimate_prior_method = \"optim\",\n max_iter = 20, verbose = FALSE\n )\n\n # Basic sanity checks\n expect_true(is.numeric(fit_rss$theta))\n expect_length(fit_rss$theta, d$p)\n expect_true(is.numeric(fit_rss$sigma2))\n expect_true(length(fit_rss$sets$cs) >= 0)\n})\n" }, { "path": "tests/testthat/test_susie_auto.R", "content": "context(\"susie_auto unit tests\")\n\n# =============================================================================\n# ALGORITHM PROGRESSION\n# =============================================================================\n\ntest_that(\"susie_auto starts with L_init and doubles correctly\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 3, signal_sd = 1, seed = 123)\n # Manually set specific beta values for this test\n base_data$beta[base_data$causal_idx] <- c(2, -1.5, 1)\n base_data$y <- as.vector(base_data$X %*% base_data$beta + rnorm(base_data$n))\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 4, verbose = FALSE)\n\n L_final <- nrow(result$alpha)\n expect_true(L_final >= 1)\n expect_true(L_final %in% c(1, 2, 4, 8))\n})\n\ntest_that(\"susie_auto respects L_max limit\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 124)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 8, verbose = FALSE)\n\n L_final <- nrow(result$alpha)\n expect_true(L_final %in% c(1, 2, 4, 8, 16))\n})\n\ntest_that(\"susie_auto converges when prior variances hit zero\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 1, signal_sd = 3, seed = 125)\n\n # With single effect, should converge quickly (some V should be 0)\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 16, verbose = FALSE)\n\n # At least one prior variance should be zero (or very small)\n expect_true(any(result$V < 1e-3))\n})\n\ntest_that(\"susie_auto handles L_init = L_max (no doubling)\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 126)\n\n # No doubling should occur\n result <- susie_auto(base_data$X, base_data$y, L_init = 5, L_max = 5, verbose = FALSE)\n\n # Should complete successfully with L = 5\n expect_equal(nrow(result$alpha), 5)\n expect_true(is.finite(result$elbo[length(result$elbo)]))\n})\n\n# =============================================================================\n# CONVERGENCE BEHAVIOR\n# =============================================================================\n\ntest_that(\"susie_auto convergence logic: stops when any V = 0\", {\n set.seed(127)\n base_data <- generate_base_data(n = 100, p = 50, k = 1, signal_sd = 5, seed = NULL)\n # Add lower noise\n base_data$y <- base_data$X %*% base_data$beta + rnorm(base_data$n, sd = 0.5)\n\n # Should converge with strong single effect\n result <- susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 32, verbose = FALSE)\n\n # At least one V should be effectively zero (converged)\n expect_true(any(result$V < 1e-6))\n\n # Result should complete successfully\n expect_true(is.finite(result$elbo[length(result$elbo)]))\n})\n\ntest_that(\"susie_auto continues until L_max when all V > 0\", {\n set.seed(128)\n base_data <- generate_base_data(n = 100, p = 50, k = 10, signal_sd = 0.5, seed = NULL)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 4, verbose = FALSE)\n\n L_final <- nrow(result$alpha)\n expect_true(L_final %in% c(1, 2, 4, 8))\n})\n\n# =============================================================================\n# PARAMETER PROPAGATION\n# =============================================================================\n\ntest_that(\"susie_auto propagates standardize parameter correctly\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 129)\n # Create X with different scales\n base_data$X <- sweep(base_data$X, 2, seq(0.1, 5, length.out = base_data$p), \"*\")\n base_data$y <- as.vector(base_data$X %*% base_data$beta + rnorm(base_data$n))\n\n result_std <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4,\n standardize = TRUE, verbose = FALSE)\n result_nostd <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4,\n standardize = FALSE, verbose = FALSE)\n\n expect_true(all(result_std$alpha >= 0 & result_std$alpha <= 1))\n expect_true(all(result_nostd$alpha >= 0 & result_nostd$alpha <= 1))\n})\n\ntest_that(\"susie_auto propagates intercept parameter correctly\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 130)\n base_data$y <- as.vector(base_data$X %*% base_data$beta + 3 + rnorm(base_data$n)) # Add intercept\n\n result_int <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4,\n intercept = TRUE, verbose = FALSE)\n result_noint <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4,\n intercept = FALSE, verbose = FALSE)\n\n # Intercept estimates should differ\n expect_false(isTRUE(all.equal(result_int$intercept, result_noint$intercept,\n tolerance = 1e-3)))\n})\n\ntest_that(\"susie_auto propagates max_iter parameter correctly\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 131)\n\n # Use very small max_iter to test propagation\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 2, max_iter = 3,\n verbose = FALSE)\n\n # Should complete (may not converge, but should respect max_iter)\n expect_true(result$niter <= 3)\n})\n\ntest_that(\"susie_auto uses init_tol for early runs and tol for final run\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 132)\n\n # Large init_tol should make early runs converge faster\n result_large_init <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 2,\n init_tol = 10, tol = 1e-3, verbose = FALSE)\n result_small_init <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 2,\n init_tol = 1e-5, tol = 1e-3, verbose = FALSE)\n\n # Both should complete successfully\n expect_true(is.finite(result_large_init$elbo[length(result_large_init$elbo)]))\n expect_true(is.finite(result_small_init$elbo[length(result_small_init$elbo)]))\n})\n\ntest_that(\"susie_auto passes additional arguments via ...\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 133)\n\n # Pass coverage argument\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 2, coverage = 0.9,\n verbose = FALSE)\n\n # Should complete successfully\n expect_true(is.finite(result$elbo[length(result$elbo)]))\n\n # Check that sets are computed (if any exist)\n if (!is.null(result$sets)) {\n expect_true(is.list(result$sets))\n }\n})\n\n# =============================================================================\n# MODEL INITIALIZATION & EXPANSION\n# =============================================================================\n\ntest_that(\"susie_auto correctly expands L via add_null_effect\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 5, signal_sd = 1, seed = 134)\n\n # Start small and let it expand\n result <- susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 8, verbose = FALSE)\n\n L_final <- nrow(result$alpha)\n\n # Dimensions should be consistent\n expect_equal(nrow(result$alpha), L_final)\n expect_equal(nrow(result$mu), L_final)\n expect_equal(nrow(result$mu2), L_final)\n expect_equal(length(result$V), L_final)\n expect_equal(length(result$KL), L_final)\n})\n\ntest_that(\"susie_auto maintains valid model structure throughout\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 135)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n # Check model structure\n L <- nrow(result$alpha)\n expect_equal(dim(result$alpha), c(L, base_data$p))\n expect_equal(dim(result$mu), c(L, base_data$p))\n expect_equal(dim(result$mu2), c(L, base_data$p))\n expect_equal(length(result$V), L)\n expect_equal(length(result$KL), L)\n\n # Alpha rows should sum to 1\n expect_true(all(abs(rowSums(result$alpha) - 1) < 1e-10))\n})\n\n# =============================================================================\n# VARIANCE ESTIMATION\n# =============================================================================\n\ntest_that(\"susie_auto estimates variances in correct stages\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 136)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 2, verbose = FALSE)\n\n # Final result should have estimated variances\n expect_true(result$sigma2 > 0)\n expect_true(all(result$V >= 0))\n})\n\ntest_that(\"susie_auto residual variance is positive\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 137)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n expect_true(result$sigma2 > 0)\n expect_true(is.finite(result$sigma2))\n})\n\ntest_that(\"susie_auto prior variances are non-negative\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 138)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n expect_true(all(result$V >= 0))\n expect_true(all(is.finite(result$V)))\n})\n\n# =============================================================================\n# EDGE CASES & ROBUSTNESS\n# =============================================================================\n\ntest_that(\"susie_auto handles sparse signal (single effect)\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 1, signal_sd = 3, seed = 139)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 8, verbose = FALSE)\n\n # Should identify the effect\n pips <- colSums(result$alpha * result$mu)\n expect_true(max(pips) > 0.5) # At least one variable should have high PIP\n\n # Most V should be zero or very small\n expect_true(sum(result$V < 1e-3) >= length(result$V) - 2)\n})\n\ntest_that(\"susie_auto handles dense signal (many effects)\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 8, signal_sd = 0.5, seed = 140)\n\n # May need multiple doublings\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 16, verbose = FALSE)\n\n # Should complete successfully\n expect_true(is.finite(result$elbo[length(result$elbo)]))\n expect_true(nrow(result$alpha) >= 2)\n})\n\ntest_that(\"susie_auto handles high noise scenario\", {\n set.seed(141)\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = NULL)\n # Add high noise\n base_data$y <- as.vector(base_data$X %*% base_data$beta + rnorm(base_data$n, sd = 5))\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n # Should complete successfully\n expect_true(is.finite(result$elbo[length(result$elbo)]))\n expect_true(result$sigma2 > 0)\n})\n\ntest_that(\"susie_auto handles no signal (pure noise)\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 142)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 4, verbose = FALSE)\n\n # Should complete successfully\n expect_true(is.finite(result$elbo[length(result$elbo)]))\n\n # All effects should have small prior variance\n expect_true(all(result$V < 0.5))\n\n # No credible sets should be found\n expect_true(is.null(result$sets) || length(result$sets$cs) == 0)\n})\n\ntest_that(\"susie_auto handles L_init = 1 (minimum)\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 143)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 8, verbose = FALSE)\n\n # Should complete successfully\n expect_true(is.finite(result$elbo[length(result$elbo)]))\n expect_true(nrow(result$alpha) >= 1)\n})\n\ntest_that(\"susie_auto handles large L_init\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 144)\n\n # Start with large L\n result <- susie_auto(base_data$X, base_data$y, L_init = 10, L_max = 10, verbose = FALSE)\n\n # Should complete successfully with L = 10\n expect_equal(nrow(result$alpha), 10)\n expect_true(is.finite(result$elbo[length(result$elbo)]))\n})\n\n# =============================================================================\n# OUTPUT VALIDATION\n# =============================================================================\n\ntest_that(\"susie_auto returns valid susie object\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 145)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n # Check required fields\n expect_true(\"alpha\" %in% names(result))\n expect_true(\"mu\" %in% names(result))\n expect_true(\"mu2\" %in% names(result))\n expect_true(\"V\" %in% names(result))\n expect_true(\"sigma2\" %in% names(result))\n expect_true(\"elbo\" %in% names(result))\n expect_true(\"niter\" %in% names(result))\n})\n\ntest_that(\"susie_auto PIPs are valid probabilities\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 146)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n # PIPs should be between 0 and 1\n pips <- susie_get_pip(result)\n expect_true(all(pips >= 0))\n expect_true(all(pips <= 1))\n})\n\ntest_that(\"susie_auto fitted values have correct dimensions\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 147)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n # Fitted values should have length n\n expect_equal(length(result$fitted), base_data$n)\n expect_true(all(is.finite(result$fitted)))\n})\n\ntest_that(\"susie_auto predictions work correctly\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 148)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n # Predictions should work\n pred <- predict(result)\n expect_equal(length(pred), base_data$n)\n expect_true(all(is.finite(pred)))\n})\n\ntest_that(\"susie_auto coefficients can be extracted\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 149)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n # Coefficients should be extractable\n coefs <- coef(result)\n expect_equal(length(coefs), base_data$p + 1) # p coefficients + intercept\n expect_true(all(is.finite(coefs)))\n})\n\n# =============================================================================\n# MATHEMATICAL PROPERTIES\n# =============================================================================\n\ntest_that(\"susie_auto ELBO is monotonically increasing or stable\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 150)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n # ELBO should be non-decreasing (allowing for small numerical errors)\n elbo_diff <- diff(result$elbo)\n expect_true(all(elbo_diff > -1e-6))\n})\n\ntest_that(\"susie_auto final ELBO is finite\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 151)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n final_elbo <- result$elbo[length(result$elbo)]\n expect_true(is.finite(final_elbo))\n expect_false(is.na(final_elbo))\n})\n\ntest_that(\"susie_auto alpha rows sum to 1\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 152)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n # Each row of alpha should sum to 1\n row_sums <- rowSums(result$alpha)\n expect_true(all(abs(row_sums - 1) < 1e-10))\n})\n\ntest_that(\"susie_auto alpha values are valid probabilities\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 153)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n # Alpha should be in [0, 1]\n expect_true(all(result$alpha >= 0))\n expect_true(all(result$alpha <= 1))\n})\n\ntest_that(\"susie_auto KL divergences are non-negative\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 154)\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n # KL divergences should be non-negative\n expect_true(all(result$KL >= -1e-10)) # Allow small numerical error\n})\n\n# =============================================================================\n# SIGNAL RECOVERY\n# =============================================================================\n\ntest_that(\"susie_auto recovers true causal variables with strong signal\", {\n base_data <- generate_base_data(n = 200, p = 100, k = 3, signal_sd = 1.5, seed = 155)\n base_data$X <- scale(base_data$X)\n # Set specific effect sizes\n base_data$beta[base_data$causal_idx] <- c(1.5, -1.2, 1.8)\n base_data$y <- as.vector(base_data$X %*% base_data$beta + rnorm(base_data$n, sd = 0.5))\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 10, verbose = FALSE)\n\n # Get PIPs\n pips <- susie_get_pip(result)\n\n # Top PIPs should include causal variables\n top_vars <- order(pips, decreasing = TRUE)[1:5]\n expect_true(length(intersect(top_vars, base_data$causal_idx)) >= 2)\n})\n\ntest_that(\"susie_auto has low PIPs for null variables\", {\n base_data <- generate_base_data(n = 200, p = 100, k = 2, signal_sd = 1.9, seed = 156)\n base_data$X <- scale(base_data$X)\n base_data$y <- as.vector(base_data$X %*% base_data$beta + rnorm(base_data$n, sd = 0.5))\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 10, verbose = FALSE)\n\n # Get PIPs\n pips <- susie_get_pip(result)\n\n # Most PIPs should be low for null variables\n null_pips <- pips[setdiff(1:base_data$p, base_data$causal_idx)]\n expect_true(median(null_pips) < 0.2)\n})\n\ntest_that(\"susie_auto identifies credible sets for strong effects\", {\n base_data <- generate_base_data(n = 200, p = 100, k = 3, signal_sd = 2, seed = 157)\n base_data$X <- scale(base_data$X)\n base_data$y <- as.vector(base_data$X %*% base_data$beta + rnorm(base_data$n, sd = 0.5))\n\n result <- susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 10, verbose = FALSE)\n\n # Should find credible sets\n cs <- susie_get_cs(result)\n\n if (!is.null(cs) && length(cs$cs) > 0) {\n # At least one CS should be found\n expect_true(length(cs$cs) >= 1)\n\n # CSs should have reasonable coverage\n expect_true(all(cs$coverage >= 0.9))\n }\n})\n\n# =============================================================================\n# VERBOSE OUTPUT\n# =============================================================================\n\ntest_that(\"susie_auto verbose mode produces output\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 158)\n\n # Capture messages\n expect_message(\n susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 4, verbose = TRUE),\n \"Trying L=\"\n )\n})\n\ntest_that(\"susie_auto verbose shows correct L progression\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 5, signal_sd = 1, seed = 159)\n\n # Capture messages and check for L progression\n msgs <- capture_messages(\n susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 4, verbose = TRUE)\n )\n\n # Should see \"Trying L=\" messages\n expect_true(any(grepl(\"Trying L=\", msgs)))\n})\n\n# =============================================================================\n# CONSISTENCY\n# =============================================================================\n\ntest_that(\"susie_auto gives consistent results with same seed\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 199)\n\n set.seed(200)\n result1 <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n set.seed(200)\n result2 <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 4, verbose = FALSE)\n\n # Results should be identical\n expect_equal(result1$alpha, result2$alpha)\n expect_equal(result1$elbo, result2$elbo)\n})\n\ntest_that(\"susie_auto with different L_init converges to similar solutions\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 2, signal_sd = 1.75, seed = 201)\n\n result_L1 <- susie_auto(base_data$X, base_data$y, L_init = 1, L_max = 8, verbose = FALSE)\n result_L2 <- susie_auto(base_data$X, base_data$y, L_init = 2, L_max = 8, verbose = FALSE)\n\n # PIPs should be similar\n pips1 <- susie_get_pip(result_L1)\n pips2 <- susie_get_pip(result_L2)\n\n # Correlation of PIPs should be high\n expect_true(cor(pips1, pips2) > 0.9)\n})\n" }, { "path": "tests/testthat/test_susie_constructors.R", "content": "context(\"SuSiE Data Constructors\")\n\n# =============================================================================\n# INDIVIDUAL DATA CONSTRUCTOR - Basic Functionality\n# =============================================================================\n\ntest_that(\"individual_data_constructor returns correct structure\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 1)\n\n result <- individual_data_constructor(base_data$X, base_data$y)\n\n expect_type(result, \"list\")\n expect_true(\"data\" %in% names(result))\n expect_true(\"params\" %in% names(result))\n expect_s3_class(result$data, \"individual\")\n})\n\ntest_that(\"individual_data_constructor creates data object with correct fields\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 2)\n\n result <- individual_data_constructor(base_data$X, base_data$y)\n\n expect_true(\"X\" %in% names(result$data))\n expect_true(\"y\" %in% names(result$data))\n expect_true(\"n\" %in% names(result$data))\n expect_true(\"p\" %in% names(result$data))\n expect_true(\"mean_y\" %in% names(result$data))\n})\n\ntest_that(\"individual_data_constructor sets correct dimensions\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 3)\n\n result <- individual_data_constructor(base_data$X, base_data$y)\n\n expect_equal(result$data$n, base_data$n)\n expect_equal(result$data$p, base_data$p)\n expect_equal(dim(result$data$X), c(base_data$n, base_data$p))\n expect_length(result$data$y, base_data$n)\n})\n\ntest_that(\"individual_data_constructor sets X attributes\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 4)\n\n result <- individual_data_constructor(base_data$X, base_data$y, standardize = TRUE, intercept = TRUE)\n\n expect_true(!is.null(attr(result$data$X, \"scaled:center\")))\n expect_true(!is.null(attr(result$data$X, \"scaled:scale\")))\n expect_true(!is.null(attr(result$data$X, \"d\")))\n})\n\n# =============================================================================\n# INDIVIDUAL DATA CONSTRUCTOR - Input Validation\n# =============================================================================\n\ntest_that(\"individual_data_constructor rejects non-matrix X\", {\n expect_error(\n individual_data_constructor(as.data.frame(matrix(1:10, 5, 2)), rnorm(5)),\n \"Input X must be a double-precision matrix\"\n )\n})\n\ntest_that(\"individual_data_constructor rejects X with NAs\", {\n base_data <- generate_base_data(n = 10, p = 10, k = 0, seed = 5)\n base_data$X[5, 5] <- NA\n\n expect_error(\n individual_data_constructor(base_data$X, base_data$y),\n \"X contains NA values\"\n )\n})\n\ntest_that(\"individual_data_constructor rejects y with NAs when na.rm=FALSE\", {\n base_data <- generate_base_data(n = 10, p = 10, k = 0, seed = 6)\n base_data$y[5] <- NA\n\n expect_error(\n individual_data_constructor(base_data$X, base_data$y, na.rm = FALSE),\n \"Input y must not contain missing values\"\n )\n})\n\ntest_that(\"individual_data_constructor handles y with NAs when na.rm=TRUE\", {\n base_data <- generate_base_data(n = 10, p = 10, k = 0, seed = 7)\n base_data$y[5] <- NA\n\n result <- individual_data_constructor(base_data$X, base_data$y, na.rm = TRUE)\n\n expect_equal(result$data$n, 9)\n expect_equal(nrow(result$data$X), 9)\n expect_length(result$data$y, 9)\n expect_false(anyNA(result$data$y))\n})\n\ntest_that(\"individual_data_constructor computes residual_variance_lowerbound after NA removal\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 7.25)\n base_data$y[1] <- NA\n\n result <- individual_data_constructor(base_data$X, base_data$y, na.rm = TRUE)\n\n # Verify residual_variance_lowerbound is computed correctly (not NA)\n expect_true(is.finite(result$params$residual_variance_lowerbound))\n expect_true(result$params$residual_variance_lowerbound > 0)\n\n # Verify it equals var(y_clean) / 1e4 where y_clean has NA removed\n y_clean <- base_data$y[!is.na(base_data$y)]\n expected_lowerbound <- var(y_clean) / 1e4\n expect_equal(result$params$residual_variance_lowerbound, expected_lowerbound)\n})\n\ntest_that(\"individual_data_constructor allows custom residual_variance_lowerbound with NA in y\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 7.5)\n base_data$y[1] <- NA\n\n custom_lowerbound <- 0.001\n result <- individual_data_constructor(\n base_data$X, base_data$y,\n na.rm = TRUE,\n residual_variance_lowerbound = custom_lowerbound\n )\n\n expect_equal(result$params$residual_variance_lowerbound, custom_lowerbound)\n})\n\ntest_that(\"individual_data_constructor handles multiple NAs in y with na.rm=TRUE\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 7.75)\n # Set multiple NAs at different positions\n\n base_data$y[c(1, 25, 50, 75, 100)] <- NA\n\n result <- individual_data_constructor(base_data$X, base_data$y, na.rm = TRUE)\n\n expect_equal(result$data$n, 95)\n expect_equal(nrow(result$data$X), 95)\n expect_length(result$data$y, 95)\n expect_false(anyNA(result$data$y))\n expect_true(is.finite(result$params$residual_variance_lowerbound))\n})\n\n# =============================================================================\n# INDIVIDUAL DATA CONSTRUCTOR - Centering and Scaling\n# =============================================================================\n\ntest_that(\"individual_data_constructor centers y when intercept=TRUE\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 8)\n base_data$y <- base_data$y + 10\n\n result <- individual_data_constructor(base_data$X, base_data$y, intercept = TRUE)\n\n expect_equal(mean(result$data$y), 0, tolerance = 1e-10)\n expect_true(result$data$mean_y != 0)\n})\n\ntest_that(\"individual_data_constructor does not center y when intercept=FALSE\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 9)\n base_data$y <- base_data$y + 10\n\n result <- individual_data_constructor(base_data$X, base_data$y, intercept = FALSE)\n\n expect_true(abs(mean(result$data$y) - 10) < 1)\n})\n\ntest_that(\"individual_data_constructor standardizes X when requested\", {\n set.seed(10)\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = NULL)\n # Create X with different mean and sd\n base_data$X <- matrix(rnorm(base_data$n * base_data$p, mean = 5, sd = 3), base_data$n, base_data$p)\n\n result <- individual_data_constructor(base_data$X, base_data$y, standardize = TRUE, intercept = TRUE)\n\n cm <- attr(result$data$X, \"scaled:center\")\n csd <- attr(result$data$X, \"scaled:scale\")\n\n expect_length(cm, base_data$p)\n expect_length(csd, base_data$p)\n expect_true(all(csd > 0))\n})\n\n# =============================================================================\n# INDIVIDUAL DATA CONSTRUCTOR - Prior Weights\n# =============================================================================\n\ntest_that(\"individual_data_constructor creates uniform prior weights by default\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 11)\n\n result <- individual_data_constructor(base_data$X, base_data$y)\n\n expect_length(result$params$prior_weights, base_data$p)\n expect_equal(sum(result$params$prior_weights), 1, tolerance = 1e-10)\n expect_true(all(abs(result$params$prior_weights - 1/base_data$p) < 1e-10))\n})\n\ntest_that(\"individual_data_constructor normalizes custom prior weights\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 12)\n custom_weights <- rep(2, base_data$p)\n\n result <- individual_data_constructor(base_data$X, base_data$y, prior_weights = custom_weights)\n\n expect_equal(sum(result$params$prior_weights), 1, tolerance = 1e-10)\n})\n\ntest_that(\"individual_data_constructor rejects wrong length prior weights\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 13)\n\n expect_error(\n individual_data_constructor(base_data$X, base_data$y, prior_weights = rep(1, 40)),\n \"Prior weights must have length p\"\n )\n})\n\ntest_that(\"individual_data_constructor rejects all-zero prior weights\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 14)\n\n expect_error(\n individual_data_constructor(base_data$X, base_data$y, prior_weights = rep(0, base_data$p)),\n \"Prior weight should be greater than 0\"\n )\n})\n\n# =============================================================================\n# INDIVIDUAL DATA CONSTRUCTOR - Null Weight\n# =============================================================================\n\ntest_that(\"individual_data_constructor handles null_weight=0\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 15)\n\n result <- individual_data_constructor(base_data$X, base_data$y, null_weight = 0)\n\n expect_equal(result$data$p, base_data$p)\n expect_equal(ncol(result$data$X), base_data$p)\n expect_null(result$params$null_weight)\n})\n\ntest_that(\"individual_data_constructor adds null column when null_weight > 0\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 16)\n\n result <- individual_data_constructor(base_data$X, base_data$y, null_weight = 0.1)\n\n expect_equal(result$data$p, base_data$p + 1)\n expect_equal(ncol(result$data$X), base_data$p + 1)\n expect_equal(result$params$null_weight, 0.1)\n expect_true(all(result$data$X[, base_data$p + 1] == 0))\n})\n\ntest_that(\"individual_data_constructor adjusts prior weights with null_weight\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 17)\n\n result <- individual_data_constructor(base_data$X, base_data$y, null_weight = 0.2)\n\n expect_length(result$params$prior_weights, base_data$p + 1)\n expect_equal(sum(result$params$prior_weights), 1, tolerance = 1e-10)\n expect_equal(result$params$prior_weights[base_data$p + 1], 0.2, tolerance = 1e-10)\n})\n\ntest_that(\"individual_data_constructor adjusts custom prior weights with null_weight\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 17.5)\n\n # Create custom prior weights (not uniform)\n custom_weights <- runif(base_data$p, 0.5, 2)\n custom_weights <- custom_weights / sum(custom_weights) # Normalize to sum to 1\n\n result <- individual_data_constructor(base_data$X, base_data$y,\n prior_weights = custom_weights,\n null_weight = 0.3)\n\n # Check that we have p+1 weights (original p + null column)\n expect_length(result$params$prior_weights, base_data$p + 1)\n\n # Check that all weights sum to 1\n expect_equal(sum(result$params$prior_weights), 1, tolerance = 1e-10)\n\n # Check that the null weight is exactly 0.3\n expect_equal(result$params$prior_weights[base_data$p + 1], 0.3, tolerance = 1e-10)\n\n # Check that the other weights were scaled by (1 - null_weight) = 0.7\n # i.e., result$params$prior_weights[1:p] should equal custom_weights * 0.7\n expect_equal(result$params$prior_weights[1:base_data$p],\n custom_weights * 0.7,\n tolerance = 1e-10)\n\n # Verify that the sum of the first p weights is (1 - 0.3) = 0.7\n expect_equal(sum(result$params$prior_weights[1:base_data$p]), 0.7, tolerance = 1e-10)\n})\n\ntest_that(\"individual_data_constructor rejects invalid null_weight\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 18)\n\n expect_error(\n individual_data_constructor(base_data$X, base_data$y, null_weight = -0.1),\n \"Null weight must be between 0 and 1\"\n )\n\n expect_error(\n individual_data_constructor(base_data$X, base_data$y, null_weight = 1.5),\n \"Null weight must be between 0 and 1\"\n )\n\n expect_error(\n individual_data_constructor(base_data$X, base_data$y, null_weight = \"invalid\"),\n \"Null weight must be numeric\"\n )\n})\n\n# =============================================================================\n# INDIVIDUAL DATA CONSTRUCTOR - Rfast Warning\n# =============================================================================\n\ntest_that(\"individual_data_constructor warns about Rfast when p > 1000 and Rfast not available\", {\n # Only test the warning if Rfast is not installed\n skip_if(requireNamespace(\"Rfast\", quietly = TRUE),\n \"Rfast is installed, skipping warning test\")\n\n base_data <- generate_base_data(n = 100, p = 1001, k = 0, seed = 18.5)\n\n expect_message(\n result <- individual_data_constructor(base_data$X, base_data$y),\n \"consider installing the Rfast package\",\n fixed = FALSE\n )\n\n # Verify constructor still works despite the warning\n expect_equal(result$data$p, 1001)\n})\n\ntest_that(\"individual_data_constructor does not warn when p <= 1000\", {\n # This should never warn regardless of Rfast availability\n base_data <- generate_base_data(n = 100, p = 1000, k = 0, seed = 18.75)\n result <- individual_data_constructor(base_data$X, base_data$y)\n\n expect_equal(result$data$p, 1000)\n})\n\n# =============================================================================\n# INDIVIDUAL DATA CONSTRUCTOR - Parameters\n# =============================================================================\n\ntest_that(\"individual_data_constructor stores all parameters\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 19)\n\n result <- individual_data_constructor(\n base_data$X, base_data$y,\n L = 5,\n estimate_residual_variance = TRUE,\n estimate_prior_variance = TRUE,\n max_iter = 50,\n tol = 1e-4\n )\n\n expect_equal(result$params$L, 5)\n expect_true(result$params$estimate_residual_variance)\n expect_true(result$params$estimate_prior_variance)\n expect_equal(result$params$max_iter, 50)\n expect_equal(result$params$tol, 1e-4)\n})\n\n# =============================================================================\n# INDIVIDUAL DATA CONSTRUCTOR - Incompatible Parameter Combinations\n# =============================================================================\n\ntest_that(\"individual_data_constructor rejects unmappable_effects with NIG\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 19.5)\n\n expect_error(\n individual_data_constructor(\n base_data$X, base_data$y,\n unmappable_effects = \"inf\",\n estimate_residual_method = \"NIG\"\n ),\n \"The combination of unmappable_effects = 'inf' with estimate_residual_method = 'NIG' is not supported\"\n )\n\n expect_error(\n individual_data_constructor(\n base_data$X, base_data$y,\n unmappable_effects = \"ash\",\n estimate_residual_method = \"NIG\"\n ),\n \"The combination of unmappable_effects = 'ash' with estimate_residual_method = 'NIG' is not supported\"\n )\n})\n\ntest_that(\"individual_data_constructor rejects unmappable_effects='ash' with estimate_prior_method='EM'\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 19.75)\n\n expect_error(\n individual_data_constructor(\n base_data$X, base_data$y,\n unmappable_effects = \"ash\",\n estimate_prior_method = \"EM\"\n ),\n \"The combination of unmappable_effects = 'ash' with estimate_prior_method = 'EM' is not supported\"\n )\n})\n\n# =============================================================================\n# SUFFICIENT STATISTICS CONSTRUCTOR - Basic Functionality\n# =============================================================================\n\ntest_that(\"sufficient_stats_constructor returns correct structure\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 20)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n result <- sufficient_stats_constructor(Xty = Xty, yty = yty, n = base_data$n, XtX = XtX)\n\n expect_type(result, \"list\")\n expect_true(\"data\" %in% names(result))\n expect_true(\"params\" %in% names(result))\n expect_s3_class(result$data, \"ss\")\n})\n\ntest_that(\"sufficient_stats_constructor creates data object with correct fields\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 21)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n result <- sufficient_stats_constructor(Xty = Xty, yty = yty, n = base_data$n, XtX = XtX)\n\n expect_true(\"XtX\" %in% names(result$data))\n expect_true(\"Xty\" %in% names(result$data))\n expect_true(\"yty\" %in% names(result$data))\n expect_true(\"n\" %in% names(result$data))\n expect_true(\"p\" %in% names(result$data))\n})\n\ntest_that(\"sufficient_stats_constructor sets correct dimensions\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 22)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n result <- sufficient_stats_constructor(Xty = Xty, yty = yty, n = base_data$n, XtX = XtX)\n\n expect_equal(result$data$n, base_data$n)\n expect_equal(result$data$p, base_data$p)\n expect_equal(dim(result$data$XtX), c(base_data$p, base_data$p))\n expect_length(result$data$Xty, base_data$p)\n})\n\n# =============================================================================\n# SUFFICIENT STATISTICS CONSTRUCTOR - Input Validation\n# =============================================================================\n\ntest_that(\"sufficient_stats_constructor requires n\", {\n XtX <- matrix(1:25, 5, 5)\n Xty <- 1:5\n yty <- 10\n\n expect_error(\n sufficient_stats_constructor(Xty = Xty, yty = yty, XtX = XtX),\n \"n must be provided\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor rejects n <= 1\", {\n XtX <- matrix(1:25, 5, 5)\n Xty <- 1:5\n yty <- 10\n\n expect_error(\n sufficient_stats_constructor(Xty = Xty, yty = yty, n = 1, XtX = XtX),\n \"n must be greater than 1\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor requires all inputs\", {\n XtX <- matrix(1:25, 5, 5)\n Xty <- 1:5\n yty <- 10\n n <- 100\n\n expect_error(\n sufficient_stats_constructor(Xty = Xty, yty = yty, n = n),\n \"XtX, Xty, yty must all be provided\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor rejects non-matrix XtX\", {\n # Test with data.frame (not a matrix)\n XtX_df <- data.frame(matrix(rnorm(25), 5, 5))\n Xty <- rnorm(5)\n yty <- 10\n n <- 100\n\n expect_error(\n sufficient_stats_constructor(Xty = Xty, yty = yty, n = n, XtX = XtX_df),\n \"XtX must be a numeric dense or sparse matrix\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor rejects integer matrix XtX\", {\n # Test with integer matrix (not double)\n XtX_int <- matrix(1L:25L, 5, 5)\n Xty <- 1:5\n yty <- 10\n n <- 100\n\n expect_error(\n sufficient_stats_constructor(Xty = Xty, yty = yty, n = n, XtX = XtX_int),\n \"XtX must be a numeric dense or sparse matrix\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor rejects non-numeric XtX\", {\n # Test with character matrix\n XtX_char <- matrix(as.character(1:25), 5, 5)\n Xty <- 1:5\n yty <- 10\n n <- 100\n\n expect_error(\n sufficient_stats_constructor(Xty = Xty, yty = yty, n = n, XtX = XtX_char),\n \"XtX must be a numeric dense or sparse matrix\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor rejects vector XtX\", {\n # Test with vector (not a matrix)\n XtX_vec <- rnorm(25)\n Xty <- 1:5\n yty <- 10\n n <- 100\n\n expect_error(\n sufficient_stats_constructor(Xty = Xty, yty = yty, n = n, XtX = XtX_vec),\n \"XtX must be a numeric dense or sparse matrix\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor rejects dimension mismatch\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 23)\n XtX <- crossprod(base_data$X)\n Xty <- rnorm(10)\n yty <- 100\n\n expect_error(\n sufficient_stats_constructor(Xty = Xty, yty = yty, n = base_data$n, XtX = XtX),\n \"does not agree with expected\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor rejects non-symmetric XtX\", {\n XtX <- matrix(1:25, 5, 5)\n XtX[1, 2] <- 100\n Xty <- 1:5\n yty <- 10\n n <- 100\n\n expect_message(\n result <- sufficient_stats_constructor(Xty = Xty, yty = yty, n = n, XtX = XtX),\n \"XtX not symmetric\"\n )\n\n expect_true(isSymmetric(result$data$XtX))\n})\n\ntest_that(\"sufficient_stats_constructor rejects XtX with NAs\", {\n XtX <- matrix(rnorm(25), 5, 5)\n XtX[1, 1] <- NA\n Xty <- 1:5\n yty <- 10\n n <- 100\n\n expect_error(\n sufficient_stats_constructor(Xty = Xty, yty = yty, n = n, XtX = XtX),\n \"Input XtX matrix contains NAs\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor handles Xty with NAs\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 24)\n XtX <- crossprod(base_data$X)\n Xty <- rnorm(base_data$p)\n Xty[5] <- NA\n yty <- 100\n\n expect_message(\n result <- sufficient_stats_constructor(Xty = Xty, yty = yty, n = base_data$n, XtX = XtX),\n \"NA values in Xty are replaced with 0\"\n )\n\n expect_false(anyNA(result$data$Xty))\n expect_equal(result$data$Xty[5], 0)\n})\n\ntest_that(\"sufficient_stats_constructor rejects infinite Xty\", {\n XtX <- crossprod(matrix(rnorm(100 * 10), 100, 10))\n Xty <- rnorm(10)\n Xty[5] <- Inf\n yty <- 100\n n <- 100\n\n expect_error(\n sufficient_stats_constructor(Xty = Xty, yty = yty, n = n, XtX = XtX),\n \"Input Xty contains infinite values\"\n )\n})\n\n# =============================================================================\n# SUFFICIENT STATISTICS CONSTRUCTOR - Standardization\n# =============================================================================\n\ntest_that(\"sufficient_stats_constructor standardizes when requested\", {\n set.seed(25)\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = NULL)\n base_data$X <- matrix(rnorm(base_data$n * base_data$p, mean = 5, sd = 3), base_data$n, base_data$p)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n result <- sufficient_stats_constructor(Xty = Xty, yty = yty, n = base_data$n, XtX = XtX, standardize = TRUE)\n\n d_attr <- attr(result$data$XtX, \"d\")\n expect_length(d_attr, base_data$p)\n expect_true(all(is.finite(d_attr)))\n})\n\ntest_that(\"sufficient_stats_constructor does not standardize when standardize=FALSE\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 26)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n result <- sufficient_stats_constructor(Xty = Xty, yty = yty, n = base_data$n, XtX = XtX, standardize = FALSE)\n\n csd_attr <- attr(result$data$XtX, \"scaled:scale\")\n expect_true(all(csd_attr == 1))\n})\n\n# =============================================================================\n# SUFFICIENT STATISTICS CONSTRUCTOR - Rfast Warning\n# =============================================================================\n\ntest_that(\"sufficient_stats_constructor warns about Rfast when p > 1000 and Rfast not available\", {\n # Only test the warning if Rfast is not installed\n skip_if(requireNamespace(\"Rfast\", quietly = TRUE),\n \"Rfast is installed, skipping warning test\")\n\n base_data <- generate_base_data(n = 100, p = 1001, k = 0, seed = 27.5)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n expect_message(\n result <- sufficient_stats_constructor(Xty = Xty, yty = yty, n = base_data$n, XtX = XtX),\n \"consider installing the Rfast package\",\n fixed = FALSE\n )\n\n # Verify constructor still works despite the warning\n expect_equal(result$data$p, 1001)\n})\n\ntest_that(\"sufficient_stats_constructor does not warn when p <= 1000\", {\n # This should never warn regardless of Rfast availability\n base_data <- generate_base_data(n = 100, p = 1000, k = 0, seed = 27.6)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n result <- sufficient_stats_constructor(Xty = Xty, yty = yty, n = base_data$n, XtX = XtX)\n\n # Just verify it worked\n expect_equal(result$data$p, 1000)\n})\n\n# =============================================================================\n# SUFFICIENT STATISTICS CONSTRUCTOR - MAF Filtering\n# =============================================================================\n\ntest_that(\"sufficient_stats_constructor applies MAF filter\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 27)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n maf <- runif(base_data$p, 0, 0.5)\n\n result <- sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n maf = maf, maf_thresh = 0.1\n )\n\n n_filtered <- sum(maf > 0.1)\n expect_equal(result$data$p, n_filtered)\n expect_equal(nrow(result$data$XtX), n_filtered)\n expect_length(result$data$Xty, n_filtered)\n})\n\ntest_that(\"sufficient_stats_constructor rejects MAF with incorrect length\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 27.7)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # MAF vector with wrong length (p - 10 instead of p)\n maf_wrong_length <- runif(base_data$p - 10, 0, 0.5)\n\n expect_error(\n sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n maf = maf_wrong_length, maf_thresh = 0.1\n ),\n \"The length of maf does not agree with expected\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor rejects MAF that is too long\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 27.8)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # MAF vector with wrong length (p + 10 instead of p)\n maf_too_long <- runif(base_data$p + 10, 0, 0.5)\n\n expect_error(\n sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n maf = maf_too_long, maf_thresh = 0.1\n ),\n \"The length of maf does not agree with expected\"\n )\n})\n\n# =============================================================================\n# SUFFICIENT STATISTICS CONSTRUCTOR - Positive Semidefinite Check\n# =============================================================================\n\ntest_that(\"sufficient_stats_constructor rejects non-positive-semidefinite XtX when check_input=TRUE\", {\n # Create a matrix that is NOT positive semidefinite\n # by using a matrix with negative eigenvalues\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 28.9)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # Make XtX non-positive-semidefinite by adding a negative diagonal\n # This creates negative eigenvalues\n XtX[1, 1] <- -10\n\n expect_error(\n sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n check_input = TRUE\n ),\n \"XtX is not a positive semidefinite matrix\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor accepts positive-semidefinite XtX when check_input=TRUE\", {\n # Create a valid positive semidefinite matrix\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 29)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # This should work without error\n result <- sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n check_input = TRUE\n )\n\n expect_equal(result$data$p, base_data$p)\n})\n\ntest_that(\"sufficient_stats_constructor warns when Xty not in column space of XtX\", {\n # Create a rank-deficient matrix with exact zero eigenvalues\n p <- 5\n n <- 100\n\n # Diagonal matrix with rank 3 (2 zero eigenvalues)\n XtX <- diag(c(1, 1, 1, 0, 0))\n\n # Create Xty with non-zero components in the null space (positions 4 and 5)\n # This Xty cannot be written as X'y for any y\n Xty <- c(1, 1, 1, 10, 10) # Last two components are in null space\n\n yty <- 100\n\n expect_message(\n result <- sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = n, XtX = XtX,\n check_input = TRUE\n ),\n \"Xty does not lie in the space of the non-zero eigenvectors\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor does not warn when Xty in column space\", {\n # Create valid XtX and Xty from same data\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 29.3)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # This should work without warning since Xty = X'y by construction\n result <- sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n check_input = TRUE\n )\n\n # Just verify it worked\n expect_equal(result$data$p, base_data$p)\n})\n\n# =============================================================================\n# SUFFICIENT STATISTICS CONSTRUCTOR - Null Weight\n# =============================================================================\n\ntest_that(\"sufficient_stats_constructor adds null column when null_weight > 0\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 28)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n result <- sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n null_weight = 0.1,\n X_colmeans = rep(0, base_data$p)\n )\n\n expect_equal(result$data$p, base_data$p + 1)\n expect_equal(nrow(result$data$XtX), base_data$p + 1)\n expect_length(result$data$Xty, base_data$p + 1)\n expect_equal(result$params$null_weight, 0.1)\n})\n\ntest_that(\"sufficient_stats_constructor adjusts custom prior weights with null_weight\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 28.5)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # Create custom prior weights (not uniform)\n custom_weights <- runif(base_data$p, 0.5, 2)\n custom_weights <- custom_weights / sum(custom_weights) # Normalize to sum to 1\n\n result <- sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n prior_weights = custom_weights,\n null_weight = 0.25,\n X_colmeans = rep(0, base_data$p)\n )\n\n # Check that we have p+1 weights (original p + null column)\n expect_length(result$params$prior_weights, base_data$p + 1)\n\n # Check that all weights sum to 1\n expect_equal(sum(result$params$prior_weights), 1, tolerance = 1e-10)\n\n # Check that the null weight is exactly 0.25\n expect_equal(result$params$prior_weights[base_data$p + 1], 0.25, tolerance = 1e-10)\n\n # Check that the other weights were scaled by (1 - null_weight) = 0.75\n expect_equal(result$params$prior_weights[1:base_data$p],\n custom_weights * 0.75,\n tolerance = 1e-10)\n\n # Verify that the sum of the first p weights is (1 - 0.25) = 0.75\n expect_equal(sum(result$params$prior_weights[1:base_data$p]), 0.75, tolerance = 1e-10)\n})\n\ntest_that(\"sufficient_stats_constructor rejects non-numeric null_weight\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 28.6)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n expect_error(\n sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n null_weight = \"invalid\"\n ),\n \"Null weight must be numeric\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor rejects negative null_weight\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 28.7)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n expect_error(\n sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n null_weight = -0.1\n ),\n \"Null weight must be between 0 and 1\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor rejects null_weight >= 1\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 28.8)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # Test null_weight = 1\n expect_error(\n sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n null_weight = 1\n ),\n \"Null weight must be between 0 and 1\"\n )\n\n # Test null_weight > 1\n expect_error(\n sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n null_weight = 1.5\n ),\n \"Null weight must be between 0 and 1\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor replicates scalar X_colmeans when null_weight is set\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 28.9)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # Provide scalar X_colmeans which should be replicated to length p\n result <- sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n null_weight = 0.1,\n X_colmeans = 0 # Scalar value\n )\n\n # Should work without error\n expect_equal(result$data$p, base_data$p + 1) # p + 1 due to null column\n})\n\ntest_that(\"sufficient_stats_constructor rejects wrong length X_colmeans with null_weight\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 29.0)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # Provide X_colmeans with wrong length\n expect_error(\n sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n null_weight = 0.1,\n X_colmeans = rep(0, base_data$p - 10) # Wrong length\n ),\n \"The length of X_colmeans does not agree with number of variables\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor replicates scalar X_colmeans without null_weight\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 29.1)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # Provide scalar X_colmeans which should be replicated to length p\n result <- sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n X_colmeans = 0 # Scalar value\n )\n\n # Should work without error\n expect_equal(result$data$p, base_data$p)\n})\n\ntest_that(\"sufficient_stats_constructor rejects wrong length X_colmeans without null_weight\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 29.2)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # Provide X_colmeans with wrong length\n expect_error(\n sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n X_colmeans = rep(0, base_data$p - 10) # Wrong length\n ),\n \"X_colmeans.*does not match number of variables\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor rejects wrong length prior_weights\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 29.3)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # Provide prior_weights with wrong length\n expect_error(\n sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n prior_weights = rep(1, base_data$p - 10) # Wrong length\n ),\n \"Prior weights must have length p\"\n )\n})\n\ntest_that(\"sufficient_stats_constructor rejects all-zero prior_weights\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 29.4)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n # Provide all-zero prior_weights\n expect_error(\n sufficient_stats_constructor(\n Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n prior_weights = rep(0, base_data$p) # All zeros\n ),\n \"Prior weight should be greater than 0 for at least one variable\"\n )\n})\n\n# =============================================================================\n# SUFFICIENT STATISTICS CONSTRUCTOR - Method Restrictions\n# =============================================================================\n\ntest_that(\"sufficient_stats_constructor accepts NIG\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 29)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- 100\n\n result <- sufficient_stats_constructor(Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n estimate_residual_method = \"NIG\")\n expect_true(result$params$use_NIG)\n expect_equal(result$params$estimate_prior_method, \"EM\")\n})\n\ntest_that(\"sufficient_stats_constructor accepts unmappable_effects='ash'\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 30)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- 100\n\n # ash is now supported for sufficient statistics via mr.ash.rss\n result <- sufficient_stats_constructor(Xty = Xty, yty = yty, n = base_data$n, XtX = XtX,\n unmappable_effects = \"ash\")\n expect_true(inherits(result$data, \"ss\"))\n expect_equal(result$params$unmappable_effects, \"ash\")\n})\n\n# =============================================================================\n# RSS LAMBDA CONSTRUCTOR - Basic Functionality\n# =============================================================================\n\ntest_that(\"rss_lambda_constructor returns correct structure\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n result <- rss_lambda_constructor(z, R, lambda = 0.5)\n\n expect_type(result, \"list\")\n expect_true(\"data\" %in% names(result))\n expect_true(\"params\" %in% names(result))\n expect_s3_class(result$data, \"rss_lambda\")\n})\n\ntest_that(\"rss_lambda_constructor creates data object with correct fields\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n result <- rss_lambda_constructor(z, R, lambda = 0.5)\n\n expect_true(\"z\" %in% names(result$data))\n expect_true(\"R\" %in% names(result$data))\n expect_true(\"lambda\" %in% names(result$data))\n expect_true(\"eigen_R\" %in% names(result$data))\n expect_true(\"Vtz\" %in% names(result$data))\n expect_true(\"n\" %in% names(result$data))\n expect_true(\"p\" %in% names(result$data))\n})\n\ntest_that(\"rss_lambda_constructor stores n and dimensions correctly\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n # When n is not provided, data$n is NA_integer_ (not silently set to p)\n result <- rss_lambda_constructor(z, R, lambda = 0.5)\n expect_true(is.na(result$data$n))\n expect_equal(result$data$p, p)\n expect_length(result$data$z, p)\n expect_equal(dim(result$data$R), c(p, p))\n\n # When n is provided, data$n stores the GWAS sample size as supplied\n result_n <- rss_lambda_constructor(z, R, lambda = 0.5, n = 1000)\n expect_equal(result_n$data$n, 1000L)\n})\n\ntest_that(\"rss_lambda_constructor computes eigen decomposition\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n result <- rss_lambda_constructor(z, R, lambda = 0.5)\n\n expect_true(\"eigen_R\" %in% names(result$data))\n expect_true(\"values\" %in% names(result$data$eigen_R))\n expect_true(\"vectors\" %in% names(result$data$eigen_R))\n expect_length(result$data$eigen_R$values, p)\n})\n\ntest_that(\"rss_lambda_constructor computes Vtz\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n result <- rss_lambda_constructor(z, R, lambda = 0.5)\n\n expect_true(\"Vtz\" %in% names(result$data))\n expect_length(result$data$Vtz, p)\n})\n\n# =============================================================================\n# RSS LAMBDA CONSTRUCTOR - Input Validation\n# =============================================================================\n\ntest_that(\"rss_lambda_constructor rejects dimension mismatch\", {\n z <- rnorm(50)\n R <- diag(40)\n\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5),\n \"does not agree with expected\"\n )\n})\n\ntest_that(\"rss_lambda_constructor rejects non-symmetric R\", {\n R <- matrix(rnorm(25), 5, 5)\n z <- rnorm(5)\n\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5),\n \"not a positive semidefinite matrix|R is not a symmetric matrix\"\n )\n})\n\ntest_that(\"rss_lambda_constructor accepts R with mismatched rownames and colnames\", {\n p <- 10\n z <- rnorm(p)\n R <- diag(p)\n rownames(R) <- paste0(\"row_\", 1:p)\n colnames(R) <- paste0(\"col_\", 1:p)\n\n # Should succeed despite mismatched dimnames (values are symmetric)\n result <- rss_lambda_constructor(z, R, lambda = 0.5)\n expect_equal(result$data$p, p)\n expect_s3_class(result$data, \"rss_lambda\")\n})\n\ntest_that(\"rss_lambda_constructor accepts R with matching rownames and colnames\", {\n p <- 10\n z <- rnorm(p)\n R <- diag(p)\n rownames(R) <- paste0(\"SNP\", 1:p)\n colnames(R) <- paste0(\"SNP\", 1:p)\n\n result <- rss_lambda_constructor(z, R, lambda = 0.5)\n expect_equal(result$data$p, p)\n expect_s3_class(result$data, \"rss_lambda\")\n})\n\ntest_that(\"rss_lambda_constructor accepts R with no dimnames\", {\n p <- 10\n z <- rnorm(p)\n R <- diag(p)\n\n result <- rss_lambda_constructor(z, R, lambda = 0.5)\n expect_equal(result$data$p, p)\n expect_s3_class(result$data, \"rss_lambda\")\n})\n\ntest_that(\"rss_lambda_constructor rejects integer matrix R\", {\n R <- matrix(1:25, 5, 5)\n R <- R + t(R) # Make it symmetric\n mode(R) <- \"integer\" # Convert to integer type\n z <- rnorm(5)\n\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5),\n \"Input R must be a double-precision matrix or a sparse matrix\"\n )\n})\n\ntest_that(\"rss_lambda_constructor rejects non-positive-semidefinite R when check_R=TRUE\", {\n # Create a matrix with negative eigenvalue\n R <- diag(5)\n R[1, 1] <- -1 # Force negative eigenvalue\n z <- rnorm(5)\n\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5, check_R = TRUE),\n \"is not a positive semidefinite matrix\"\n )\n})\n\ntest_that(\"rss_lambda_constructor accepts non-PSD R when check_R=FALSE\", {\n # Create a matrix with negative eigenvalue\n R <- diag(5)\n R[1, 1] <- -0.5 # Force negative eigenvalue\n z <- rnorm(5)\n\n # Should succeed with check_R = FALSE (sets negative eigenvalues to 0)\n result <- suppressWarnings(\n rss_lambda_constructor(z, R, lambda = 0.5, check_R = FALSE)\n )\n expect_true(!is.null(result))\n})\n\ntest_that(\"rss_lambda_constructor warns when z not in column space of R\", {\n # Create R with rank < p (has null space)\n p <- 5\n R <- diag(c(1, 1, 1, 0, 0)) # Rank 3, nullspace dimension 2\n\n # Create z with components in null space (positions 4 and 5)\n z <- c(0.1, 0.1, 0.1, 10, 10) # Large components in null directions\n\n expect_message(\n rss_lambda_constructor(z, R, lambda = 0.5, check_z = TRUE),\n \"Input z does not lie in the space of non-zero eigenvectors of R\"\n )\n})\n\ntest_that(\"rss_lambda_constructor messages when z in column space of R\", {\n # Create R with rank < p\n p <- 5\n R <- diag(c(1, 1, 1, 0, 0)) # Rank 3\n\n # Create z only in column space (zero components in null directions)\n z <- c(1, 2, 3, 0, 0)\n\n expect_message(\n suppressWarnings(\n rss_lambda_constructor(z, R, lambda = 0.5, check_z = TRUE)\n ),\n \"Input z is in space spanned by the non-zero eigenvectors of R\"\n )\n})\n\ntest_that(\"rss_lambda_constructor skips z check when check_z=FALSE\", {\n # Create R with rank < p\n p <- 5\n R <- diag(c(1, 1, 1, 0, 0))\n z <- c(0.1, 0.1, 0.1, 10, 10) # z in null space\n result <- suppressWarnings(\n suppressMessages(\n rss_lambda_constructor(z, R, lambda = 0.5, check_z = FALSE)\n )\n )\n expect_true(!is.null(result))\n})\n\ntest_that(\"rss_lambda_constructor skips z check when R is full rank\", {\n # Full rank R (no null space)\n p <- 5\n R <- diag(p)\n z <- rnorm(p)\n\n # Should not check when length(colspace) == length(z)\n result <- suppressWarnings(\n rss_lambda_constructor(z, R, lambda = 0.5, check_z = TRUE)\n )\n expect_true(!is.null(result))\n})\n\ntest_that(\"rss_lambda_constructor rejects R with NAs\", {\n R <- diag(10)\n R[1, 1] <- NA\n z <- rnorm(10)\n\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5),\n \"R matrix contains missing values\"\n )\n})\n\ntest_that(\"rss_lambda_constructor rejects infinite z\", {\n R <- diag(10)\n z <- rnorm(10)\n z[5] <- Inf\n\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5),\n \"z contains infinite values\"\n )\n})\n\ntest_that(\"rss_lambda_constructor replaces NA z with zero\", {\n R <- diag(10)\n z <- rnorm(10)\n z[5] <- NA\n\n expect_message(\n result <- rss_lambda_constructor(z, R, lambda = 0.5),\n \"NA values in z-scores are replaced with 0\"\n )\n\n expect_false(anyNA(result$data$z))\n expect_equal(result$data$z[5], 0)\n})\n\n# =============================================================================\n# RSS LAMBDA CONSTRUCTOR - Lambda Parameter\n# =============================================================================\n\ntest_that(\"rss_lambda_constructor stores lambda value\", {\n z <- rnorm(50)\n R <- diag(50)\n\n result <- rss_lambda_constructor(z, R, lambda = 0.3)\n\n expect_equal(result$data$lambda, 0.3)\n})\n\ntest_that(\"rss_lambda_constructor estimates lambda when lambda='estimate'\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n R[1:10, 1:10] <- 0\n\n result <- rss_lambda_constructor(z, R, lambda = \"estimate\")\n\n expect_true(is.numeric(result$data$lambda))\n expect_true(result$data$lambda >= 0)\n})\n\ntest_that(\"rss_lambda_constructor sets lambda=0 when R is full rank and lambda='estimate'\", {\n set.seed(123)\n p <- 50\n z <- rnorm(p)\n R <- diag(p) # Full rank - all eigenvalues positive\n\n result <- rss_lambda_constructor(z, R, lambda = \"estimate\")\n\n # When R is full rank, length(colspace) == length(z), so lambda should be set to 0\n expect_equal(result$data$lambda, 0)\n})\n\ntest_that(\"rss_lambda_constructor adjusts residual variance with lambda\", {\n z <- rnorm(50)\n R <- diag(50)\n\n result <- rss_lambda_constructor(z, R, lambda = 0.2, residual_variance = 0.8)\n\n expect_equal(result$params$residual_variance, 0.6)\n})\n\n# =============================================================================\n# RSS LAMBDA CONSTRUCTOR - Method Restrictions\n# =============================================================================\n\ntest_that(\"rss_lambda_constructor rejects non-MLE residual variance methods\", {\n z <- rnorm(50)\n R <- diag(50)\n\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5,\n estimate_residual_method = \"MoM\"),\n \"RSS-lambda supports estimate_residual_method\"\n )\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5,\n estimate_residual_method = \"NIG\"),\n \"RSS-lambda supports estimate_residual_method\"\n )\n})\n\ntest_that(\"rss_lambda_constructor does not expose unmappable_effects\", {\n z <- rnorm(50)\n R <- diag(50)\n\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5, unmappable_effects = \"inf\"),\n \"unused argument\"\n )\n})\n\n# =============================================================================\n# RSS LAMBDA CONSTRUCTOR - MAF Filtering\n# =============================================================================\n\ntest_that(\"rss_lambda_constructor applies MAF filter\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n maf <- runif(p, 0, 0.5)\n\n result <- rss_lambda_constructor(z, R, lambda = 0.5,\n maf = maf, maf_thresh = 0.1)\n\n n_filtered <- sum(maf > 0.1)\n expect_equal(result$data$p, n_filtered)\n expect_length(result$data$z, n_filtered)\n expect_equal(nrow(result$data$R), n_filtered)\n})\n\ntest_that(\"rss_lambda_constructor rejects MAF with wrong length\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n maf <- runif(p - 10) # Wrong length\n\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5, maf = maf),\n \"The length of maf does not agree with expected 50\"\n )\n})\n\n# =============================================================================\n# RSS LAMBDA CONSTRUCTOR - Null Weight\n# =============================================================================\n\ntest_that(\"rss_lambda_constructor adds null column when null_weight > 0\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n result <- rss_lambda_constructor(z, R, lambda = 0.5, null_weight = 0.1)\n\n expect_equal(result$data$p, p + 1)\n expect_length(result$data$z, p + 1)\n expect_equal(nrow(result$data$R), p + 1)\n expect_equal(result$params$null_weight, 0.1)\n expect_equal(result$data$z[p + 1], 0)\n})\n\ntest_that(\"rss_lambda_constructor adjusts custom prior weights with null_weight\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n # Create custom prior weights (not uniform)\n custom_weights <- runif(p, 0.5, 2)\n custom_weights <- custom_weights / sum(custom_weights) # Normalize to sum to 1\n\n result <- rss_lambda_constructor(z, R, lambda = 0.5,\n prior_weights = custom_weights,\n null_weight = 0.15)\n\n # Check that we have p+1 weights (original p + null column)\n expect_length(result$params$prior_weights, p + 1)\n\n # Check that all weights sum to 1\n expect_equal(sum(result$params$prior_weights), 1, tolerance = 1e-10)\n\n # Check that the null weight is exactly 0.15\n expect_equal(result$params$prior_weights[p + 1], 0.15, tolerance = 1e-10)\n\n # Check that the other weights were scaled by (1 - null_weight) = 0.85\n expect_equal(result$params$prior_weights[1:p],\n custom_weights * 0.85,\n tolerance = 1e-10)\n\n # Verify that the sum of the first p weights is (1 - 0.15) = 0.85\n expect_equal(sum(result$params$prior_weights[1:p]), 0.85, tolerance = 1e-10)\n})\n\ntest_that(\"rss_lambda_constructor rejects non-numeric null_weight\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5, null_weight = \"invalid\"),\n \"Null weight must be numeric\"\n )\n})\n\ntest_that(\"rss_lambda_constructor rejects negative null_weight\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5, null_weight = -0.1),\n \"Null weight must be between 0 and 1\"\n )\n})\n\ntest_that(\"rss_lambda_constructor rejects null_weight >= 1\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5, null_weight = 1.0),\n \"Null weight must be between 0 and 1\"\n )\n\n expect_error(\n rss_lambda_constructor(z, R, lambda = 0.5, null_weight = 1.5),\n \"Null weight must be between 0 and 1\"\n )\n})\n\n# =============================================================================\n# SUMMARY STATISTICS CONSTRUCTOR - Routing Logic\n# =============================================================================\n\ntest_that(\"summary_stats_constructor routes to rss_lambda when lambda != 0\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n result <- summary_stats_constructor(z = z, R = R, lambda = 0.5,\n estimate_residual_method = \"MLE\")\n\n expect_s3_class(result$data, \"rss_lambda\")\n expect_equal(result$data$lambda, 0.5)\n})\n\ntest_that(\"summary_stats_constructor routes to sufficient_stats when lambda = 0\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n result <- summary_stats_constructor(z = z, R = R, n = 100, lambda = 0)\n\n expect_s3_class(result$data, \"ss\")\n})\n\n# =============================================================================\n# SUMMARY STATISTICS CONSTRUCTOR - Input Validation\n# =============================================================================\n\ntest_that(\"summary_stats_constructor rejects R with wrong number of rows\", {\n p <- 50\n z <- rnorm(p)\n\n # Create R with wrong number of rows (40 instead of 50)\n R_wrong <- diag(40)\n\n expect_error(\n summary_stats_constructor(z = z, R = R_wrong, n = 100, lambda = 0),\n \"The dimension of R \\\\(40 x 40\\\\) does not agree with expected \\\\(50 x 50\\\\)\"\n )\n})\n\ntest_that(\"summary_stats_constructor rejects n <= 1\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n # Test n = 1\n expect_error(\n summary_stats_constructor(z = z, R = R, n = 1, lambda = 0),\n \"n must be greater than 1\"\n )\n\n # Test n = 0\n expect_error(\n summary_stats_constructor(z = z, R = R, n = 0, lambda = 0),\n \"n must be greater than 1\"\n )\n\n # Test negative n\n expect_error(\n summary_stats_constructor(z = z, R = R, n = -5, lambda = 0),\n \"n must be greater than 1\"\n )\n})\n\ntest_that(\"summary_stats_constructor rejects mismatched bhat and shat lengths\", {\n p <- 50\n R <- diag(p)\n bhat <- rnorm(p)\n shat <- abs(rnorm(p - 5)) # Wrong length\n\n expect_error(\n summary_stats_constructor(bhat = bhat, shat = shat, R = R, n = 100, lambda = 0),\n \"The lengths of bhat and shat do not agree\"\n )\n})\n\ntest_that(\"summary_stats_constructor accepts scalar shat and replicates it\", {\n p <- 50\n R <- diag(p)\n bhat <- rnorm(p)\n shat <- 0.1 # Scalar\n\n # Should replicate shat to length of bhat\n result <- summary_stats_constructor(bhat = bhat, shat = shat, R = R, n = 100, lambda = 0)\n expect_true(!is.null(result))\n})\n\ntest_that(\"summary_stats_constructor rejects missing values in bhat\", {\n p <- 50\n R <- diag(p)\n bhat <- rnorm(p)\n bhat[5] <- NA\n shat <- abs(rnorm(p))\n\n expect_error(\n summary_stats_constructor(bhat = bhat, shat = shat, R = R, n = 100, lambda = 0),\n \"bhat, shat cannot have missing values\"\n )\n})\n\ntest_that(\"summary_stats_constructor rejects missing values in shat\", {\n p <- 50\n R <- diag(p)\n bhat <- rnorm(p)\n shat <- abs(rnorm(p))\n shat[10] <- NA\n\n expect_error(\n summary_stats_constructor(bhat = bhat, shat = shat, R = R, n = 100, lambda = 0),\n \"bhat, shat cannot have missing values\"\n )\n})\n\ntest_that(\"summary_stats_constructor rejects zero elements in shat\", {\n p <- 50\n R <- diag(p)\n bhat <- rnorm(p)\n shat <- abs(rnorm(p))\n shat[5] <- 0\n\n expect_error(\n summary_stats_constructor(bhat = bhat, shat = shat, R = R, n = 100, lambda = 0),\n \"shat cannot have zero or negative elements\"\n )\n})\n\ntest_that(\"summary_stats_constructor rejects negative elements in shat\", {\n p <- 50\n R <- diag(p)\n bhat <- rnorm(p)\n shat <- abs(rnorm(p))\n shat[8] <- -0.5\n\n expect_error(\n summary_stats_constructor(bhat = bhat, shat = shat, R = R, n = 100, lambda = 0),\n \"shat cannot have zero or negative elements\"\n )\n})\n\ntest_that(\"summary_stats_constructor rejects empty z vector\", {\n # When z is empty, length(z) = 0, so p = 0\n # This causes R dimension check to fail before z length check\n z <- numeric(0) # Empty vector\n R <- matrix(0, 0, 0) # Match the expected dimension (0 x 0)\n\n expect_error(\n summary_stats_constructor(z = z, R = R, n = 100, lambda = 0),\n \"Input vector z should have at least one element\"\n )\n})\n\ntest_that(\"summary_stats_constructor rejects MAF with wrong length\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n maf <- runif(p - 10) # Wrong length\n\n expect_error(\n summary_stats_constructor(z = z, R = R, n = 100, lambda = 0, maf = maf),\n \"The length of maf does not agree with expected 50\"\n )\n})\n\ntest_that(\"summary_stats_constructor handles shat and var_y for original scale effects\", {\n p <- 50\n bhat <- rnorm(p)\n shat <- abs(rnorm(p, mean = 0.1, sd = 0.02))\n var_y <- 2.5\n R <- diag(p)\n n <- 100\n\n # This should use the original scale path (lines 649-655)\n result <- summary_stats_constructor(\n bhat = bhat, shat = shat, var_y = var_y, R = R, n = n, lambda = 0\n )\n\n # Verify the result is created successfully\n expect_true(!is.null(result))\n expect_true(!is.null(result$data))\n expect_true(!is.null(result$data$XtX))\n expect_true(!is.null(result$data$Xty))\n expect_true(!is.null(result$data$yty))\n\n # Verify yty matches expected: (n - 1) * var_y\n expect_equal(result$data$yty, (n - 1) * var_y)\n})\n\n# =============================================================================\n# SUMMARY STATISTICS CONSTRUCTOR - Lambda=0 Path\n# =============================================================================\n\ntest_that(\"summary_stats_constructor converts z to sufficient stats\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n n <- 100\n\n result <- summary_stats_constructor(z = z, R = R, n = n, lambda = 0)\n\n expect_true(\"XtX\" %in% names(result$data))\n expect_true(\"Xty\" %in% names(result$data))\n expect_true(\"yty\" %in% names(result$data))\n})\n\ntest_that(\"summary_stats_constructor handles z without n\", {\n p <- 50\n z <- rnorm(p)\n R <- diag(p)\n\n expect_message(\n result <- summary_stats_constructor(z = z, R = R, lambda = 0),\n \"Providing the sample size\"\n )\n\n expect_s3_class(result$data, \"ss\")\n})\n\ntest_that(\"summary_stats_constructor converts bhat/shat to z\", {\n p <- 50\n bhat <- rnorm(p)\n shat <- runif(p, 0.5, 1.5)\n R <- diag(p)\n n <- 100\n\n result <- summary_stats_constructor(bhat = bhat, shat = shat, R = R, n = n, lambda = 0)\n\n expect_s3_class(result$data, \"ss\")\n})\n\ntest_that(\"summary_stats_constructor requires either z or bhat/shat\", {\n R <- diag(50)\n\n expect_error(\n summary_stats_constructor(R = R, n = 100, lambda = 0),\n \"Please provide either z or \\\\(bhat, shat\\\\)\"\n )\n})\n\ntest_that(\"summary_stats_constructor rejects both z and bhat/shat\", {\n z <- rnorm(50)\n bhat <- rnorm(50)\n shat <- runif(50, 0.5, 1.5)\n R <- diag(50)\n\n expect_error(\n summary_stats_constructor(z = z, bhat = bhat, shat = shat, R = R, n = 100, lambda = 0),\n \"Please provide either z or \\\\(bhat, shat\\\\), but not both\"\n )\n})\n\n# =============================================================================\n# SUMMARY STATISTICS CONSTRUCTOR - Lambda != 0 Restrictions\n# =============================================================================\n\ntest_that(\"summary_stats_constructor rejects bhat/shat when lambda != 0\", {\n z <- rnorm(50)\n bhat <- rnorm(50)\n shat <- runif(50, 0.5, 1.5)\n R <- diag(50)\n\n expect_error(\n summary_stats_constructor(z = z, R = R, bhat = bhat, shat = shat, lambda = 0.5),\n \"bhat.*shat.*not supported\"\n )\n})\n\ntest_that(\"summary_stats_constructor rejects var_y when lambda != 0\", {\n z <- rnorm(50)\n R <- diag(50)\n\n expect_error(\n summary_stats_constructor(z = z, R = R, var_y = 1.5, lambda = 0.5),\n \"var_y.*not supported\"\n )\n})\n\ntest_that(\"summary_stats_constructor accepts n when lambda != 0 for PVE adjustment\", {\n z <- rnorm(50)\n R <- diag(50)\n\n # n is used for PVE adjustment in all paths; the lambda > 0 dispatch\n # routes through rss_lambda_constructor which requires MLE.\n result <- summary_stats_constructor(z = z, R = R, n = 100, lambda = 0.5,\n estimate_residual_method = \"MLE\")\n expect_true(!is.null(result))\n})\n\n# =============================================================================\n# SUMMARY STATISTICS CONSTRUCTOR - Lambda=0 Restrictions\n# =============================================================================\n\ntest_that(\"summary_stats_constructor rejects intercept_value when lambda = 0\", {\n z <- rnorm(50)\n R <- diag(50)\n\n expect_error(\n summary_stats_constructor(z = z, R = R, n = 100, lambda = 0, intercept_value = 0.5),\n \"intercept_value.*only supported\"\n )\n})\n\n# =============================================================================\n# INTEGRATION - Constructor Output Usability\n# =============================================================================\n\ntest_that(\"individual_data_constructor output works with ibss_initialize\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 31)\n\n result <- individual_data_constructor(base_data$X, base_data$y, L = 5)\n\n expect_error(\n model <- ibss_initialize(result$data, result$params),\n NA\n )\n})\n\ntest_that(\"sufficient_stats_constructor output works with ibss_initialize\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 32)\n XtX <- crossprod(base_data$X)\n Xty <- crossprod(base_data$X, base_data$y)\n yty <- sum(base_data$y^2)\n\n result <- sufficient_stats_constructor(Xty = Xty, yty = yty, n = base_data$n, XtX = XtX, L = 5)\n\n expect_error(\n model <- ibss_initialize(result$data, result$params),\n NA\n )\n})\n\ntest_that(\"rss_lambda_constructor output works with ibss_initialize\", {\n z <- rnorm(50)\n R <- diag(50)\n\n result <- rss_lambda_constructor(z, R, lambda = 0.5, L = 5)\n\n expect_error(\n model <- ibss_initialize(result$data, result$params),\n NA\n )\n})\n" }, { "path": "tests/testthat/test_susie_get_functions.R", "content": "context(\"susie_get_* functions\")\n\n# =============================================================================\n# Get Model Information\n# =============================================================================\n\ntest_that(\"susie_get_objective returns last ELBO when last_only=TRUE\", {\n set.seed(1)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n obj <- susie_get_objective(fit, last_only = TRUE)\n\n expect_type(obj, \"double\")\n expect_length(obj, 1)\n expect_equal(obj, fit$elbo[length(fit$elbo)])\n})\n\ntest_that(\"susie_get_objective returns full ELBO vector when last_only=FALSE\", {\n set.seed(2)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n obj <- susie_get_objective(fit, last_only = FALSE)\n\n expect_type(obj, \"double\")\n expect_equal(length(obj), fit$niter)\n expect_equal(obj, fit$elbo)\n})\n\ntest_that(\"susie_get_objective detects ELBO decrease\", {\n set.seed(3)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n fit$elbo <- c(-100, -90, -95, -85)\n\n expect_message(\n susie_get_objective(fit, warning_tol = 1e-6),\n \"Objective is decreasing\"\n )\n})\n\n# =============================================================================\n# Get Posterior Quantities\n# =============================================================================\n\ntest_that(\"susie_get_posterior_mean computes correctly\", {\n set.seed(4)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n pm <- susie_get_posterior_mean(fit)\n\n # Should return p-length vector\n expect_length(pm, dat$p)\n expect_type(pm, \"double\")\n\n # Manual calculation\n expected <- colSums(fit$alpha * fit$mu) / fit$X_column_scale_factors\n expect_equal(pm, expected)\n})\n\ntest_that(\"susie_get_posterior_mean filters effects with V < prior_tol\", {\n set.seed(5)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Set some V values to zero\n fit$V[c(1, 3)] <- 0\n\n pm <- susie_get_posterior_mean(fit, prior_tol = 1e-9)\n\n # Only effects 2, 4, 5 should contribute\n expected <- colSums((fit$alpha * fit$mu)[c(2, 4, 5), , drop = FALSE]) /\n fit$X_column_scale_factors\n expect_equal(pm, expected)\n})\n\ntest_that(\"susie_get_posterior_mean returns zeros when all V=0\", {\n set.seed(6)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Set all V to zero\n fit$V <- rep(0, 5)\n\n pm <- susie_get_posterior_mean(fit)\n\n expect_length(pm, dat$p)\n expect_equal(pm, rep(0, dat$p))\n})\n\ntest_that(\"susie_get_posterior_mean uses all effects when V is not numeric\", {\n set.seed(26)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Set V to NULL (not numeric) to trigger the else branch\n fit$V <- NULL\n\n pm <- susie_get_posterior_mean(fit)\n\n # Should return p-length vector\n expect_length(pm, dat$p)\n expect_type(pm, \"double\")\n\n # Manual calculation using ALL effects (since V is not numeric)\n expected <- colSums(fit$alpha * fit$mu) / fit$X_column_scale_factors\n expect_equal(pm, expected)\n})\n\ntest_that(\"susie_get_posterior_sd computes correctly\", {\n set.seed(7)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n psd <- susie_get_posterior_sd(fit)\n\n # Should return p-length vector\n expect_length(psd, dat$p)\n expect_type(psd, \"double\")\n expect_true(all(psd >= 0)) # SD must be non-negative\n\n # Manual calculation\n expected <- sqrt(colSums(fit$alpha * fit$mu2 - (fit$alpha * fit$mu)^2)) /\n fit$X_column_scale_factors\n expect_equal(psd, expected)\n})\n\ntest_that(\"susie_get_posterior_sd filters effects with V < prior_tol\", {\n set.seed(8)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Set some V values to zero\n fit$V[c(2, 4)] <- 0\n\n psd <- susie_get_posterior_sd(fit, prior_tol = 1e-9)\n\n # Only effects 1, 3, 5 should contribute\n expected <- sqrt(colSums((fit$alpha * fit$mu2 -\n (fit$alpha * fit$mu)^2)[c(1, 3, 5), , drop = FALSE])) /\n fit$X_column_scale_factors\n expect_equal(psd, expected)\n})\n\ntest_that(\"susie_get_posterior_sd uses all effects when V is not numeric\", {\n set.seed(27)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Set V to NULL (not numeric) to trigger the else branch\n fit$V <- NULL\n\n psd <- susie_get_posterior_sd(fit)\n\n # Should return p-length vector\n expect_length(psd, dat$p)\n expect_type(psd, \"double\")\n expect_true(all(psd >= 0)) # SD must be non-negative\n\n # Manual calculation using ALL effects (since V is not numeric)\n expected <- sqrt(colSums(fit$alpha * fit$mu2 - (fit$alpha * fit$mu)^2)) /\n fit$X_column_scale_factors\n expect_equal(psd, expected)\n})\n\ntest_that(\"susie_get_posterior_sd returns zeros when no effects pass prior_tol\", {\n set.seed(28)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Set all V to zero so no effects pass the prior_tol filter\n fit$V <- rep(0, 5)\n\n psd <- susie_get_posterior_sd(fit, prior_tol = 1e-9)\n\n # Should return p-length vector of zeros (length(include_idx) == 0)\n expect_length(psd, dat$p)\n expect_type(psd, \"double\")\n expect_equal(psd, numeric(dat$p)) # Should be all zeros\n expect_true(all(psd == 0))\n})\n\ntest_that(\"susie_get_niter returns correct iteration count\", {\n set.seed(9)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, max_iter = 50, verbose = FALSE)\n\n niter <- susie_get_niter(fit)\n\n expect_type(niter, \"integer\")\n expect_equal(niter, fit$niter)\n expect_equal(niter, length(fit$elbo))\n})\n\ntest_that(\"susie_get_prior_variance returns V\", {\n set.seed(10)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n V <- susie_get_prior_variance(fit)\n\n expect_equal(V, fit$V)\n expect_length(V, 5)\n expect_true(all(V >= 0))\n})\n\ntest_that(\"susie_get_residual_variance returns sigma2\", {\n set.seed(11)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n sigma2 <- susie_get_residual_variance(fit)\n\n expect_type(sigma2, \"double\")\n expect_length(sigma2, 1)\n expect_equal(sigma2, fit$sigma2)\n expect_true(sigma2 > 0)\n})\n\ntest_that(\"susie_get_lfsr computes local false sign rate\", {\n set.seed(17)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n lfsr <- susie_get_lfsr(fit)\n\n # Should return L-length vector (one per effect)\n expect_length(lfsr, 5)\n expect_type(lfsr, \"double\")\n\n # LFSR should be in [0, 1]\n expect_true(all(lfsr >= 0 & lfsr <= 1))\n})\n\ntest_that(\"susie_get_posterior_samples generates samples\", {\n set.seed(18)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n num_samples <- 100\n samples <- susie_get_posterior_samples(fit, num_samples = num_samples)\n\n # Should return list with b and gamma\n expect_type(samples, \"list\")\n expect_named(samples, c(\"b\", \"gamma\"))\n\n # Check dimensions\n expect_equal(dim(samples$b), c(dat$p, num_samples))\n expect_equal(dim(samples$gamma), c(dat$p, num_samples))\n\n # Gamma should be binary\n expect_true(all(samples$gamma %in% c(0, 1)))\n\n # b should be non-zero only where gamma is 1\n for (i in 1:num_samples) {\n expect_true(all((samples$b[, i] != 0) == (samples$gamma[, i] == 1)))\n }\n})\n\ntest_that(\"susie_get_posterior_samples filters effects with V < 1e-9\", {\n set.seed(19)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Set all V to zero (no effects)\n fit$V <- rep(0, 5)\n\n samples <- susie_get_posterior_samples(fit, num_samples = 50)\n\n # With all V=0, all samples should be zero\n expect_true(all(samples$b == 0))\n expect_true(all(samples$gamma == 0))\n})\n\ntest_that(\"susie_get_posterior_samples uses all effects when V is not numeric\", {\n set.seed(29)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Set V to NULL (not numeric) to trigger the else branch\n fit$V <- NULL\n\n num_samples <- 100\n samples <- susie_get_posterior_samples(fit, num_samples = num_samples)\n\n # Should return list with b and gamma\n expect_type(samples, \"list\")\n expect_named(samples, c(\"b\", \"gamma\"))\n\n # Check dimensions\n expect_equal(dim(samples$b), c(dat$p, num_samples))\n expect_equal(dim(samples$gamma), c(dat$p, num_samples))\n\n # Gamma should be binary\n expect_true(all(samples$gamma %in% c(0, 1)))\n\n # When V is not numeric, ALL effects are included (not filtered)\n # So samples should be generated from all L effects\n})\n\n# =============================================================================\n# Get Credible Sets and Correlations\n# =============================================================================\n\ntest_that(\"susie_get_cs identifies credible sets\", {\n set.seed(20)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n cs <- susie_get_cs(fit, coverage = 0.95)\n\n # Should return list with cs, coverage, requested_coverage\n expect_type(cs, \"list\")\n expect_true(\"cs\" %in% names(cs))\n expect_true(\"coverage\" %in% names(cs))\n expect_true(\"requested_coverage\" %in% names(cs))\n\n expect_equal(cs$requested_coverage, 0.95)\n\n # If CS found, check structure\n if (!is.null(cs$cs)) {\n expect_type(cs$cs, \"list\")\n expect_true(all(sapply(cs$cs, is.numeric)))\n expect_equal(length(cs$cs), length(cs$coverage))\n }\n})\n\ntest_that(\"susie_get_cs filters by purity when X provided\", {\n set.seed(21)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n cs_with_purity <- susie_get_cs(fit, X = dat$X, min_abs_corr = 0.5, coverage = 0.95)\n\n # Should have purity and cs_index fields when X provided\n if (!is.null(cs_with_purity$cs)) {\n expect_true(\"purity\" %in% names(cs_with_purity))\n expect_true(\"cs_index\" %in% names(cs_with_purity))\n\n # Purity should be data frame with min, mean, median\n expect_s3_class(cs_with_purity$purity, \"data.frame\")\n expect_true(all(c(\"min.abs.corr\", \"mean.abs.corr\", \"median.abs.corr\") %in%\n colnames(cs_with_purity$purity)))\n\n # All purity values should be >= min_abs_corr\n expect_true(all(cs_with_purity$purity$min.abs.corr >= 0.5))\n }\n})\n\ntest_that(\"susie_get_cs handles dedup parameter\", {\n set.seed(22)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n cs_dedup <- susie_get_cs(fit, coverage = 0.95, dedup = TRUE)\n cs_no_dedup <- susie_get_cs(fit, coverage = 0.95, dedup = FALSE)\n\n # With dedup=TRUE, should have <= CS than without\n n_cs_dedup <- if (is.null(cs_dedup$cs)) 0 else length(cs_dedup$cs)\n n_cs_no_dedup <- if (is.null(cs_no_dedup$cs)) 0 else length(cs_no_dedup$cs)\n expect_true(n_cs_dedup <= n_cs_no_dedup)\n})\n\ntest_that(\"susie_get_cs errors when both X and Xcorr are provided\", {\n set.seed(30)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n # Create Xcorr\n Xcorr <- cor(dat$X)\n\n # Should error when both X and Xcorr are specified\n expect_error(\n susie_get_cs(fit, X = dat$X, Xcorr = Xcorr, coverage = 0.95),\n \"Only one of X or Xcorr should be specified\"\n )\n})\n\ntest_that(\"susie_get_cs warns when neither X nor Xcorr is provided\", {\n set.seed(40)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n # Warn even when min_abs_corr is left at its default, since purity\n # filtering is skipped whenever neither X nor Xcorr is supplied.\n expect_message(\n susie_get_cs(fit),\n \"purity filtering is skipped\"\n )\n\n # Same warning when min_abs_corr is explicitly set.\n expect_message(\n susie_get_cs(fit, min_abs_corr = 0.9),\n \"purity filtering is skipped\"\n )\n})\n\ntest_that(\"susie_get_cs does not warn when X or Xcorr is provided\", {\n set.seed(41)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n expect_no_message(\n susie_get_cs(fit, X = dat$X, min_abs_corr = 0.5),\n message = \"purity filtering is skipped\"\n )\n\n expect_no_message(\n susie_get_cs(fit, Xcorr = cor(dat$X), min_abs_corr = 0.5),\n message = \"purity filtering is skipped\"\n )\n})\n\ntest_that(\"susie_get_cs warns and fixes non-symmetric Xcorr\", {\n set.seed(31)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n # Create a non-symmetric correlation matrix\n Xcorr <- cor(dat$X)\n # Make it non-symmetric by modifying upper triangle\n Xcorr[1, 2] <- 0.9\n Xcorr[2, 1] <- 0.8 # Different from Xcorr[1, 2]\n\n # Should warn about non-symmetry\n expect_message(\n cs <- susie_get_cs(fit, Xcorr = Xcorr, coverage = 0.95, check_symmetric = TRUE),\n \"Xcorr is not symmetric; forcing Xcorr to be symmetric\"\n )\n\n # Verify the symmetrization formula: (Xcorr + t(Xcorr)) / 2\n Xcorr_original <- cor(dat$X)\n Xcorr_original[1, 2] <- 0.9\n Xcorr_original[2, 1] <- 0.8\n\n expected_value <- (0.9 + 0.8) / 2 # Should be 0.85\n expect_equal(expected_value, 0.85)\n})\n\ntest_that(\"susie_get_cs uses squared correlation column names when squared=TRUE\", {\n set.seed(32)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n # Get CS with squared=TRUE\n cs_squared <- susie_get_cs(fit, X = dat$X, coverage = 0.95, squared = TRUE)\n\n # If CS found, check purity column names\n if (!is.null(cs_squared$cs) && !is.null(cs_squared$purity)) {\n expect_true(\"purity\" %in% names(cs_squared))\n expect_s3_class(cs_squared$purity, \"data.frame\")\n\n # When squared=TRUE, column names should be min.sq.corr, mean.sq.corr, median.sq.corr\n expect_true(all(c(\"min.sq.corr\", \"mean.sq.corr\", \"median.sq.corr\") %in%\n colnames(cs_squared$purity)))\n\n # Should NOT have the absolute correlation names\n expect_false(\"min.abs.corr\" %in% colnames(cs_squared$purity))\n expect_false(\"mean.abs.corr\" %in% colnames(cs_squared$purity))\n expect_false(\"median.abs.corr\" %in% colnames(cs_squared$purity))\n } else {\n skip(\"No CS with purity found for squared correlation test\")\n }\n\n # Compare with squared=FALSE (default)\n cs_abs <- susie_get_cs(fit, X = dat$X, coverage = 0.95, squared = FALSE)\n\n if (!is.null(cs_abs$cs) && !is.null(cs_abs$purity)) {\n # When squared=FALSE, column names should be min.abs.corr, mean.abs.corr, median.abs.corr\n expect_true(all(c(\"min.abs.corr\", \"mean.abs.corr\", \"median.abs.corr\") %in%\n colnames(cs_abs$purity)))\n\n # Should NOT have the squared correlation names\n expect_false(\"min.sq.corr\" %in% colnames(cs_abs$purity))\n expect_false(\"mean.sq.corr\" %in% colnames(cs_abs$purity))\n expect_false(\"median.sq.corr\" %in% colnames(cs_abs$purity))\n }\n})\n\ntest_that(\"get_cs_correlation computes correlations between CS\", {\n set.seed(23)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n if (!is.null(fit$sets$cs) && length(fit$sets$cs) > 1) {\n cs_corr <- get_cs_correlation(fit, X = dat$X)\n\n expect_true(is.matrix(cs_corr))\n expect_equal(nrow(cs_corr), length(fit$sets$cs))\n expect_equal(ncol(cs_corr), length(fit$sets$cs))\n\n expect_equal(as.numeric(diag(cs_corr)), rep(1, nrow(cs_corr)))\n } else {\n skip(\"No multiple CS found for correlation test\")\n }\n})\n\ntest_that(\"get_cs_correlation with Xcorr instead of X\", {\n set.seed(24)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n if (!is.null(fit$sets$cs) && length(fit$sets$cs) > 1) {\n Xcorr <- cor(dat$X)\n cs_corr <- get_cs_correlation(fit, Xcorr = Xcorr)\n\n expect_true(is.matrix(cs_corr))\n expect_equal(nrow(cs_corr), length(fit$sets$cs))\n } else {\n skip(\"No multiple CS found for Xcorr test\")\n }\n})\n\ntest_that(\"get_cs_correlation returns NA when no CS or only one CS\", {\n set.seed(33)\n dat <- simulate_regression(n = 100, p = 50, k = 1)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Case 1: No CS at all\n fit$sets <- list(cs = NULL)\n result <- get_cs_correlation(fit, X = dat$X)\n expect_true(is.na(result))\n\n # Case 2: Only one CS\n fit$sets <- list(cs = list(c(1, 2, 3)))\n result <- get_cs_correlation(fit, X = dat$X)\n expect_true(is.na(result))\n})\n\ntest_that(\"get_cs_correlation errors when both X and Xcorr are provided\", {\n set.seed(34)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n if (!is.null(fit$sets$cs) && length(fit$sets$cs) > 1) {\n Xcorr <- cor(dat$X)\n\n # Should error when both X and Xcorr are specified\n expect_error(\n get_cs_correlation(fit, X = dat$X, Xcorr = Xcorr),\n \"Only one of X or Xcorr should be specified\"\n )\n } else {\n skip(\"No multiple CS found for test\")\n }\n})\n\ntest_that(\"get_cs_correlation errors when neither X nor Xcorr are provided\", {\n set.seed(35)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n if (!is.null(fit$sets$cs) && length(fit$sets$cs) > 1) {\n # Should error when neither X nor Xcorr are specified\n expect_error(\n get_cs_correlation(fit, X = NULL, Xcorr = NULL),\n \"One of X or Xcorr must be specified\"\n )\n } else {\n skip(\"No multiple CS found for test\")\n }\n})\n\ntest_that(\"get_cs_correlation warns and fixes non-symmetric Xcorr\", {\n set.seed(36)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n if (!is.null(fit$sets$cs) && length(fit$sets$cs) > 1) {\n # Create a non-symmetric correlation matrix\n Xcorr <- cor(dat$X)\n Xcorr[1, 2] <- 0.9\n Xcorr[2, 1] <- 0.8 # Different from Xcorr[1, 2]\n\n # Should warn about non-symmetry\n expect_message(\n cs_corr <- get_cs_correlation(fit, Xcorr = Xcorr),\n \"Xcorr is not symmetric; forcing Xcorr to be symmetric\"\n )\n\n # Verify the symmetrization formula: (Xcorr + t(Xcorr)) / 2\n expected_value <- (0.9 + 0.8) / 2 # Should be 0.85\n expect_equal(expected_value, 0.85)\n } else {\n skip(\"No multiple CS found for test\")\n }\n})\n\ntest_that(\"get_cs_correlation with max=TRUE returns scalar maximum\", {\n set.seed(37)\n dat <- simulate_regression(n = 200, p = 100, k = 3, signal_sd = 2)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n fit$sets <- susie_get_cs(fit, X = dat$X, coverage = 0.95)\n\n if (!is.null(fit$sets$cs) && length(fit$sets$cs) > 1) {\n # Get full correlation matrix first\n cs_corr_matrix <- get_cs_correlation(fit, X = dat$X, max = FALSE)\n\n # Get max correlation\n cs_corr_max <- get_cs_correlation(fit, X = dat$X, max = TRUE)\n\n # Should be a scalar\n expect_type(cs_corr_max, \"double\")\n expect_length(cs_corr_max, 1)\n\n # Should equal max of upper triangle absolute values\n expected_max <- max(abs(cs_corr_matrix[upper.tri(cs_corr_matrix)]))\n expect_equal(cs_corr_max, expected_max)\n\n # Max should be >= 0 and <= 1 (correlation)\n expect_true(cs_corr_max >= 0 && cs_corr_max <= 1)\n\n # When max=TRUE, should not have rownames/colnames (it's a scalar)\n expect_null(names(cs_corr_max))\n } else {\n skip(\"No multiple CS found for test\")\n }\n})\n\n# =============================================================================\n# Get PIPs and Related Functions\n# =============================================================================\n\ntest_that(\"susie_get_pip computes PIPs correctly\", {\n set.seed(12)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n pip <- susie_get_pip(fit)\n\n # Should return p-length vector\n expect_length(pip, dat$p)\n expect_type(pip, \"double\")\n\n # All PIPs should be in [0, 1]\n expect_true(all(pip >= 0 & pip <= 1))\n\n # Manual calculation: 1 - prod(1 - alpha)\n expected <- 1 - apply(1 - fit$alpha, 2, prod)\n expect_equal(pip, expected)\n})\n\ntest_that(\"susie_get_pip handles null_index correctly\", {\n set.seed(13)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, null_weight = 0.1, verbose = FALSE)\n\n pip <- susie_get_pip(fit)\n\n expect_length(pip, dat$p)\n expect_true(all(pip >= 0 & pip <= 1))\n\n if (!is.null(fit$null_index) && fit$null_index > 0) {\n expect_true(ncol(fit$alpha) == dat$p + 1)\n }\n})\n\ntest_that(\"susie_get_pip filters by prior_tol\", {\n set.seed(14)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Set some V to zero\n fit$V[c(1, 5)] <- 0\n\n pip <- susie_get_pip(fit, prior_tol = 1e-9)\n\n # Only effects 2, 3, 4 should contribute\n expected <- 1 - apply(1 - fit$alpha[c(2, 3, 4), , drop = FALSE], 2, prod)\n expect_equal(pip, expected)\n})\n\ntest_that(\"susie_get_pip with prune_by_cs filters to CS effects only\", {\n set.seed(15)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n # Get CS\n fit$sets <- susie_get_cs(fit, coverage = 0.95)\n\n pip_pruned <- susie_get_pip(fit, prune_by_cs = TRUE)\n\n # Should still return p-length vector\n expect_length(pip_pruned, dat$p)\n expect_true(all(pip_pruned >= 0 & pip_pruned <= 1))\n\n # If there are CS, pruned PIPs should be different from unpruned\n if (!is.null(fit$sets$cs_index)) {\n pip_full <- susie_get_pip(fit, prune_by_cs = FALSE)\n # At least some should differ (unless all effects are in CS)\n expect_true(any(pip_pruned != pip_full) || length(fit$sets$cs_index) == nrow(fit$alpha))\n }\n})\n\ntest_that(\"susie_get_pip returns zeros when no CS and prune_by_cs=TRUE\", {\n set.seed(16)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Force no credible sets\n fit$sets <- list(cs = NULL, cs_index = NULL)\n\n pip <- susie_get_pip(fit, prune_by_cs = TRUE)\n\n expect_length(pip, dat$p)\n # When no CS, all PIPs should be zero\n expect_true(all(pip == 0))\n})\n\ntest_that(\"susie_get_pip uses all effects when V is not numeric\", {\n set.seed(38)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 5, verbose = FALSE)\n\n # Set V to NULL (not numeric) to trigger the else branch\n fit$V <- NULL\n\n pip <- susie_get_pip(fit)\n\n # Should return p-length vector\n expect_length(pip, dat$p)\n expect_type(pip, \"double\")\n\n # All PIPs should be in [0, 1]\n expect_true(all(pip >= 0 & pip <= 1))\n\n # Manual calculation using ALL effects (since V is not numeric)\n expected <- 1 - apply(1 - fit$alpha, 2, prod)\n expect_equal(pip, expected)\n})\n\ntest_that(\"susie_get_pip with prune_by_cs uses intersection of include_idx and cs_index\", {\n set.seed(39)\n dat <- simulate_regression(n = 100, p = 50, k = 3)\n fit <- susie(dat$X, dat$y, L = 10, verbose = FALSE)\n\n # Get CS\n fit$sets <- susie_get_cs(fit, coverage = 0.95)\n\n # Also set some V to zero to create a filtering scenario\n fit$V[c(1, 2)] <- 0\n\n if (!is.null(fit$sets$cs_index)) {\n # Get PIPs with prune_by_cs=TRUE\n pip_pruned <- susie_get_pip(fit, prune_by_cs = TRUE, prior_tol = 1e-9)\n\n # Should return p-length vector\n expect_length(pip_pruned, dat$p)\n expect_true(all(pip_pruned >= 0 & pip_pruned <= 1))\n\n # Manually compute what include_idx should be\n # Effects with V > prior_tol\n include_idx_V <- which(fit$V > 1e-9) # Should exclude 1, 2\n\n # Intersection with cs_index (only effects in CS)\n include_idx_final <- intersect(include_idx_V, fit$sets$cs_index)\n\n # If the intersection is non-empty, compute expected PIPs\n if (length(include_idx_final) > 0) {\n expected <- 1 - apply(1 - fit$alpha[include_idx_final, , drop = FALSE], 2, prod)\n expect_equal(pip_pruned, expected)\n } else {\n # If intersection is empty, should be all zeros\n expect_true(all(pip_pruned == 0))\n }\n } else {\n skip(\"No CS found for intersection test\")\n }\n})\n\n# =============================================================================\n# Initialization Functions\n# =============================================================================\n\ntest_that(\"susie_init_coef creates valid initialization object\", {\n p <- 100\n coef_index <- c(5, 20, 45, 80)\n coef_value <- c(1.5, -2.0, 0.8, -1.2)\n\n init <- susie_init_coef(coef_index, coef_value, p)\n\n # Should return susie object\n expect_s3_class(init, \"susie\")\n expect_type(init, \"list\")\n\n # Should have required fields\n expect_true(all(c(\"alpha\", \"mu\", \"mu2\") %in% names(init)))\n expect_null(init$V)\n\n # Check dimensions\n L <- length(coef_index)\n expect_equal(dim(init$alpha), c(L, p))\n expect_equal(dim(init$mu), c(L, p))\n expect_equal(dim(init$mu2), c(L, p))\n})\n\ntest_that(\"susie_init_coef sets alpha correctly\", {\n p <- 50\n coef_index <- c(10, 25, 40)\n coef_value <- c(1.0, 2.0, 3.0)\n\n init <- susie_init_coef(coef_index, coef_value, p)\n\n # Alpha should be indicator matrix\n for (i in seq_along(coef_index)) {\n expect_equal(init$alpha[i, coef_index[i]], 1)\n expect_equal(sum(init$alpha[i, ]), 1) # Each row sums to 1\n expect_equal(sum(init$alpha[i, -coef_index[i]]), 0) # All others are 0\n }\n})\n\ntest_that(\"susie_init_coef sets mu and mu2 correctly\", {\n p <- 50\n coef_index <- c(10, 25, 40)\n coef_value <- c(1.5, -2.0, 0.8)\n\n init <- susie_init_coef(coef_index, coef_value, p)\n\n # Mu should have coef_value at coef_index\n for (i in seq_along(coef_index)) {\n expect_equal(init$mu[i, coef_index[i]], coef_value[i])\n expect_equal(sum(init$mu[i, -coef_index[i]]), 0) # All others are 0\n }\n\n # mu2 should equal mu^2\n expect_equal(init$mu2, init$mu * init$mu)\n})\n\ntest_that(\"susie_init_coef errors on invalid inputs\", {\n # No effects\n expect_error(\n susie_init_coef(integer(0), numeric(0), 100),\n \"Need at least one non-zero effect\"\n )\n\n # Zero coefficient value\n expect_error(\n susie_init_coef(c(1, 5), c(1.0, 0.0), 100),\n \"Input coef_value must be non-zero for all its elements\"\n )\n\n # Mismatched lengths\n expect_error(\n susie_init_coef(c(1, 5, 10), c(1.0, 2.0), 100),\n \"Inputs coef_index and coef_value must of the same length\"\n )\n\n # Index out of bounds\n expect_error(\n susie_init_coef(c(1, 5, 150), c(1.0, 2.0, 3.0), 100),\n \"Input coef_index exceeds the boundary of p\"\n )\n})\n\ntest_that(\"susie_init_coef works with susie\", {\n set.seed(25)\n n <- 100\n p <- 50\n\n # Create data with known true effects\n dat <- simulate_regression(n = n, p = p, k = 3)\n true_coef_idx <- which(dat$beta != 0)\n true_coef_val <- dat$beta[true_coef_idx]\n\n # Initialize with true coefficients\n init <- susie_init_coef(true_coef_idx, true_coef_val, p)\n\n # Fit susie with initialization\n fit <- susie(dat$X, dat$y, L = 10, model_init = init, verbose = FALSE)\n\n # Should return valid susie fit\n expect_s3_class(fit, \"susie\")\n expect_true(!is.null(fit$alpha))\n expect_true(!is.null(fit$mu))\n expect_true(!is.null(fit$elbo))\n})\n" }, { "path": "tests/testthat/test_susie_small.R", "content": "context(\"test_susie_small.R\")\n\ntest_that(paste(\"check that ELBO is monotonically increasing for \",\n \"estimate_residual_method = 'NIG', \",\n \"with L = 1\"),{\n set.seed(1)\n data(data_small)\n y <- data_small$y\n X <- data_small$X\n fit <- susie(X,y,L = 1,estimate_residual_method = \"NIG\",\n alpha0 = 0.1,beta0 = 0.1,tol = 1e-6,verbose = TRUE)\n expect_true(all(diff(fit$elbo) >= 0))\n})\n" }, { "path": "tests/testthat/test_susie_utils.R", "content": "context(\"Utility functions for susieR\")\n\n# =============================================================================\n# FUNDAMENTAL BUILDING BLOCKS\n# =============================================================================\n\ntest_that(\"warning_message displays warnings correctly\", {\n # Test warning style (default)\n expect_message(\n warning_message(\"Test warning\"),\n \"WARNING:.*Test warning\"\n )\n\n # Test warning style (explicit)\n expect_message(\n warning_message(\"Test warning\", style = \"warning\"),\n \"WARNING:.*Test warning\"\n )\n\n # Test hint style\n expect_message(\n warning_message(\"Test hint\", style = \"hint\"),\n \"HINT:.*Test hint\"\n )\n\n # Test with warn < 0\n old_warn <- getOption(\"warn\")\n on.exit(options(warn = old_warn), add = TRUE)\n\n options(warn = -1)\n expect_no_error(warning_message(\"Still executes\", style = \"warning\"))\n\n # Hint should still show even with warn < 0\n expect_message(\n warning_message(\"Hint shows\", style = \"hint\"),\n \"HINT:.*Hint shows\"\n )\n})\n\ntest_that(\"safe_cor computes correlation and handles zero sd columns\", {\n # Normal correlation\n x <- matrix(c(1, 2, 3, 4, 5, 6), nrow = 3, ncol = 2)\n result <- safe_cor(x)\n expected <- cor(x)\n expect_equal(result, expected)\n\n # With constant column (zero sd) - should handle without warning\n\n x_const <- cbind(x, rep(1, 3))\n\n # Without safe_cor, cor() would warn\n expect_warning(cor(x_const), \"the standard deviation is zero\")\n\n # safe_cor handles this without warning and returns 0 for constant column correlations\n expect_silent(result <- safe_cor(x_const))\n\n # Check that correlations involving constant column are 0 (not NA)\n expect_equal(result[3, 1], 0)\n expect_equal(result[3, 2], 0)\n expect_equal(result[1, 3], 0)\n expect_equal(result[2, 3], 0)\n # Diagonal should still be 1\n expect_equal(diag(result), c(1, 1, 1))\n})\n\ntest_that(\"safe_cov2cor computes correlation from covariance and handles zero variance\", {\n # Normal case\n cov_mat <- matrix(c(4, 2, 2, 3), nrow = 2)\n result <- safe_cov2cor(cov_mat)\n expected <- cov2cor(cov_mat)\n expect_equal(result, expected)\n\n # With zero variance entry - safe_cov2cor handles this without warning\n cov_mat_zero <- matrix(c(0, 0, 0, 3), nrow = 2)\n\n # Without safe_cov2cor, cov2cor() would warn\n expect_warning(cov2cor(cov_mat_zero))\n\n # safe_cov2cor handles zero variance by returning 0 correlations (not NA)\n expect_silent(result <- safe_cov2cor(cov_mat_zero))\n expect_true(is.matrix(result))\n # Diagonal should be 1\n expect_equal(diag(result), c(1, 1))\n # Off-diagonal correlations involving zero-variance variable should be 0\n\n expect_equal(result[1, 2], 0)\n expect_equal(result[2, 1], 0)\n})\n\ntest_that(\"safe_cor handles constant columns without warnings\", {\n # Create data with a constant column that would trigger a warning in base cor()\n x_const <- matrix(c(1, 2, 3, 4, 5, 6, 1, 1, 1), nrow = 3, ncol = 3)\n\n # Verify that base cor() would warn\n expect_warning(cor(x_const), \"the standard deviation is zero\")\n\n # Test that safe_cor handles it silently\n expect_silent(safe_cor(x_const))\n\n # Verify result is computed correctly\n result <- safe_cor(x_const)\n expect_true(is.matrix(result))\n # Correlations involving the constant column (col 3) should be 0, not NA\n\n expect_equal(result[3, 1], 0)\n expect_equal(result[3, 2], 0)\n expect_equal(result[1, 3], 0)\n expect_equal(result[2, 3], 0)\n # Diagonal should be 1\n expect_equal(diag(result), c(1, 1, 1))\n})\n\ntest_that(\"safe_cov2cor handles zero variance without warnings\", {\n # Create covariance matrix with zero variance that would trigger a warning in base cov2cor()\n cov_mat_zero <- matrix(c(0, 0, 0, 3), nrow = 2)\n\n # Verify that base cov2cor() would warn\n expect_warning(cov2cor(cov_mat_zero))\n\n # Test that safe_cov2cor handles it silently\n expect_silent(safe_cov2cor(cov_mat_zero))\n\n # Verify result is computed correctly\n result <- safe_cov2cor(cov_mat_zero)\n expect_true(is.matrix(result))\n # Correlations involving zero-variance variable should be 0, not NA\n\n expect_equal(result[1, 2], 0)\n expect_equal(result[2, 1], 0)\n # Diagonal should be 1\n expect_equal(diag(result), c(1, 1))\n})\n\ntest_that(\"is_symmetric_matrix correctly identifies symmetric matrices\", {\n # Symmetric matrix\n sym_mat <- matrix(c(1, 2, 3, 2, 4, 5, 3, 5, 6), nrow = 3)\n expect_true(is_symmetric_matrix(sym_mat))\n\n # Non-symmetric matrix\n nonsym_mat <- matrix(c(1, 2, 3, 4, 5, 6, 7, 8, 9), nrow = 3)\n expect_false(is_symmetric_matrix(nonsym_mat))\n\n # Identity matrix\n expect_true(is_symmetric_matrix(diag(5)))\n\n # Sparse symmetric matrix\n sparse_sym <- Matrix::Matrix(sym_mat, sparse = TRUE)\n expect_true(is_symmetric_matrix(sparse_sym))\n})\n\ntest_that(\"apply_nonzeros applies function to nonzero elements of sparse matrix\", {\n # Create sparse matrix\n X <- Matrix::Matrix(c(1, 0, 0, 2, 0, 3, 4, 0, 5), nrow = 3, sparse = TRUE)\n\n # Square all nonzero elements\n result <- apply_nonzeros(X, function(x) x^2)\n\n # Check dimensions preserved\n expect_equal(dim(result), dim(X))\n\n # Check that zeros remain zeros\n expect_equal(sum(result == 0), sum(X == 0))\n\n # Check nonzero values are squared\n expected <- Matrix::Matrix(c(1, 0, 0, 4, 0, 9, 16, 0, 25), nrow = 3, sparse = TRUE)\n expect_equal(as.matrix(result), as.matrix(expected))\n\n # Test with another function (doubling)\n result2 <- apply_nonzeros(X, function(x) x * 2)\n expected2 <- Matrix::Matrix(c(2, 0, 0, 4, 0, 6, 8, 0, 10), nrow = 3, sparse = TRUE)\n expect_equal(as.matrix(result2), as.matrix(expected2))\n})\n\ntest_that(\"compute_colSds computes column standard deviations correctly\", {\n # Dense matrix\n X_dense <- matrix(rnorm(100), nrow = 10, ncol = 10)\n result_dense <- compute_colSds(X_dense)\n expected_dense <- matrixStats::colSds(X_dense)\n expect_equal(result_dense, expected_dense, tolerance = 1e-10)\n\n # Sparse matrix\n X_sparse <- Matrix::Matrix(X_dense, sparse = TRUE)\n X_sparse[abs(X_sparse) < 0.5] <- 0 # Make it actually sparse\n result_sparse <- compute_colSds(X_sparse)\n expected_sparse <- apply(as.matrix(X_sparse), 2, sd)\n expect_equal(result_sparse, expected_sparse, tolerance = 1e-10)\n\n # Matrix with constant column (sd = 0)\n X_const <- cbind(X_dense, rep(1, 10))\n result_const <- compute_colSds(X_const)\n expect_equal(result_const[11], 0)\n expect_equal(result_const[1:10], matrixStats::colSds(X_dense))\n})\n\ntest_that(\"compute_colstats computes column statistics correctly\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 123)\n\n # Test with both center and scale\n result <- compute_colstats(base_data$X, center = TRUE, scale = TRUE)\n\n # Check components exist\n expect_true(all(c(\"cm\", \"csd\", \"d\") %in% names(result)))\n expect_length(result$cm, base_data$p)\n expect_length(result$csd, base_data$p)\n expect_length(result$d, base_data$p)\n\n # Check column means\n expect_equal(result$cm, colMeans(base_data$X), tolerance = 1e-10)\n\n # Check column sds\n expected_csd <- apply(base_data$X, 2, sd)\n expect_equal(result$csd, expected_csd, tolerance = 1e-10)\n\n # Check d values (sum of squared standardized values)\n X_std <- scale(base_data$X, center = TRUE, scale = TRUE)\n expected_d <- colSums(X_std^2)\n expect_equal(result$d, expected_d, tolerance = 1e-8)\n\n # Test with center = FALSE\n result_nocenter <- compute_colstats(base_data$X, center = FALSE, scale = TRUE)\n expect_equal(result_nocenter$cm, rep(0, base_data$p))\n expect_equal(result_nocenter$csd, expected_csd, tolerance = 1e-10)\n\n # Test with scale = FALSE\n result_noscale <- compute_colstats(base_data$X, center = TRUE, scale = FALSE)\n expect_equal(result_noscale$cm, colMeans(base_data$X), tolerance = 1e-10)\n expect_equal(result_noscale$csd, rep(1, base_data$p))\n\n # Test with neither center nor scale\n result_neither <- compute_colstats(base_data$X, center = FALSE, scale = FALSE)\n expect_equal(result_neither$cm, rep(0, base_data$p))\n expect_equal(result_neither$csd, rep(1, base_data$p))\n expected_d_neither <- colSums(base_data$X^2)\n expect_equal(result_neither$d, expected_d_neither, tolerance = 1e-10)\n\n # Test with column of zeros (sd = 0)\n X_zero <- cbind(base_data$X, rep(0, base_data$n))\n result_zero <- compute_colstats(X_zero, center = TRUE, scale = TRUE)\n expect_equal(result_zero$csd[base_data$p + 1], 1) # sd = 0 replaced by 1\n\n # Test with sparse matrix\n X_sparse <- Matrix::Matrix(base_data$X, sparse = TRUE)\n X_sparse[abs(X_sparse) < 1] <- 0\n result_sparse <- compute_colstats(X_sparse, center = TRUE, scale = TRUE)\n expect_length(result_sparse$cm, base_data$p)\n expect_length(result_sparse$csd, base_data$p)\n expect_length(result_sparse$d, base_data$p)\n})\n\n# =============================================================================\n# DATA PROCESSING & VALIDATION\n# =============================================================================\n\ntest_that(\"check_semi_pd identifies positive semi-definite matrices\", {\n # Positive definite matrix\n A_pd <- matrix(c(2, 1, 1, 2), nrow = 2)\n result_pd <- check_semi_pd(A_pd, tol = 1e-10)\n\n expect_true(result_pd$status)\n expect_true(all(result_pd$eigenvalues >= 0))\n expect_true(!is.null(attr(result_pd$matrix, \"eigen\")))\n\n # Positive semi-definite matrix (singular)\n A_psd <- matrix(c(1, 1, 1, 1), nrow = 2)\n result_psd <- check_semi_pd(A_psd, tol = 1e-10)\n\n expect_true(result_psd$status)\n expect_true(min(result_psd$eigenvalues) >= 0)\n expect_true(any(abs(result_psd$eigenvalues) < 1e-10)) # Has zero eigenvalue\n\n # Not positive semi-definite\n A_neg <- matrix(c(1, 2, 2, -1), nrow = 2)\n result_neg <- check_semi_pd(A_neg, tol = 1e-10)\n\n expect_false(result_neg$status)\n expect_true(any(result_neg$eigenvalues < 0))\n\n # Identity matrix\n A_id <- diag(3)\n result_id <- check_semi_pd(A_id, tol = 1e-10)\n\n expect_true(result_id$status)\n expect_equal(result_id$eigenvalues, rep(1, 3), tolerance = 1e-10)\n})\n\ntest_that(\"check_projection verifies if vector is in eigenspace\", {\n # Create a matrix and vector in its column space\n A <- matrix(c(4, 2, 2, 3), nrow = 2)\n b_in <- c(2, 1) # In column space\n\n result_in <- check_projection(A, b_in)\n expect_true(result_in$status)\n expect_true(is.na(result_in$msg))\n\n # Test with pre-computed eigen decomposition\n A_with_eigen <- A\n attr(A_with_eigen, \"eigen\") <- eigen(A, symmetric = TRUE)\n result_with_eigen <- check_projection(A_with_eigen, b_in)\n expect_true(result_with_eigen$status)\n})\n\ntest_that(\"validate_init validates model initialization objects\", {\n # Create valid model_init\n p <- 50\n L <- 5\n valid_init <- list(\n alpha = matrix(1/p, L, p),\n mu = matrix(0, L, p),\n mu2 = matrix(0, L, p),\n V = rep(1, L),\n sigma2 = 1,\n pi = rep(1/p, p),\n null_index = 0\n )\n class(valid_init) <- \"susie\"\n\n data <- list(n = 100, p = p)\n params <- list(L = L, model_init = valid_init)\n\n # Should pass without error\n expect_silent(validate_init(data, params))\n\n # Test: not a susie object\n bad_init <- valid_init\n class(bad_init) <- \"lm\"\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init must be a 'susie' object\")\n\n # Test: NA in alpha\n bad_init <- valid_init\n bad_init$alpha[1, 1] <- NA\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$alpha contains NA/Inf\")\n\n # Test: Inf in mu\n bad_init <- valid_init\n bad_init$mu[1, 1] <- Inf\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$mu contains NA/Inf\")\n\n # Test: alpha not a matrix\n bad_init <- valid_init\n bad_init$alpha <- as.vector(bad_init$alpha)\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$alpha must be a matrix\")\n\n # Test: alpha values outside [0,1]\n bad_init <- valid_init\n bad_init$alpha[1, 1] <- 1.5\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"invalid values outside range\")\n\n # Test: dimension mismatch\n bad_init <- valid_init\n bad_init$mu <- matrix(0, L, p - 1)\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"dimensions do not match\")\n\n # Test: V length mismatch\n bad_init <- valid_init\n bad_init$V <- rep(1, L - 1)\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"does not equal nrow\")\n\n # Test: negative V\n bad_init <- valid_init\n bad_init$V[1] <- -1\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"at least one negative value\")\n\n # Test: negative sigma2\n bad_init <- valid_init\n bad_init$sigma2 <- -0.5\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"sigma2 is negative\")\n\n # Test: NULL V (should pass)\n init_no_V <- valid_init\n init_no_V$V <- NULL\n params_no_V <- list(L = L, model_init = init_no_V)\n expect_silent(validate_init(data, params_no_V))\n\n # Test 1: mu2 contains NA/Inf values\n bad_init <- valid_init\n bad_init$mu2[2, 3] <- NA\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$mu2 contains NA/Inf values\")\n\n bad_init <- valid_init\n bad_init$mu2[1, 5] <- Inf\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$mu2 contains NA/Inf values\")\n\n # Test 2: V contains NA/Inf values\n bad_init <- valid_init\n bad_init$V[2] <- NA\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$V contains NA/Inf values\")\n\n bad_init <- valid_init\n bad_init$V[3] <- Inf\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$V contains NA/Inf values\")\n\n # Test 3: sigma2 contains NA/Inf\n bad_init <- valid_init\n bad_init$sigma2 <- NA\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$sigma2 contains NA/Inf\")\n\n bad_init <- valid_init\n bad_init$sigma2 <- Inf\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$sigma2 contains NA/Inf\")\n\n # Test 4: pi contains NA/Inf\n bad_init <- valid_init\n bad_init$pi[10] <- NA\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$pi contains NA/Inf\")\n\n bad_init <- valid_init\n bad_init$pi[5] <- Inf\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$pi contains NA/Inf\")\n\n # Test 5: mu2 and alpha dimensions do not match\n bad_init <- valid_init\n bad_init$mu2 <- matrix(0, L, p - 1)\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$mu2 and model_init\\\\$alpha dimensions do not match\")\n\n bad_init <- valid_init\n bad_init$mu2 <- matrix(0, L + 1, p)\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$mu2 and model_init\\\\$alpha dimensions do not match\")\n\n # Test 6: V must be numeric\n # Note: This branch is unreachable because is.finite() on character vectors\n # returns FALSE, triggering the NA/Inf error first. The numeric check only runs\n # if all values pass is.finite(). Testing with numeric values only.\n bad_init <- valid_init\n bad_init$V <- rep(0, L) # All zeros (valid finite numerics)\n # This should pass all checks since 0 is valid for V\n params_ok <- list(L = L, model_init = bad_init)\n expect_silent(validate_init(data, params_ok))\n\n # Test 7: sigma2 must be numeric\n # Note: Similar to above - unreachable branch due to is.finite() check first\n bad_init <- valid_init\n bad_init$sigma2 <- 0 # Zero is valid\n params_ok <- list(L = L, model_init = bad_init)\n expect_silent(validate_init(data, params_ok))\n\n # Test 8: pi length must match number of columns in alpha\n bad_init <- valid_init\n bad_init$pi <- rep(1/(p-1), p - 1)\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$pi should have the same length as the number of columns in model_init\\\\$alpha\")\n\n bad_init <- valid_init\n bad_init$pi <- rep(1/(p+1), p + 1)\n params_bad <- list(L = L, model_init = bad_init)\n expect_error(validate_init(data, params_bad), \"model_init\\\\$pi should have the same length as the number of columns in model_init\\\\$alpha\")\n})\n\ntest_that(\"convert_individual_to_ss converts individual data to sufficient statistics\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5, seed = 123)\n data <- setup$data\n\n params <- list(\n unmappable_effects = \"inf\",\n verbose = FALSE\n )\n\n # Convert\n ss_data <- convert_individual_to_ss(data, params)\n\n # Check class\n expect_s3_class(ss_data, \"ss\")\n\n # Check components exist\n expect_true(all(c(\"XtX\", \"Xty\", \"yty\", \"n\", \"p\") %in% names(ss_data)))\n\n # Check dimensions\n expect_equal(dim(ss_data$XtX), c(50, 50))\n expect_length(ss_data$Xty, 50)\n expect_length(ss_data$yty, 1)\n\n # Values may be rescaled for unmappable effects\n expect_true(is.numeric(ss_data$XtX))\n expect_true(is.numeric(ss_data$Xty))\n expect_true(is.numeric(ss_data$yty))\n expect_true(ss_data$yty > 0)\n\n # Check attributes preserved\n expect_equal(ss_data$X_colmeans, attr(data$X, \"scaled:center\"))\n expect_equal(ss_data$y_mean, data$mean_y)\n expect_equal(attr(ss_data$XtX, \"d\"), attr(data$X, \"d\"))\n expect_equal(attr(ss_data$XtX, \"scaled:scale\"), attr(data$X, \"scaled:scale\"))\n\n # Check eigen decomposition added for unmappable effects\n expect_true(!is.null(ss_data$eigen_vectors))\n expect_true(!is.null(ss_data$eigen_values))\n expect_true(!is.null(ss_data$VtXty))\n})\n\ntest_that(\"extract_prior_weights extracts and rescales prior weights\", {\n p <- 100\n\n # Test: no null weight\n model_no_null <- list(\n pi = rep(1/p, p),\n null_weight = 0,\n null_index = 0\n )\n result <- extract_prior_weights(model_no_null)\n expect_equal(result, rep(1/p, p))\n\n # Test: with null weight\n null_weight <- 0.1\n null_idx <- p\n pi_vec <- c(rep((1 - null_weight)/(p - 1), p - 1), null_weight)\n model_with_null <- list(\n pi = pi_vec,\n null_weight = null_weight,\n null_index = null_idx\n )\n result <- extract_prior_weights(model_with_null)\n\n # Should extract non-null weights and rescale to sum to 1\n expect_length(result, p - 1)\n expect_equal(sum(result), 1, tolerance = 1e-10)\n expect_equal(result, rep(1/(p-1), p-1), tolerance = 1e-10)\n\n # Test: null weight provided as argument\n result_arg <- extract_prior_weights(model_with_null, null_weight = null_weight)\n expect_equal(result, result_arg)\n\n # Test: null_weight = NULL (backwards compatibility)\n model_null_weight_null <- model_no_null\n model_null_weight_null$null_weight <- NULL\n result <- extract_prior_weights(model_null_weight_null)\n expect_equal(result, rep(1/p, p))\n})\n\ntest_that(\"reconstruct_full_weights reconstructs prior weights with null component\", {\n p <- 100\n non_null_weights <- rep(1/(p-1), p-1)\n\n # Test: no null weight\n result_no_null <- reconstruct_full_weights(non_null_weights, null_weight = 0)\n expect_length(result_no_null, p - 1)\n expect_equal(sum(result_no_null), 1, tolerance = 1e-10)\n expect_equal(result_no_null, non_null_weights, tolerance = 1e-10)\n\n # Test: with null weight\n null_weight <- 0.1\n result_with_null <- reconstruct_full_weights(non_null_weights, null_weight = null_weight)\n expect_length(result_with_null, p)\n expect_equal(sum(result_with_null), 1, tolerance = 1e-10)\n expect_equal(result_with_null[p], null_weight, tolerance = 1e-10)\n expect_equal(sum(result_with_null[1:(p-1)]), 1 - null_weight, tolerance = 1e-10)\n\n # Test: null_weight = NULL\n result_null <- reconstruct_full_weights(non_null_weights, null_weight = NULL)\n expect_equal(sum(result_null), 1, tolerance = 1e-10)\n})\n\ntest_that(\"validate_and_override_params validates and adjusts parameters\", {\n # Valid params\n valid_params <- list(\n L = 10,\n prior_tol = 1e-9,\n residual_variance_upperbound = 1e10,\n scaled_prior_variance = 0.2,\n unmappable_effects = \"none\",\n convergence_method = \"elbo\",\n estimate_prior_variance = TRUE,\n estimate_prior_method = \"EM\",\n estimate_residual_method = \"MLE\",\n estimate_residual_variance = TRUE,\n refine = FALSE,\n alpha0 = 0.1,\n beta0 = 0.1,\n n = 100\n )\n\n result <- validate_and_override_params(valid_params)\n expect_equal(result$prior_tol, 1e-9)\n expect_false(result$use_NIG)\n\n # Test: invalid prior_tol\n bad_params <- valid_params\n bad_params$prior_tol <- -1\n expect_error(validate_and_override_params(bad_params), \"prior_tol must be non-negative\")\n\n bad_params$prior_tol <- c(1e-9, 1e-8)\n expect_error(validate_and_override_params(bad_params), \"prior_tol must be a numeric scalar\")\n\n # Test: invalid residual_variance_upperbound (negative value)\n bad_params <- valid_params\n bad_params$residual_variance_upperbound <- -1\n expect_error(validate_and_override_params(bad_params), \"must be positive\")\n\n # Test: residual_variance_upperbound must be a numeric scalar (not a vector)\n bad_params <- valid_params\n bad_params$residual_variance_upperbound <- c(1e10, 1e11)\n expect_error(validate_and_override_params(bad_params), \"residual_variance_upperbound must be a numeric scalar\")\n\n # Test: residual_variance_upperbound must be numeric (not character)\n bad_params <- valid_params\n bad_params$residual_variance_upperbound <- \"1e10\"\n expect_error(validate_and_override_params(bad_params), \"residual_variance_upperbound must be a numeric scalar\")\n\n # Test: invalid scaled_prior_variance\n bad_params <- valid_params\n bad_params$scaled_prior_variance <- -0.1\n expect_error(validate_and_override_params(bad_params), \"should be positive\")\n\n # Test: invalid unmappable_effects\n bad_params <- valid_params\n bad_params$unmappable_effects <- \"invalid\"\n expect_error(validate_and_override_params(bad_params), \"must be one of\")\n\n # Test: unmappable effects overrides convergence method\n inf_params <- valid_params\n inf_params$unmappable_effects <- \"inf\"\n inf_params$convergence_method <- \"elbo\"\n expect_message(\n result <- validate_and_override_params(inf_params),\n \"Setting convergence_method='pip'\"\n )\n expect_equal(result$convergence_method, \"pip\")\n\n # Test: refine incompatible with unmappable effects\n refine_params <- valid_params\n refine_params$unmappable_effects <- \"inf\"\n refine_params$refine <- TRUE\n expect_error(\n validate_and_override_params(refine_params),\n \"Refinement is not supported with unmappable effects\"\n )\n\n # Test: NIG overrides convergence method when L > 1\n nig_params <- valid_params\n nig_params$L <- 10\n nig_params$estimate_residual_method <- \"NIG\"\n nig_params$convergence_method <- \"elbo\"\n nig_params$estimate_prior_method <- \"simple\"\n\n expect_message(\n result <- validate_and_override_params(nig_params),\n \"PIP convergence\"\n )\n expect_message(\n result <- validate_and_override_params(nig_params),\n \"EM\"\n )\n\n expect_true(result$use_NIG)\n expect_equal(result$convergence_method, \"pip\")\n expect_equal(result$estimate_prior_method, \"EM\")\n\n # Test: NIG does NOT override convergence method when L = 1\n # (ELBO is well-defined for single-effect models)\n nig_params_l1 <- valid_params\n nig_params_l1$L <- 1\n nig_params_l1$estimate_residual_method <- \"NIG\"\n nig_params_l1$convergence_method <- \"elbo\"\n nig_params_l1$estimate_prior_method <- \"EM\"\n\n result_l1 <- validate_and_override_params(nig_params_l1)\n\n expect_true(result_l1$use_NIG)\n expect_equal(result_l1$convergence_method, \"elbo\") # Not overridden\n expect_equal(result_l1$estimate_prior_method, \"EM\")\n\n # Test: NIG overrides estimate_residual_variance = FALSE\n nig_erv_params <- valid_params\n nig_erv_params$estimate_residual_method <- \"NIG\"\n nig_erv_params$estimate_residual_variance <- FALSE\n nig_erv_params$estimate_prior_method <- \"EM\"\n\n expect_message(\n result <- validate_and_override_params(nig_erv_params),\n \"estimate_residual_variance = TRUE\"\n )\n expect_true(result$estimate_residual_variance)\n\n # Test: NIG with explicit estimate_residual_variance = TRUE produces no warning\n nig_erv_params2 <- valid_params\n nig_erv_params2$estimate_residual_method <- \"NIG\"\n nig_erv_params2$estimate_residual_variance <- TRUE\n nig_erv_params2$estimate_prior_method <- \"EM\"\n\n # Should not produce the \"estimate_residual_variance\" warning\n expect_no_message(\n result <- validate_and_override_params(nig_erv_params2),\n message = \"integrates out residual variance\"\n )\n expect_true(result$estimate_residual_variance)\n\n # Test: estimate_prior_variance = FALSE\n no_est_params <- valid_params\n no_est_params$estimate_prior_variance <- FALSE\n result <- validate_and_override_params(no_est_params)\n expect_equal(result$estimate_prior_method, \"none\")\n\n # Test: NIG with estimate_prior_variance = FALSE respects user choice\n # The EM override should NOT happen when user explicitly disables prior variance estimation\n nig_no_prior_params <- valid_params\n nig_no_prior_params$estimate_residual_method <- \"NIG\"\n nig_no_prior_params$estimate_prior_variance <- FALSE\n nig_no_prior_params$estimate_prior_method <- \"optim\"\n\n result <- validate_and_override_params(nig_no_prior_params)\n expect_true(result$use_NIG)\n # estimate_prior_variance = FALSE -> estimate_prior_method stays \"none\" (set earlier)\n # The SS block should NOT override to \"EM\" because estimation is disabled\n expect_equal(result$estimate_prior_method, \"none\")\n\n # Test: NIG with estimate_prior_variance = TRUE overrides to EM\n nig_yes_prior_params <- valid_params\n nig_yes_prior_params$estimate_residual_method <- \"NIG\"\n nig_yes_prior_params$estimate_prior_variance <- TRUE\n nig_yes_prior_params$estimate_prior_method <- \"simple\"\n\n expect_message(\n result <- validate_and_override_params(nig_yes_prior_params),\n \"EM\"\n )\n expect_true(result$use_NIG)\n expect_equal(result$estimate_prior_method, \"EM\")\n\n # Test: NIG rejects alpha0 = 0 (reproduces GitHub issue: L=1,\n # alpha0 = 0, beta0 > 0 previously produced an infinite ELBO crash)\n nig_bad_alpha <- valid_params\n nig_bad_alpha$estimate_residual_method <- \"NIG\"\n nig_bad_alpha$alpha0 <- 0\n nig_bad_alpha$beta0 <- 0.5\n expect_error(\n validate_and_override_params(nig_bad_alpha),\n \"alpha0 > 0 and beta0 > 0\"\n )\n\n # Test: NIG rejects alpha0 = 0, beta0 = 0 (previously produced\n # a silent NaN ELBO rather than a proper error)\n nig_both_zero <- valid_params\n nig_both_zero$estimate_residual_method <- \"NIG\"\n nig_both_zero$alpha0 <- 0\n nig_both_zero$beta0 <- 0\n expect_error(\n validate_and_override_params(nig_both_zero),\n \"alpha0 > 0 and beta0 > 0\"\n )\n\n # Test: NIG rejects negative alpha0\n nig_neg_alpha <- valid_params\n nig_neg_alpha$estimate_residual_method <- \"NIG\"\n nig_neg_alpha$alpha0 <- -0.5\n nig_neg_alpha$beta0 <- 1\n expect_error(\n validate_and_override_params(nig_neg_alpha),\n \"alpha0 > 0 and beta0 > 0\"\n )\n\n # Test: NIG rejects negative beta0\n nig_neg_beta <- valid_params\n nig_neg_beta$estimate_residual_method <- \"NIG\"\n nig_neg_beta$alpha0 <- 1\n nig_neg_beta$beta0 <- -0.5\n expect_error(\n validate_and_override_params(nig_neg_beta),\n \"alpha0 > 0 and beta0 > 0\"\n )\n\n # Test: NIG rejects non-finite alpha0/beta0\n nig_inf <- valid_params\n nig_inf$estimate_residual_method <- \"NIG\"\n nig_inf$alpha0 <- Inf\n expect_error(\n validate_and_override_params(nig_inf),\n \"alpha0 > 0 and beta0 > 0\"\n )\n\n nig_na <- valid_params\n nig_na$estimate_residual_method <- \"NIG\"\n nig_na$alpha0 <- NA_real_\n expect_error(\n validate_and_override_params(nig_na),\n \"alpha0 > 0 and beta0 > 0\"\n )\n\n # Test: NIG rejects non-scalar alpha0/beta0\n nig_vec <- valid_params\n nig_vec$estimate_residual_method <- \"NIG\"\n nig_vec$alpha0 <- c(0.1, 0.2)\n expect_error(\n validate_and_override_params(nig_vec),\n \"alpha0 > 0 and beta0 > 0\"\n )\n\n # Test: NIG rejects NULL alpha0/beta0 (non-numeric)\n nig_null <- valid_params\n nig_null$estimate_residual_method <- \"NIG\"\n nig_null$alpha0 <- NULL\n expect_error(\n validate_and_override_params(nig_null),\n \"alpha0 > 0 and beta0 > 0\"\n )\n\n # Test: non-NIG path does NOT validate alpha0/beta0\n # (the NIG prior is unused, so invalid values must be silently ignored)\n no_nig_bad <- valid_params\n no_nig_bad$estimate_residual_method <- \"MLE\"\n no_nig_bad$alpha0 <- 0\n no_nig_bad$beta0 <- 0\n result <- validate_and_override_params(no_nig_bad)\n expect_false(result$use_NIG)\n expect_null(result$alpha0)\n expect_null(result$beta0)\n\n # Test: NIG requires a valid sample size params$n (the default alpha0/beta0\n # scale as 1/sqrt(n), so n must be a positive finite scalar)\n nig_needs_n <- valid_params\n nig_needs_n$estimate_residual_method <- \"NIG\"\n\n # NULL n rejected\n nig_needs_n$n <- NULL\n expect_error(\n validate_and_override_params(nig_needs_n),\n \"requires a valid sample size\"\n )\n\n # Zero n rejected\n nig_needs_n$n <- 0\n expect_error(\n validate_and_override_params(nig_needs_n),\n \"requires a valid sample size\"\n )\n\n # Negative n rejected\n nig_needs_n$n <- -5\n expect_error(\n validate_and_override_params(nig_needs_n),\n \"requires a valid sample size\"\n )\n\n # Non-scalar n rejected\n nig_needs_n$n <- c(100, 200)\n expect_error(\n validate_and_override_params(nig_needs_n),\n \"requires a valid sample size\"\n )\n\n # Valid n passes\n nig_needs_n$n <- 100\n result <- suppressMessages(validate_and_override_params(nig_needs_n))\n expect_true(result$use_NIG)\n})\n\n# =============================================================================\n# MODEL INITIALIZATION\n# =============================================================================\n\ntest_that(\"initialize_matrices creates correct model matrices\", {\n n <- 100\n p <- 50\n L <- 5\n\n data <- list(n = n, p = p)\n\n params <- list(\n L = L,\n scaled_prior_variance = 0.2,\n residual_variance = 1.5,\n prior_weights = rep(1/p, p),\n null_weight = 0\n )\n\n var_y <- 2.0\n\n result <- initialize_matrices(data, params, var_y)\n\n # Check all components exist\n expected_names <- c(\"alpha\", \"mu\", \"mu2\", \"V\", \"KL\", \"lbf\",\n \"lbf_variable\", \"sigma2\", \"pi\", \"null_weight\",\n \"predictor_weights\")\n expect_true(all(expected_names %in% names(result)))\n\n # Check dimensions\n expect_equal(dim(result$alpha), c(L, p))\n expect_equal(dim(result$mu), c(L, p))\n expect_equal(dim(result$mu2), c(L, p))\n expect_equal(dim(result$lbf_variable), c(L, p))\n expect_length(result$V, L)\n expect_length(result$KL, L)\n expect_length(result$lbf, L)\n expect_length(result$predictor_weights, p)\n\n # Check initial values\n expect_equal(result$alpha, matrix(1/p, L, p))\n expect_equal(result$mu, matrix(0, L, p))\n expect_equal(result$mu2, matrix(0, L, p))\n expect_equal(result$V, rep(params$scaled_prior_variance * var_y, L))\n expect_equal(result$sigma2, params$residual_variance)\n expect_equal(result$pi, params$prior_weights)\n expect_true(all(is.na(result$KL)))\n expect_true(all(is.na(result$lbf)))\n})\n\ntest_that(\"initialize_matrices handles vector scaled_prior_variance of length L\", {\n # Regression for GitHub issue: scaled_prior_variance docs allow a length-L\n # vector, but the refactor's rep(vec * var_y, L) produced length L*L.\n n <- 100; p <- 50; L <- 5\n data <- list(n = n, p = p)\n spv <- c(0.1, 0.2, 0.3, 0.4, 0.5)\n params <- list(\n L = L,\n scaled_prior_variance = spv,\n residual_variance = 1.5,\n prior_weights = rep(1 / p, p),\n null_weight = 0\n )\n var_y <- 2.0\n\n result <- initialize_matrices(data, params, var_y)\n\n expect_length(result$V, L)\n expect_equal(result$V, spv * var_y)\n})\n\ntest_that(\"expand_scaled_prior_variance recycles scalar and preserves vector\", {\n expect_equal(expand_scaled_prior_variance(0.2, 2.0, 5), rep(0.4, 5))\n expect_equal(\n expand_scaled_prior_variance(c(0.1, 0.2, 0.3, 0.4, 0.5), 2.0, 5),\n c(0.2, 0.4, 0.6, 0.8, 1.0)\n )\n})\n\ntest_that(\"validate_and_override_params rejects wrong-length scaled_prior_variance\", {\n base_params <- list(\n prior_tol = 1e-9,\n residual_variance_upperbound = 1e4,\n scaled_prior_variance = c(0.1, 0.2, 0.3),\n L = 5,\n unmappable_effects = \"none\",\n slot_prior = NULL\n )\n expect_error(\n validate_and_override_params(base_params),\n \"scalar or a vector of length L\"\n )\n})\n\ntest_that(\"susie with vector scaled_prior_variance runs end-to-end (pcarbo example)\", {\n # Regression for GitHub issue requesting per-slot prior variances.\n # Before the fix, rep(vec * var_y, L) produced length L*L and poisoned\n # downstream state; susie_get_cs eventually raised 'get_purity returned NaN/NA'.\n set.seed(1)\n n <- 200; p <- 100\n beta <- rep(0, p); beta[1:4] <- 1\n X <- matrix(rnorm(n * p), nrow = n)\n X <- scale(X, center = TRUE, scale = TRUE)\n y <- drop(X %*% beta + rnorm(n))\n\n fit <- susie(X, y, L = 10,\n estimate_prior_variance = FALSE,\n scaled_prior_variance = rep(1, 10))\n\n expect_length(fit$V, 10)\n expect_true(all(is.finite(fit$V)))\n})\n\ntest_that(\"vector scaled_prior_variance composes with model_init L expansion\", {\n # Confirms the preserve-fitted-V behavior (from the s_init/model_init PR)\n # still applies when scaled_prior_variance is a length-L vector: the first\n # num_effects entries come from model_init$V; the rest use the user vector.\n set.seed(2)\n n <- 200; p <- 80\n beta <- rep(0, p); beta[1:3] <- 1\n X <- scale(matrix(rnorm(n * p), nrow = n), center = TRUE, scale = TRUE)\n y <- drop(X %*% beta + rnorm(n))\n\n init <- susie(X, y, L = 2, estimate_prior_variance = TRUE)\n\n L_new <- 5\n spv <- c(0.1, 0.2, 0.3, 0.4, 0.5)\n fit <- susie(X, y, L = L_new,\n estimate_prior_variance = FALSE,\n scaled_prior_variance = spv,\n model_init = init)\n\n expect_length(fit$V, L_new)\n expect_true(all(is.finite(fit$V)))\n})\n\ntest_that(\"initialize_null_index sets null index correctly\", {\n data <- list(p = 100)\n\n # Test: no null weight\n model_no_null <- list(null_weight = 0)\n result <- initialize_null_index(data, model_no_null)\n expect_equal(result, 0)\n\n model_null_null <- list(null_weight = NULL)\n result <- initialize_null_index(data, model_null_null)\n expect_equal(result, 0)\n\n # Test: with null weight\n model_with_null <- list(null_weight = 0.1)\n result <- initialize_null_index(data, model_with_null)\n expect_equal(result, data$p)\n})\n\ntest_that(\"assign_names assigns variable names to model components\", {\n p <- 10\n L <- 3\n data <- list(p = p)\n\n model <- list(\n alpha = matrix(1/p, L, p),\n mu = matrix(0, L, p),\n mu2 = matrix(0, L, p),\n lbf_variable = matrix(0, L, p),\n pip = rep(0.1, p),\n null_weight = NULL\n )\n\n variable_names <- paste0(\"var\", 1:p)\n\n # Test: without null weight\n result <- assign_names(data, model, variable_names)\n expect_equal(names(result$pip), variable_names)\n expect_equal(colnames(result$alpha), variable_names)\n expect_equal(colnames(result$mu), variable_names)\n expect_equal(colnames(result$mu2), variable_names)\n expect_equal(colnames(result$lbf_variable), variable_names)\n\n # Test: with null weight\n model$null_weight <- 0.1\n model$null_index <- p\n model$pip <- rep(0.1, p - 1)\n variable_names_with_null <- c(paste0(\"var\", 1:(p-1)), \"null_placeholder\")\n\n result <- assign_names(data, model, variable_names_with_null)\n expect_equal(names(result$pip), paste0(\"var\", 1:(p-1)))\n expect_equal(colnames(result$alpha)[p], \"null\")\n\n # Test: NULL variable names\n result_null <- assign_names(data, model, NULL)\n expect_null(names(result_null$pip))\n})\n\ntest_that(\"adjust_L adjusts number of effects correctly\", {\n p <- 50\n L_requested <- 10\n num_effects_init <- 5\n var_y <- 2.0\n\n model_init_pruned <- list(\n alpha = matrix(1/p, num_effects_init, p),\n mu = matrix(0, num_effects_init, p),\n mu2 = matrix(0, num_effects_init, p),\n V = rep(1, num_effects_init)\n )\n\n params <- list(\n L = L_requested,\n scaled_prior_variance = 0.2\n )\n\n # Test: L > num_effects (should expand)\n result <- adjust_L(params, model_init_pruned, var_y)\n expect_equal(result$L, L_requested)\n expect_equal(nrow(result$model_init$alpha), L_requested)\n\n # Test: L < num_effects (should warn and use num_effects)\n params_small <- params\n params_small$L <- 3\n\n expect_message(\n result <- adjust_L(params_small, model_init_pruned, var_y),\n \"is smaller than the\"\n )\n expect_equal(result$L, num_effects_init)\n})\n\ntest_that(\"prune_single_effects expands or filters model effects\", {\n p <- 50\n L_init <- 10\n\n model_init <- list(\n alpha = matrix(1/p, L_init, p),\n mu = matrix(0, L_init, p),\n mu2 = matrix(0, L_init, p),\n lbf_variable = matrix(0, L_init, p),\n KL = rep(1, L_init),\n lbf = rep(0, L_init),\n V = rep(1, L_init),\n sets = list(cs_index = c(1, 3, 5))\n )\n\n # Test: L == num_effects (just removes sets)\n result_same <- prune_single_effects(model_init, L = L_init, V = NULL)\n expect_equal(nrow(result_same$alpha), L_init)\n expect_null(result_same$sets)\n\n # Test: expand to larger L with vector V (length(V) > 1)\n L_expand <- 15\n V_expand <- rep(2, L_expand)\n result_expand <- prune_single_effects(model_init, L = L_expand, V = V_expand)\n expect_equal(nrow(result_expand$alpha), L_expand)\n expect_equal(result_expand$V[1:L_init], rep(1, L_init))\n expect_equal(result_expand$V[(L_init+1):L_expand], rep(2, L_expand - L_init))\n\n # Test: expand to larger L with scalar V (length(V) == 1)\n # This tests the else branch: V <- rep(V, L)\n L_expand_scalar <- 12\n V_scalar <- 3 # Single value\n result_expand_scalar <- prune_single_effects(model_init, L = L_expand_scalar, V = V_scalar)\n expect_equal(nrow(result_expand_scalar$alpha), L_expand_scalar)\n # When V is scalar, it gets replicated to length L\n expect_equal(result_expand_scalar$V, rep(V_scalar, L_expand_scalar))\n expect_length(result_expand_scalar$V, L_expand_scalar)\n # All V values should be the same scalar value\n expect_true(all(result_expand_scalar$V == V_scalar))\n})\n\ntest_that(\"add_null_effect adds null effect to model\", {\n p <- 50\n L <- 5\n\n model_init <- list(\n alpha = matrix(1/p, L, p),\n mu = matrix(0, L, p),\n mu2 = matrix(0, L, p),\n lbf_variable = matrix(0, L, p),\n V = rep(1, L)\n )\n\n V_null <- 0\n\n result <- add_null_effect(model_init, V_null)\n\n # Check dimensions increased\n expect_equal(nrow(result$alpha), L + 1)\n expect_equal(nrow(result$mu), L + 1)\n expect_equal(nrow(result$mu2), L + 1)\n expect_equal(nrow(result$lbf_variable), L + 1)\n expect_length(result$V, L + 1)\n\n # Check null effect values\n expect_equal(result$alpha[L + 1, ], rep(1/p, p))\n expect_equal(result$mu[L + 1, ], rep(0, p))\n expect_equal(result$mu2[L + 1, ], rep(0, p))\n expect_equal(result$lbf_variable[L + 1, ], rep(0, p))\n expect_equal(result$V[L + 1], V_null)\n})\n\n# =============================================================================\n# CORE ALGORITHM COMPONENTS\n# =============================================================================\n\ntest_that(\"compute_eigen_decomposition computes eigenvalues and eigenvectors\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 456)\n XtX <- crossprod(base_data$X)\n\n result <- compute_eigen_decomposition(XtX, base_data$n)\n\n # Check components\n expect_true(all(c(\"V\", \"Dsq\", \"VtXty\") %in% names(result)))\n expect_equal(dim(result$V), c(base_data$p, base_data$p))\n expect_length(result$Dsq, base_data$p)\n expect_null(result$VtXty)\n\n # Check eigenvalues in decreasing order\n expect_true(all(diff(result$Dsq) <= 0))\n\n # Check eigenvalues are non-negative\n expect_true(all(result$Dsq >= 0))\n\n # Verify decomposition\n LD <- XtX / base_data$n\n eig_direct <- eigen(LD, symmetric = TRUE)\n expect_equal(result$Dsq, sort(eig_direct$values * base_data$n, decreasing = TRUE), tolerance = 1e-10)\n})\n\ntest_that(\"add_eigen_decomposition adds eigen components to data object\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 789)\n\n XtX <- crossprod(base_data$X)\n Xty <- as.vector(crossprod(base_data$X, base_data$y))\n yty <- sum(base_data$y^2)\n\n data <- list(\n XtX = XtX,\n Xty = Xty,\n yty = yty,\n n = base_data$n,\n p = base_data$p\n )\n\n params <- list(\n unmappable_effects = \"inf\",\n verbose = FALSE\n )\n\n result <- add_eigen_decomposition(data, params)\n\n # Check components added\n expect_true(!is.null(result$eigen_vectors))\n expect_true(!is.null(result$eigen_values))\n expect_true(!is.null(result$VtXty))\n\n # Check dimensions\n expect_equal(dim(result$eigen_vectors), c(base_data$p, base_data$p))\n expect_length(result$eigen_values, base_data$p)\n expect_length(result$VtXty, base_data$p)\n expect_true(all(is.finite(result$VtXty)))\n\n # Test with unmappable_effects = \"none\" (no scaling)\n params_none <- list(unmappable_effects = \"none\", verbose = FALSE)\n result_none <- add_eigen_decomposition(data, params_none)\n expect_true(!is.null(result_none$eigen_vectors))\n\n # Test with unmappable_effects = \"ash\" (no raw data storage needed)\n params_ash <- list(unmappable_effects = \"ash\", verbose = FALSE)\n\n result_ash <- add_eigen_decomposition(data, params_ash)\n expect_true(!is.null(result_ash$eigen_vectors))\n expect_true(!is.null(result_ash$eigen_values))\n expect_true(!is.null(result_ash$VtXty))\n})\n\ntest_that(\"compute_omega_quantities computes omega-weighted quantities\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 111)\n XtX <- crossprod(base_data$X)\n\n eigen_decomp <- compute_eigen_decomposition(XtX, base_data$n)\n\n data <- list(\n eigen_vectors = eigen_decomp$V,\n eigen_values = eigen_decomp$Dsq,\n p = base_data$p\n )\n\n tau2 <- 0.01\n sigma2 <- 1.0\n\n result <- compute_omega_quantities(data, tau2, sigma2)\n\n # Check components\n expect_true(all(c(\"omega_var\", \"diagXtOmegaX\") %in% names(result)))\n expect_length(result$omega_var, base_data$p)\n expect_length(result$diagXtOmegaX, base_data$p)\n\n # Check omega_var calculation\n expected_omega_var <- tau2 * data$eigen_values + sigma2\n expect_equal(result$omega_var, expected_omega_var, tolerance = 1e-10)\n\n # Check diagXtOmegaX is positive\n expect_true(all(result$diagXtOmegaX > 0))\n\n # Check diagXtOmegaX sums correctly\n # Should be trace of X'OmegaX\n trace_approx <- sum(result$diagXtOmegaX)\n expect_true(trace_approx > 0)\n})\n\ntest_that(\"compute_theta_blup computes BLUP coefficients\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 222)\n L <- 5\n\n XtX <- crossprod(base_data$X)\n Xty <- as.vector(crossprod(base_data$X, base_data$y))\n\n eigen_decomp <- compute_eigen_decomposition(XtX, base_data$n)\n\n data <- list(\n eigen_vectors = eigen_decomp$V,\n eigen_values = eigen_decomp$Dsq,\n VtXty = crossprod(eigen_decomp$V, Xty),\n p = base_data$p\n )\n\n model <- list(\n alpha = matrix(1/base_data$p, L, base_data$p),\n mu = matrix(rnorm(L * base_data$p, 0, 0.1), L, base_data$p),\n tau2 = 0.01,\n sigma2 = 1.0\n )\n\n result <- compute_theta_blup(data, model)\n\n # Check output\n expect_length(result, base_data$p)\n\n # Check finite values\n expect_true(all(is.finite(result)))\n\n # When tau2 = 0, theta should be 0\n model_zero_tau2 <- model\n model_zero_tau2$tau2 <- 0\n result_zero <- compute_theta_blup(data, model_zero_tau2)\n expect_true(all(abs(as.vector(result_zero)) < 1e-10))\n})\n\ntest_that(\"lbf_stabilization stabilizes log Bayes factors\", {\n p <- 100\n lbf <- rnorm(p, mean = 5, sd = 2)\n prior_weights <- rep(1/p, p)\n shat2 <- rgamma(p, shape = 2, rate = 1)\n\n result <- lbf_stabilization(lbf, prior_weights, shat2)\n\n # Check components\n expect_true(all(c(\"lbf\", \"lpo\") %in% names(result)))\n expect_length(result$lbf, p)\n expect_length(result$lpo, p)\n\n # Check lpo calculation\n expected_lpo <- lbf + log(prior_weights + sqrt(.Machine$double.eps))\n expect_equal(result$lpo, expected_lpo, tolerance = 1e-10)\n\n # Test with infinite shat2\n shat2_inf <- shat2\n shat2_inf[c(1, 5, 10)] <- Inf\n\n result_inf <- lbf_stabilization(lbf, prior_weights, shat2_inf)\n\n # LBF should be 0 where shat2 is infinite\n expect_equal(result_inf$lbf[c(1, 5, 10)], rep(0, 3))\n\n # LPO should be log(prior) where shat2 is infinite\n expected_lpo_inf <- log(prior_weights[c(1, 5, 10)] + sqrt(.Machine$double.eps))\n expect_equal(result_inf$lpo[c(1, 5, 10)], expected_lpo_inf, tolerance = 1e-10)\n})\n\ntest_that(\"compute_posterior_weights computes alpha and lbf_model\", {\n p <- 100\n lbf <- rnorm(p, mean = 5, sd = 2)\n prior_weights <- rep(1/p, p)\n lpo <- lbf + log(prior_weights)\n\n result <- compute_posterior_weights(lpo)\n\n # Check components\n expect_true(all(c(\"alpha\", \"lbf_model\") %in% names(result)))\n expect_length(result$alpha, p)\n expect_length(result$lbf_model, 1)\n\n # Check alpha sums to 1\n expect_equal(sum(result$alpha), 1, tolerance = 1e-10)\n\n # Check alpha values are probabilities\n expect_true(all(result$alpha >= 0))\n expect_true(all(result$alpha <= 1))\n\n # Verify calculation\n max_lpo <- max(lpo)\n w_weighted <- exp(lpo - max_lpo)\n weighted_sum_w <- sum(w_weighted)\n expected_alpha <- w_weighted / weighted_sum_w\n expected_lbf_model <- log(weighted_sum_w) + max_lpo\n\n expect_equal(result$alpha, expected_alpha, tolerance = 1e-10)\n expect_equal(result$lbf_model, expected_lbf_model, tolerance = 1e-10)\n\n # Test numerical stability with very large lpo\n lpo_large <- c(1000, 1001, 1002, rep(0, p - 3))\n result_large <- compute_posterior_weights(lpo_large)\n expect_equal(sum(result_large$alpha), 1, tolerance = 1e-10)\n expect_true(all(result_large$alpha >= 0 & result_large$alpha <= 1))\n})\n\ntest_that(\"compute_lbf_gradient computes gradient for prior variance\", {\n p <- 100\n alpha <- rep(1/p, p)\n betahat <- rnorm(p, mean = 0, sd = 1)\n shat2 <- rgamma(p, shape = 2, rate = 1)\n V <- 1.0\n\n result <- compute_lbf_gradient(alpha, betahat, shat2, V, use_NIG = FALSE)\n\n # Check output is numeric scalar\n expect_length(result, 1)\n expect_true(is.finite(result))\n\n # Test with different V values\n result_small_V <- compute_lbf_gradient(alpha, betahat, shat2, V = 0.1, use_NIG = FALSE)\n result_large_V <- compute_lbf_gradient(alpha, betahat, shat2, V = 10, use_NIG = FALSE)\n\n expect_true(is.finite(result_small_V))\n expect_true(is.finite(result_large_V))\n\n # Test with NIG (should return NULL)\n result_nig <- compute_lbf_gradient(alpha, betahat, shat2, V, use_NIG = TRUE)\n expect_null(result_nig)\n\n # Test with NaN in intermediate calculations (should handle)\n shat2_zero <- rep(0, p)\n betahat_zero <- rep(0, p)\n result_nan <- compute_lbf_gradient(alpha, betahat_zero, shat2_zero, V, use_NIG = FALSE)\n expect_true(is.finite(result_nan))\n})\n\n# =============================================================================\n# VARIANCE ESTIMATION\n# =============================================================================\n\ntest_that(\"mom_unmappable estimates variance using method of moments\", {\n # Setup test data\n setup <- setup_ss_data(n = 100, p = 50, L = 5, seed = 333, unmappable_effects = \"inf\")\n data <- setup$data\n params <- setup$params\n params$verbose <- FALSE\n model <- setup$model\n\n # Compute omega\n L <- nrow(model$alpha)\n omega_res <- compute_omega_quantities(data, model$tau2, model$sigma2)\n omega <- matrix(0, L, data$p)\n for (l in seq_len(L)) {\n omega[l, ] <- omega_res$diagXtOmegaX + 1 / model$V[l]\n }\n\n # Test estimating both tau2 and sigma2\n result <- mom_unmappable(data, params, model, omega, tau2 = model$tau2,\n est_tau2 = TRUE, est_sigma2 = TRUE)\n\n expect_true(all(c(\"sigma2\", \"tau2\") %in% names(result)))\n expect_true(result$sigma2 > 0)\n expect_true(result$tau2 >= 0)\n\n # Test estimating only sigma2\n result_sigma_only <- mom_unmappable(data, params, model, omega, tau2 = 0.01,\n est_tau2 = FALSE, est_sigma2 = TRUE)\n expect_true(result_sigma_only$sigma2 > 0)\n expect_equal(result_sigma_only$tau2, 0.01)\n\n # Test verbose message when estimating both tau2 and sigma2\n params_verbose <- params\n params_verbose$verbose <- TRUE\n expect_message(\n result_verbose_both <- mom_unmappable(data, params_verbose, model, omega,\n tau2 = model$tau2,\n est_tau2 = TRUE, est_sigma2 = TRUE),\n \"Update \\\\(sigma\\\\^2,tau\\\\^2\\\\) to\"\n )\n expect_true(all(c(\"sigma2\", \"tau2\") %in% names(result_verbose_both)))\n\n # Test verbose message when estimating only sigma2\n expect_message(\n result_verbose_sigma <- mom_unmappable(data, params_verbose, model, omega,\n tau2 = 0.01,\n est_tau2 = FALSE, est_sigma2 = TRUE),\n \"Update sigma\\\\^2 to\"\n )\n expect_true(result_verbose_sigma$sigma2 > 0)\n expect_equal(result_verbose_sigma$tau2, 0.01)\n})\n\ntest_that(\"mle_unmappable estimates variance using MLE\", {\n # Setup test data\n setup <- setup_ss_data(n = 100, p = 50, L = 5, seed = 444, unmappable_effects = \"inf\")\n data <- setup$data\n params <- setup$params\n params$verbose <- FALSE\n model <- setup$model\n\n # Compute omega\n L <- nrow(model$alpha)\n omega_res <- compute_omega_quantities(data, model$tau2, model$sigma2)\n omega <- matrix(0, L, data$p)\n for (l in seq_len(L)) {\n omega[l, ] <- omega_res$diagXtOmegaX + 1 / model$V[l]\n }\n\n # Test estimating both tau2 and sigma2\n result <- mle_unmappable(data, params, model, omega,\n est_tau2 = TRUE, est_sigma2 = TRUE)\n\n expect_true(all(c(\"sigma2\", \"tau2\") %in% names(result)))\n expect_true(result$sigma2 > 0)\n expect_true(result$tau2 >= 0)\n\n # Test estimating only sigma2\n result_sigma_only <- mle_unmappable(data, params, model, omega,\n est_tau2 = FALSE, est_sigma2 = TRUE)\n expect_true(result_sigma_only$sigma2 > 0)\n\n # Test verbose message when estimating both tau2 and sigma2\n params_verbose <- params\n params_verbose$verbose <- TRUE\n expect_message(\n result_verbose_both <- mle_unmappable(data, params_verbose, model, omega,\n est_tau2 = TRUE, est_sigma2 = TRUE),\n \"Update \\\\(sigma\\\\^2,tau\\\\^2\\\\) to\"\n )\n expect_true(all(c(\"sigma2\", \"tau2\") %in% names(result_verbose_both)))\n\n # Test verbose message when estimating only sigma2\n expect_message(\n result_verbose_sigma <- mle_unmappable(data, params_verbose, model, omega,\n est_tau2 = FALSE, est_sigma2 = TRUE),\n \"Update sigma\\\\^2 to\"\n )\n expect_true(result_verbose_sigma$sigma2 > 0)\n})\n\ntest_that(\"compute_lbf_NIG_univariate computes log Bayes factor\", {\n set.seed(555)\n n <- 100\n x <- rnorm(n)\n y <- 2 * x + rnorm(n)\n s0 <- 1\n alpha0 <- 0\n beta0 <- 0\n\n result <- compute_lbf_NIG_univariate(x, y, s0, alpha0, beta0)\n\n # Check output is numeric scalar\n expect_length(result, 1)\n expect_true(is.finite(result))\n\n # LBF should be positive when there's signal\n expect_true(result > 0)\n\n # Test with no signal\n x_null <- rnorm(n)\n y_null <- rnorm(n)\n result_null <- compute_lbf_NIG_univariate(x_null, y_null, s0, alpha0, beta0)\n expect_true(is.finite(result_null))\n\n # Test with different prior parameters\n result_alpha <- compute_lbf_NIG_univariate(x, y, s0, alpha0 = 2, beta0 = 1)\n expect_true(is.finite(result_alpha))\n})\n\ntest_that(\"posterior_mean_NIG computes posterior mean\", {\n set.seed(666)\n p <- 50\n xtx <- 100\n xty <- 50\n s0_t <- 1\n\n result <- posterior_mean_NIG(xtx, xty, s0_t)\n\n # Check output is numeric\n expect_length(result, 1)\n expect_true(is.finite(result))\n\n # Posterior mean should be shrunk toward zero\n ols_est <- xty / xtx\n expect_true(abs(result) < abs(ols_est))\n\n # Test with very small prior (strong shrinkage)\n result_small <- posterior_mean_NIG(xtx, xty, s0_t = 0.01)\n expect_true(abs(result_small) < abs(result))\n})\n\ntest_that(\"posterior_var_NIG computes posterior variance\", {\n set.seed(777)\n xtx <- 100\n xty <- 50\n yty <- 1000\n n <- 100\n s0_t <- 1\n\n result <- posterior_var_NIG(xtx, xty, yty, n, s0_t)\n\n # Check components\n expect_true(all(c(\"post_var\", \"beta1\") %in% names(result)))\n expect_true(is.finite(result$post_var))\n expect_true(is.finite(result$beta1))\n\n # Posterior variance should be positive\n expect_true(result$post_var > 0)\n\n # Test with very small prior (should return 0)\n result_small <- posterior_var_NIG(xtx, xty, yty, n, s0_t = 1e-6)\n expect_equal(result_small$post_var, 0)\n expect_equal(result_small$beta1, 0)\n})\n\ntest_that(\"est_residual_variance estimates residual variance\", {\n # Setup individual data\n setup <- setup_individual_data(n = 100, p = 50, L = 5, seed = 888)\n data <- setup$data\n model <- setup$model\n\n result <- est_residual_variance(data, model)\n\n # Check output is numeric and positive\n expect_length(result, 1)\n expect_true(is.finite(result))\n expect_true(result > 0)\n\n # Should be reasonable for random data\n expect_true(result < 10) \n})\n\ntest_that(\"update_model_variance updates variance components\", {\n # Setup individual data with all necessary methods defined\n setup <- setup_individual_data(n = 100, p = 50, L = 5, seed = 999)\n data <- setup$data\n params <- setup$params\n params$estimate_residual_variance <- TRUE\n params$estimate_residual_method <- \"MLE\"\n params$residual_variance_lowerbound <- 0.01\n params$residual_variance_upperbound <- 10\n params$unmappable_effects <- \"none\"\n model <- setup$model\n\n old_sigma2 <- model$sigma2\n\n result <- update_model_variance(data, params, model)\n\n # Check sigma2 was updated\n expect_true(\"sigma2\" %in% names(result))\n\n # Check sigma2 is within bounds\n expect_true(result$sigma2 >= params$residual_variance_lowerbound)\n expect_true(result$sigma2 <= params$residual_variance_upperbound)\n\n # Check it's finite and positive\n expect_true(is.finite(result$sigma2))\n expect_true(result$sigma2 > 0)\n})\n\n# =============================================================================\n# CONVERGENCE & OPTIMIZATION\n# =============================================================================\n\ntest_that(\"check_convergence detects convergence correctly\", {\n p <- 50\n L <- 5\n\n params <- list(\n convergence_method = \"elbo\",\n tol = 1e-4,\n verbose = FALSE\n )\n\n model <- list(\n alpha = matrix(1/p, L, p),\n runtime = list(\n prev_elbo = -1000,\n prev_alpha = matrix(1/p, L, p),\n prev_pip_diff = NULL\n )\n )\n\n # Test: first iteration (should not converge)\n result_iter1 <- check_convergence(NULL, params, model, elbo = c(-1000, -999),\n iter = 1)\n expect_false(result_iter1$converged)\n\n # Test: ELBO converged\n elbo_converged <- c(-1000, -999.99)\n result_elbo_conv <- check_convergence(NULL, params, model, elbo = elbo_converged,\n iter = 2)\n expect_true(result_elbo_conv$converged)\n\n # Test: ELBO not converged\n model$runtime$prev_elbo <- -1000\n elbo_not_conv <- c(NA, NA, -990)\n result_elbo_not <- check_convergence(NULL, params, model, elbo = elbo_not_conv,\n iter = 2)\n expect_false(result_elbo_not$converged)\n\n # Test: PIP convergence\n params_pip <- list(\n convergence_method = \"pip\",\n tol = 1e-4,\n verbose = FALSE\n )\n\n # PIP converged (alpha unchanged)\n result_pip_conv <- check_convergence(NULL, params_pip, model, elbo = c(-1000, -999),\n iter = 2)\n expect_true(result_pip_conv$converged)\n\n # PIP not converged (alpha changed)\n model_changed <- model\n model_changed$alpha[1, 1] <- 0.5\n result_pip_not <- check_convergence(NULL, params_pip, model_changed,\n elbo = c(-1000, -999),\n iter = 2)\n expect_false(result_pip_not$converged)\n\n # Test: ELBO is NA/Inf (fallback to PIP)\n expect_message(\n result_na <- check_convergence(NULL, params, model, elbo = c(-1000, NA),\n iter = 2),\n \"NA/infinite ELBO\"\n )\n expect_true(result_na$converged) # Alpha unchanged, so converged by PIP\n})\n\ntest_that(\"PIP convergence detects and averages short alpha cycles\", {\n alpha_a <- matrix(c(0.9, 0.1, 0.2, 0.8), nrow = 2, byrow = TRUE)\n alpha_b <- matrix(c(0.1, 0.9, 0.8, 0.2), nrow = 2, byrow = TRUE)\n model <- list(\n alpha = alpha_a,\n runtime = list(\n prev_alpha = alpha_b,\n alpha_history = list(alpha_a, alpha_b),\n pip_history = list(susie_get_pip(alpha_a), susie_get_pip(alpha_b))\n )\n )\n params <- list(tol = 1e-4, pip_stall_window = 5, prior_tol = 1e-9)\n\n result <- check_alpha_pip_cycle_convergence(NULL, params, model)\n\n expect_true(result$converged)\n expect_equal(result$convergence_reason, \"alpha_pip_cycle_2\")\n expect_equal(result$alpha, (alpha_a + alpha_b) / 2)\n})\n\ntest_that(\"get_objective computes ELBO correctly\", {\n # Setup individual data\n setup <- setup_individual_data(n = 100, p = 50, L = 5, seed = 101)\n data <- setup$data\n params <- setup$params\n params$unmappable_effects <- \"none\"\n params$verbose <- FALSE\n model <- setup$model\n model$KL <- rep(0.1, 5)\n\n result <- get_objective(data, params, model)\n\n # Check output is numeric scalar\n expect_length(result, 1)\n expect_true(is.finite(result))\n\n # ELBO should be negative for random data\n expect_true(result < 0)\n\n # Test with unmappable effects\n setup_inf <- setup_ss_data(n = 100, p = 50, L = 5, seed = 102, unmappable_effects = \"inf\")\n data_inf <- setup_inf$data\n params_inf <- setup_inf$params\n params_inf$unmappable_effects <- \"inf\"\n params_inf$verbose <- FALSE\n model_inf <- setup_inf$model\n model_inf$KL <- rep(0.1, 5)\n model_inf$lbf <- rep(0, 5)\n\n result_inf <- get_objective(data_inf, params_inf, model_inf)\n expect_length(result_inf, 1)\n expect_true(is.finite(result_inf))\n})\n\ntest_that(\"compute_elbo_inf computes ELBO for infinitesimal model\", {\n # Setup data\n setup <- setup_ss_data(n = 100, p = 50, L = 5, seed = 103, unmappable_effects = \"inf\")\n data <- setup$data\n model <- setup$model\n\n # Compute omega\n L <- nrow(model$alpha)\n omega_res <- compute_omega_quantities(data, model$tau2, model$sigma2)\n omega <- matrix(0, L, data$p)\n for (l in seq_len(L)) {\n omega[l, ] <- omega_res$diagXtOmegaX + 1 / model$V[l]\n }\n\n result <- compute_elbo_inf(\n alpha = model$alpha,\n mu = model$mu,\n omega = omega,\n lbf = rep(0, L),\n sigma2 = model$sigma2,\n tau2 = model$tau2,\n n = data$n,\n p = data$p,\n eigen_vectors = data$eigen_vectors,\n eigen_values = data$eigen_values,\n VtXty = data$VtXty,\n yty = data$yty\n )\n\n # Check output is numeric scalar\n expect_length(result, 1)\n expect_true(is.finite(result))\n\n # ELBO should be negative\n expect_true(result < 0)\n})\n\n# =============================================================================\n# CREDIBLE SETS & POST-PROCESSING\n# =============================================================================\n\ntest_that(\"n_in_CS_x counts variables in credible set\", {\n # Probability vector with clear peak\n x <- c(0.5, 0.3, 0.1, 0.05, 0.03, 0.02)\n\n # With 90% coverage, should include first 2 variables (0.5 + 0.3 = 0.8 < 0.9, add 0.1)\n result_90 <- n_in_CS_x(x, coverage = 0.9)\n expect_equal(result_90, 3)\n\n # With 95% coverage, should include more\n result_95 <- n_in_CS_x(x, coverage = 0.95)\n expect_true(result_95 >= result_90)\n\n # With 50% coverage\n result_50 <- n_in_CS_x(x, coverage = 0.5)\n expect_equal(result_50, 1)\n\n # Uniform distribution\n skip(\"Fails on Linux in CI\")\n x_uniform <- rep(1/10, 10)\n result_uniform <- n_in_CS_x(x_uniform, coverage = 0.9)\n expect_equal(result_uniform, 10) # Need all to reach 90%\n})\n\ntest_that(\"in_CS_x creates binary indicator for credible set\", {\n x <- c(0.5, 0.3, 0.1, 0.05, 0.03, 0.02)\n\n result_90 <- in_CS_x(x, coverage = 0.9)\n\n # Check output is binary\n expect_equal(sort(unique(result_90)), c(0, 1))\n expect_length(result_90, length(x))\n\n # Check correct variables included\n expect_equal(sum(result_90), n_in_CS_x(x, coverage = 0.9))\n\n # Top probability should be in CS\n expect_equal(result_90[which.max(x)], 1)\n\n # Test with different coverage\n result_50 <- in_CS_x(x, coverage = 0.5)\n expect_equal(sum(result_50), 1)\n})\n\ntest_that(\"in_CS creates credible set matrix\", {\n L <- 5\n p <- 100\n\n # Create susie object\n alpha <- matrix(0, L, p)\n for (l in 1:L) {\n alpha[l, sample(p, 1)] <- 0.6\n alpha[l, ] <- alpha[l, ] / sum(alpha[l, ]) * 0.9\n alpha[l, ] <- alpha[l, ] + 0.1 / p\n }\n\n res <- list(alpha = alpha)\n class(res) <- \"susie\"\n\n result <- in_CS(res, coverage = 0.9)\n\n # Check dimensions\n expect_equal(dim(result), c(L, p))\n\n # Check binary values\n expect_true(all(result %in% c(0, 1)))\n\n # Each row should have at least one variable\n expect_true(all(rowSums(result) > 0))\n\n # Test with just alpha matrix\n result_alpha <- in_CS(alpha, coverage = 0.9)\n expect_equal(result, result_alpha)\n})\n\ntest_that(\"n_in_CS counts variables in each credible set\", {\n L <- 5\n p <- 100\n\n alpha <- matrix(0, L, p)\n for (l in 1:L) {\n alpha[l, sample(p, 1)] <- 0.7\n alpha[l, ] <- alpha[l, ] / sum(alpha[l, ]) * 0.9\n alpha[l, ] <- alpha[l, ] + 0.1 / p\n }\n\n res <- list(alpha = alpha)\n class(res) <- \"susie\"\n\n result <- n_in_CS(res, coverage = 0.9)\n\n # Check output\n expect_length(result, L)\n expect_true(all(result > 0))\n expect_true(all(result <= p))\n\n # Should match in_CS\n cs_matrix <- in_CS(res, coverage = 0.9)\n expect_equal(result, rowSums(cs_matrix))\n})\n\ntest_that(\"get_purity computes correlation purity statistics\", {\n base_data <- generate_base_data(n = 100, p = 50, seed = 123)\n\n # Test with multiple variables\n pos <- c(1, 2, 3, 5, 8)\n result <- get_purity(pos, base_data$X, Xcorr = NULL)\n\n # Check output\n expect_length(result, 3) # min, mean, median\n expect_true(all(result >= 0))\n expect_true(all(result <= 1))\n\n # Mean should be between min and max (which is implicitly <= 1)\n expect_true(result[2] >= result[1])\n\n # Test with single variable (perfect purity)\n result_single <- get_purity(1, base_data$X, Xcorr = NULL)\n expect_equal(result_single, c(1, 1, 1))\n\n # Test with precomputed correlation\n Xcorr <- cor(base_data$X)\n result_xcorr <- get_purity(pos, base_data$X, Xcorr = Xcorr)\n expect_length(result_xcorr, 3)\n expect_true(all(result_xcorr >= 0))\n\n # Test with large set (should subsample)\n pos_large <- 1:40\n result_large <- get_purity(pos_large, base_data$X, Xcorr = NULL, n = 20)\n expect_length(result_large, 3)\n\n # Test squared correlations\n result_squared <- get_purity(pos, base_data$X, Xcorr = NULL, squared = TRUE)\n expect_length(result_squared, 3)\n expect_true(all(result_squared >= 0))\n expect_true(all(result_squared <= 1))\n})\n\n\n# =============================================================================\n# END OF TESTS\n# =============================================================================\n" }, { "path": "tests/testthat/test_susie_workhorse.R", "content": "context(\"SuSiE Workhorse - Main Orchestration\")\n\n# =============================================================================\n# BASIC FUNCTIONALITY\n# =============================================================================\n\ntest_that(\"susie_workhorse returns valid susie object\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_s3_class(result, \"susie\")\n expect_type(result, \"list\")\n})\n\ntest_that(\"susie_workhorse creates all required output fields\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n # Core posterior components\n expect_true(\"alpha\" %in% names(result))\n expect_true(\"mu\" %in% names(result))\n expect_true(\"mu2\" %in% names(result))\n expect_true(\"V\" %in% names(result))\n expect_true(\"sigma2\" %in% names(result))\n\n # Tracking components\n expect_true(\"lbf\" %in% names(result))\n expect_true(\"lbf_variable\" %in% names(result))\n expect_true(\"KL\" %in% names(result))\n\n # Output fields\n expect_true(\"elbo\" %in% names(result))\n expect_true(\"niter\" %in% names(result))\n expect_true(\"converged\" %in% names(result))\n expect_true(\"pip\" %in% names(result))\n expect_true(\"sets\" %in% names(result))\n expect_true(\"fitted\" %in% names(result))\n expect_true(\"intercept\" %in% names(result))\n})\n\ntest_that(\"susie_workhorse returns correct dimensions\", {\n n <- 100\n p <- 50\n L <- 5\n setup <- setup_individual_data(n = n, p = p, L = L)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_equal(dim(result$alpha), c(L, p))\n expect_equal(dim(result$mu), c(L, p))\n expect_equal(dim(result$mu2), c(L, p))\n expect_equal(dim(result$lbf_variable), c(L, p))\n expect_length(result$V, L)\n expect_length(result$lbf, L)\n expect_length(result$KL, L)\n expect_length(result$pip, p)\n expect_length(result$fitted, n)\n})\n\n# =============================================================================\n# CONVERGENCE BEHAVIOR\n# =============================================================================\n\ntest_that(\"susie_workhorse sets converged flag when converged\", {\n # Use simple data and loose tolerance to ensure convergence\n setup <- setup_individual_data(n = 50, p = 20, L = 3)\n setup$params$max_iter <- 100\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-2\n\n result <- susie_workhorse(setup$data, setup$params)\n\n # Should converge with enough iterations\n expect_true(\"converged\" %in% names(result))\n expect_type(result$converged, \"logical\")\n})\n\ntest_that(\"susie_workhorse warns when not converged\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 1 # Too few iterations\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-10 # Very strict tolerance\n\n # Should warn about not converging\n result <- susie_workhorse(setup$data, setup$params)\n\n # Check convergence status\n expect_false(result$converged)\n expect_equal(result$niter, 1)\n})\n\ntest_that(\"susie_workhorse tracks ELBO correctly\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_true(\"elbo\" %in% names(result))\n expect_true(all(is.finite(result$elbo)))\n expect_true(length(result$elbo) <= setup$params$max_iter)\n expect_true(length(result$elbo) > 0)\n})\n\ntest_that(\"susie_workhorse ELBO increases monotonically\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 20\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n # ELBO should be non-decreasing (allow small numerical errors)\n elbo_diff <- diff(result$elbo)\n expect_true(all(elbo_diff >= -1e-6))\n})\n\ntest_that(\"susie_workhorse records correct number of iterations\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 15\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_true(\"niter\" %in% names(result))\n expect_true(result$niter <= setup$params$max_iter)\n expect_true(result$niter > 0)\n expect_equal(result$niter, length(result$elbo))\n})\n\n# =============================================================================\n# VARIANCE ESTIMATION\n# =============================================================================\n\ntest_that(\"susie_workhorse updates residual variance when requested\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n setup$params$estimate_residual_variance <- TRUE\n setup$params$residual_variance <- 1.5 # Initial value\n\n result <- susie_workhorse(setup$data, setup$params)\n\n # Residual variance should be updated from initial value\n expect_true(result$sigma2 > 0)\n expect_true(is.finite(result$sigma2))\n})\n\ntest_that(\"susie_workhorse does not update residual variance when not requested\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n setup$params$estimate_residual_variance <- FALSE\n setup$params$residual_variance <- 2.0 # Fixed value\n\n result <- susie_workhorse(setup$data, setup$params)\n\n # Residual variance should remain at initial value\n expect_equal(result$sigma2, 2.0)\n})\n\n# =============================================================================\n# MATHEMATICAL PROPERTIES\n# =============================================================================\n\ntest_that(\"susie_workhorse maintains valid probability distributions\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n # Each row of alpha should sum to 1\n row_sums <- rowSums(result$alpha)\n expect_equal(row_sums, rep(1, 5), tolerance = 1e-10)\n\n expect_true(all(result$alpha >= 0 & result$alpha <= 1))\n})\n\ntest_that(\"susie_workhorse produces valid PIPs\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n # PIPs should be valid probabilities\n expect_true(all(result$pip >= 0))\n expect_true(all(result$pip <= 1))\n expect_true(all(is.finite(result$pip)))\n})\n\ntest_that(\"susie_workhorse V values are non-negative\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_true(all(result$V >= 0))\n expect_true(all(is.finite(result$V)))\n})\n\ntest_that(\"susie_workhorse sigma2 is positive\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_true(result$sigma2 > 0)\n expect_true(is.finite(result$sigma2))\n})\n\ntest_that(\"susie_workhorse KL divergences are non-negative\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n # KL divergence should be non-negative (allow small numerical errors)\n expect_true(all(result$KL >= -1e-6))\n expect_true(all(is.finite(result$KL)))\n})\n\n# =============================================================================\n# EDGE CASES\n# =============================================================================\n\ntest_that(\"susie_workhorse works with L=1\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 1)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_s3_class(result, \"susie\")\n expect_equal(dim(result$alpha), c(1, 50))\n expect_equal(sum(result$alpha), 1, tolerance = 1e-10)\n})\n\ntest_that(\"susie_workhorse works with small p\", {\n setup <- setup_individual_data(n = 100, p = 10, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_s3_class(result, \"susie\")\n # L should be adjusted to min(L, p)\n expect_true(nrow(result$alpha) <= 10)\n})\n\ntest_that(\"susie_workhorse works with max_iter=1\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 1\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n # Should work but likely not converge\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_s3_class(result, \"susie\")\n expect_equal(result$niter, 1)\n # With max_iter=1, may or may not converge depending on data\n})\n\n# =============================================================================\n# CONVERGENCE METHODS\n# =============================================================================\n\ntest_that(\"susie_workhorse works with ELBO convergence\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 20\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_s3_class(result, \"susie\")\n expect_true(\"elbo\" %in% names(result))\n})\n\ntest_that(\"susie_workhorse works with PIP convergence\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 20\n setup$params$convergence_method <- \"pip\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_s3_class(result, \"susie\")\n expect_true(\"pip\" %in% names(result))\n})\n\n# =============================================================================\n# REFINEMENT\n# =============================================================================\n\ntest_that(\"susie_workhorse respects refine=FALSE\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n setup$params$refine <- FALSE\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_s3_class(result, \"susie\")\n # Should complete without refinement\n})\n\ntest_that(\"susie_workhorse skips refinement when no credible sets\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 2\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-10\n setup$params$refine <- TRUE\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_s3_class(result, \"susie\")\n})\n\n# =============================================================================\n# TRACKING\n# =============================================================================\n\ntest_that(\"susie_workhorse includes tracking when track_fit=TRUE\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n setup$params$track_fit <- TRUE\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_true(\"trace\" %in% names(result))\n expect_type(result$trace, \"list\")\n})\n\ntest_that(\"susie_workhorse excludes tracking when track_fit=FALSE\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n setup$params$track_fit <- FALSE\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_false(\"trace\" %in% names(result))\n})\n\n# =============================================================================\n# MODEL INITIALIZATION\n# =============================================================================\n\ntest_that(\"susie_workhorse works without model_init\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n setup$params$model_init <- NULL\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_s3_class(result, \"susie\")\n})\n\ntest_that(\"susie_workhorse works with model_init\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 3)\n setup$params$max_iter <- 5\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n # Create an initial model\n model_init <- susie_workhorse(setup$data, setup$params)\n\n # Use it to initialize another run\n setup2 <- setup_individual_data(n = 100, p = 50, L = 3, seed = 43)\n setup2$params$max_iter <- 10\n setup2$params$convergence_method <- \"elbo\"\n setup2$params$tol <- 1e-3\n setup2$params$model_init <- model_init\n\n result <- susie_workhorse(setup2$data, setup2$params)\n\n expect_s3_class(result, \"susie\")\n})\n\n# =============================================================================\n# CREDIBLE SETS\n# =============================================================================\n\ntest_that(\"susie_workhorse computes credible sets\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 20\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_true(\"sets\" %in% names(result))\n expect_type(result$sets, \"list\")\n expect_true(\"cs\" %in% names(result$sets))\n})\n\n# =============================================================================\n# FITTED VALUES\n# =============================================================================\n\ntest_that(\"susie_workhorse computes fitted values\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_true(\"fitted\" %in% names(result))\n expect_length(result$fitted, 100)\n expect_true(all(is.finite(result$fitted)))\n})\n\ntest_that(\"susie_workhorse computes intercept when requested\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n setup$params$intercept <- TRUE\n\n result <- susie_workhorse(setup$data, setup$params)\n\n expect_true(\"intercept\" %in% names(result))\n expect_true(is.finite(result$intercept))\n})\n\n# =============================================================================\n# SIGNAL RECOVERY ON SIMULATED DATA\n# =============================================================================\n\ntest_that(\"susie_workhorse recovers true signal on simple simulated data\", {\n # Generate data with known causal variables\n set.seed(123)\n n <- 200\n p <- 100\n k <- 3 # Number of causal variables\n\n X <- matrix(rnorm(n * p), n, p)\n beta <- rep(0, p)\n causal_idx <- c(10, 30, 50)\n beta[causal_idx] <- c(2, -2, 1.5)\n y <- drop(X %*% beta + rnorm(n, sd = 0.5))\n\n # Prepare data\n X <- set_X_attributes(X, center = TRUE, scale = TRUE)\n mean_y <- mean(y)\n y <- y - mean_y\n\n data <- structure(\n list(X = X, y = y, n = n, p = p, mean_y = mean_y),\n class = \"individual\"\n )\n\n params <- list(\n L = 5,\n intercept = TRUE,\n standardize = TRUE,\n estimate_residual_variance = TRUE,\n estimate_prior_variance = TRUE,\n estimate_prior_method = \"optim\",\n unmappable_effects = \"none\",\n use_NIG = FALSE,\n compute_univariate_zscore = TRUE,\n coverage = 0.95,\n min_abs_corr = 0.5,\n n_purity = 100,\n check_null_threshold = 0.1,\n scaled_prior_variance = 0.2,\n prior_weights = rep(1/p, p),\n null_weight = 0,\n residual_variance = NULL,\n track_fit = FALSE,\n prior_tol = 1e-9,\n max_iter = 100,\n convergence_method = \"elbo\",\n tol = 1e-3,\n refine = FALSE,\n model_init = NULL,\n verbose = FALSE\n )\n\n result <- susie_workhorse(data, params)\n\n # Check that causal variables have high PIPs\n expect_true(all(result$pip[causal_idx] > 0.1))\n\n # Check that most non-causal variables have low PIPs\n non_causal_idx <- setdiff(1:p, causal_idx)\n expect_true(mean(result$pip[non_causal_idx]) < mean(result$pip[causal_idx]))\n})\n\n# =============================================================================\n# INTEGRATION WITH FULL PIPELINE\n# =============================================================================\n\ntest_that(\"susie_workhorse produces output compatible with susie_get functions\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 20\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n # Should be able to extract PIPs (already in result)\n expect_length(result$pip, 50)\n\n # Should have credible sets\n expect_true(\"sets\" %in% names(result))\n\n # Should have all fields needed for coef() method\n expect_true(all(c(\"alpha\", \"mu\", \"intercept\") %in% names(result)))\n})\n\ntest_that(\"susie_workhorse output is a valid susie object\", {\n setup <- setup_individual_data(n = 100, p = 50, L = 5)\n setup$params$max_iter <- 10\n setup$params$convergence_method <- \"elbo\"\n setup$params$tol <- 1e-3\n\n result <- susie_workhorse(setup$data, setup$params)\n\n # Check class\n expect_s3_class(result, \"susie\")\n\n # Check that we have all the core components for a susie object\n required_fields <- c(\n \"alpha\", \"mu\", \"mu2\", \"V\", \"sigma2\",\n \"elbo\", \"niter\", \"converged\",\n \"pip\", \"sets\", \"fitted\", \"intercept\",\n \"lbf\", \"lbf_variable\", \"KL\"\n )\n\n expect_true(all(required_fields %in% names(result)))\n})\n" }, { "path": "tests/testthat/test_trendfilter.R", "content": "context(\"Trend filtering\")\n\n# =============================================================================\n# BASIC FUNCTIONALITY\n# =============================================================================\n\ntest_that(\"susie_trendfilter returns susie object\", {\n set.seed(1)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n expect_s3_class(result, \"susie\")\n expect_type(result, \"list\")\n expect_true(\"alpha\" %in% names(result))\n expect_true(\"mu\" %in% names(result))\n expect_true(\"elbo\" %in% names(result))\n})\n\ntest_that(\"susie_trendfilter detects changepoints with order=0\", {\n set.seed(2)\n # Create signal with clear changepoints\n mu <- c(rep(0, 25), rep(3, 25), rep(-2, 25), rep(1, 25))\n y <- mu + rnorm(100, sd = 0.3)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n # Should have non-zero PIPs near changepoint locations (25, 50, 75)\n pip <- susie_get_pip(result)\n changepoint_regions <- c(23:27, 48:52, 73:77)\n\n expect_true(sum(pip[changepoint_regions]) > sum(pip[-changepoint_regions]))\n})\n\ntest_that(\"susie_trendfilter fitted values track signal\", {\n set.seed(3)\n mu <- c(rep(0, 20), rep(2, 20), rep(0, 20))\n y <- mu + rnorm(60, sd = 0.1)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n fitted <- predict(result)\n\n # Fitted values should be closer to true signal than raw data\n expect_true(mean((fitted - mu)^2) < mean((y - mu)^2))\n})\n\ntest_that(\"susie_trendfilter with no changepoints\", {\n set.seed(4)\n # Constant signal\n y <- rep(5, 50) + rnorm(50, sd = 0.5)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n # PIPs should be low everywhere (no clear changepoints)\n pip <- susie_get_pip(result)\n expect_true(max(pip) < 0.5)\n})\n\n# =============================================================================\n# ORDER PARAMETER\n# =============================================================================\n\ntest_that(\"susie_trendfilter with order=0 (changepoints)\", {\n set.seed(5)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n expect_error(\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE),\n NA\n )\n\n expect_s3_class(result, \"susie\")\n})\n\ntest_that(\"susie_trendfilter with order=1 warns\", {\n set.seed(6)\n y <- seq(0, 1, length.out = 50) + rnorm(50, sd = 0.1)\n\n expect_message(\n result <- suppressWarnings(susie_trendfilter(y, order = 1, use_mad = FALSE)),\n \"order > 0 is not recommended\"\n )\n\n expect_s3_class(result, \"susie\")\n})\n\ntest_that(\"susie_trendfilter with order=2 warns\", {\n set.seed(7)\n y <- (seq(0, 1, length.out = 50))^2 + rnorm(50, sd = 0.1)\n\n expect_message(\n result <- suppressWarnings(susie_trendfilter(y, order = 2, use_mad = FALSE)),\n \"order > 0 is not recommended\"\n )\n\n expect_s3_class(result, \"susie\")\n})\n\ntest_that(\"susie_trendfilter order=0 vs order=1 produce different results\", {\n set.seed(8)\n # Linear trend\n y <- seq(0, 2, length.out = 50) + rnorm(50, sd = 0.1)\n\n result_0 <- susie_trendfilter(y, order = 0, use_mad = FALSE, max_iter = 10)\n result_1 <- suppressWarnings(\n susie_trendfilter(y, order = 1, use_mad = FALSE, max_iter = 10)\n )\n\n # Results should differ\n expect_false(all(abs(result_0$alpha - result_1$alpha) < 1e-10))\n})\n\n# =============================================================================\n# USE_MAD PARAMETER\n# =============================================================================\n\ntest_that(\"susie_trendfilter with use_mad=TRUE\", {\n set.seed(9)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n expect_error(\n result <- susie_trendfilter(y, order = 0, use_mad = TRUE),\n NA\n )\n\n expect_s3_class(result, \"susie\")\n})\n\ntest_that(\"susie_trendfilter with use_mad=FALSE\", {\n set.seed(10)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n expect_error(\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE),\n NA\n )\n\n expect_s3_class(result, \"susie\")\n})\n\ntest_that(\"susie_trendfilter use_mad=TRUE vs FALSE differ\", {\n set.seed(11)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n result_mad <- susie_trendfilter(y, order = 0, use_mad = TRUE, max_iter = 5)\n result_no_mad <- susie_trendfilter(y, order = 0, use_mad = FALSE, max_iter = 5)\n\n # Results may differ due to initialization\n # Just verify both work\n expect_s3_class(result_mad, \"susie\")\n expect_s3_class(result_no_mad, \"susie\")\n})\n\ntest_that(\"susie_trendfilter use_mad with model_init skips MAD\", {\n set.seed(12)\n mu <- c(rep(0, 20), rep(2, 20))\n y <- mu + rnorm(40)\n\n # Create a simple init\n init <- susie_init_coef(c(20), c(2), 40)\n\n # With model_init, should skip MAD even if use_mad=TRUE\n result <- susie_trendfilter(y, order = 0, use_mad = TRUE,\n model_init = init, max_iter = 2)\n\n expect_s3_class(result, \"susie\")\n})\n\ntest_that(\"susie_trendfilter rejects MAD=0 when use_mad=TRUE\", {\n # Create constant data which will cause MAD = 0\n # All differences will be 0, so median(abs(diff(y))) = 0\n y <- rep(5, 50)\n\n expect_error(\n susie_trendfilter(y, order = 0, use_mad = TRUE),\n \"Cannot use median absolute deviation \\\\(MAD\\\\) to initialize residual variance because MAD = 0 for the input data. Please set 'use_mad = FALSE'\"\n )\n})\n\n# =============================================================================\n# STANDARDIZE AND INTERCEPT OPTIONS\n# =============================================================================\n\ntest_that(\"susie_trendfilter with standardize=TRUE\", {\n set.seed(13)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n result <- susie_trendfilter(y, order = 0, standardize = TRUE, use_mad = FALSE)\n\n expect_s3_class(result, \"susie\")\n expect_true(all(result$alpha >= 0 & result$alpha <= 1))\n})\n\ntest_that(\"susie_trendfilter with standardize=FALSE\", {\n set.seed(14)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n result <- susie_trendfilter(y, order = 0, standardize = FALSE, use_mad = FALSE)\n\n expect_s3_class(result, \"susie\")\n expect_true(all(result$alpha >= 0 & result$alpha <= 1))\n})\n\ntest_that(\"susie_trendfilter with intercept=TRUE\", {\n set.seed(15)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60) + 10 # Add offset\n\n result <- susie_trendfilter(y, order = 0, intercept = TRUE, use_mad = FALSE)\n\n expect_s3_class(result, \"susie\")\n expect_true(!is.na(result$intercept))\n})\n\ntest_that(\"susie_trendfilter with intercept=FALSE\", {\n set.seed(16)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n result <- susie_trendfilter(y, order = 0, intercept = FALSE, use_mad = FALSE)\n\n expect_s3_class(result, \"susie\")\n expect_equal(result$intercept, 0)\n})\n\n# =============================================================================\n# PASS-THROUGH PARAMETERS\n# =============================================================================\n\ntest_that(\"susie_trendfilter passes L parameter to susie\", {\n set.seed(17)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n result <- susie_trendfilter(y, order = 0, L = 3, use_mad = FALSE)\n\n expect_equal(nrow(result$alpha), 3)\n expect_equal(length(result$V), 3)\n})\n\ntest_that(\"susie_trendfilter passes max_iter parameter to susie\", {\n set.seed(18)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n result <- susie_trendfilter(y, order = 0, max_iter = 5, use_mad = FALSE)\n\n expect_true(result$niter <= 5)\n})\n\ntest_that(\"susie_trendfilter passes estimate_prior_variance to susie\", {\n set.seed(19)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n result_estimate <- susie_trendfilter(y, order = 0,\n estimate_prior_variance = TRUE,\n use_mad = FALSE, max_iter = 3)\n result_fixed <- susie_trendfilter(y, order = 0,\n estimate_prior_variance = FALSE,\n use_mad = FALSE, max_iter = 3)\n\n # Both should work\n expect_s3_class(result_estimate, \"susie\")\n expect_s3_class(result_fixed, \"susie\")\n})\n\ntest_that(\"susie_trendfilter passes null_weight to susie\", {\n set.seed(20)\n mu <- c(rep(0, 30), rep(2, 30))\n y <- mu + rnorm(60)\n n <- length(y)\n\n result <- susie_trendfilter(y, order = 0, null_weight = 1/(n+1),\n use_mad = FALSE, max_iter = 3)\n\n expect_s3_class(result, \"susie\")\n expect_true(!is.null(result$null_index))\n})\n\n# =============================================================================\n# INTEGRATION WITH SUSIE METHODS\n# =============================================================================\n\ntest_that(\"susie_trendfilter output works with susie_get_cs\", {\n set.seed(21)\n mu <- c(rep(0, 25), rep(3, 25), rep(-2, 25), rep(1, 25))\n y <- mu + rnorm(100, sd = 0.3)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n cs <- susie_get_cs(result, coverage = 0.95)\n\n expect_type(cs, \"list\")\n expect_true(\"cs\" %in% names(cs))\n expect_equal(cs$requested_coverage, 0.95)\n})\n\ntest_that(\"susie_trendfilter output works with susie_get_pip\", {\n set.seed(22)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n pip <- susie_get_pip(result)\n\n expect_length(pip, length(y))\n expect_type(pip, \"double\")\n expect_true(all(pip >= 0 & pip <= 1))\n})\n\ntest_that(\"susie_trendfilter output works with predict\", {\n set.seed(23)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n fitted <- predict(result)\n\n expect_length(fitted, length(y))\n expect_type(fitted, \"double\")\n expect_true(all(is.finite(fitted)))\n})\n\ntest_that(\"susie_trendfilter output works with coef\", {\n set.seed(24)\n mu <- c(rep(0, 20), rep(2, 20), rep(-1, 20))\n y <- mu + rnorm(60)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n coefficients <- coef(result)\n\n # Should have length n+1 (intercept + n basis coefficients)\n expect_length(coefficients, length(y) + 1)\n expect_type(coefficients, \"double\")\n})\n\ntest_that(\"susie_trendfilter output has sets field\", {\n set.seed(25)\n mu <- c(rep(0, 25), rep(3, 25), rep(-2, 25), rep(1, 25))\n y <- mu + rnorm(100, sd = 0.3)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n result$sets <- susie_get_cs(result, coverage = 0.95)\n\n # Verify sets structure\n expect_type(result$sets, \"list\")\n expect_true(\"cs\" %in% names(result$sets))\n expect_true(\"coverage\" %in% names(result$sets))\n expect_equal(result$sets$requested_coverage, 0.95)\n})\n\n# =============================================================================\n# CHANGEPOINT DETECTION QUALITY\n# =============================================================================\n\ntest_that(\"susie_trendfilter recovers true changepoints\", {\n set.seed(26)\n # Simple changepoint problem\n mu <- c(rep(0, 30), rep(4, 30), rep(-2, 30))\n y <- mu + rnorm(90, sd = 0.5)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n pip <- susie_get_pip(result)\n\n # Changepoints should be at positions 30 and 60\n # High PIP should be near these positions\n expect_true(pip[30] > 0.5 | pip[29] > 0.5 | pip[31] > 0.5)\n expect_true(pip[60] > 0.5 | pip[59] > 0.5 | pip[61] > 0.5)\n})\n\ntest_that(\"susie_trendfilter handles multiple small changepoints\", {\n set.seed(27)\n # Many small changes\n mu <- rep(c(0, 0.5), length.out = 60)\n y <- mu + rnorm(60, sd = 0.2)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n expect_s3_class(result, \"susie\")\n expect_true(all(result$alpha >= 0 & result$alpha <= 1))\n})\n\ntest_that(\"susie_trendfilter with noisy data\", {\n set.seed(28)\n mu <- c(rep(0, 30), rep(2, 30))\n y <- mu + rnorm(60, sd = 2) # High noise\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n # Should still converge\n expect_s3_class(result, \"susie\")\n expect_true(result$converged)\n})\n\n# =============================================================================\n# EDGE CASES\n# =============================================================================\n\ntest_that(\"susie_trendfilter with short time series\", {\n set.seed(29)\n y <- c(0, 0, 0, 2, 2, 2)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE, max_iter = 3)\n\n expect_s3_class(result, \"susie\")\n})\n\ntest_that(\"susie_trendfilter with long time series\", {\n set.seed(30)\n mu <- rep(c(0, 1, 2, 0), each = 100)\n y <- mu + rnorm(400, sd = 0.5)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE, max_iter = 20)\n\n expect_s3_class(result, \"susie\")\n expect_length(predict(result), 400)\n})\n\ntest_that(\"susie_trendfilter with constant y errors\", {\n set.seed(31)\n y <- rep(5, 50)\n\n # Constant y has zero variance, should error\n expect_error(\n susie_trendfilter(y, order = 0, use_mad = FALSE),\n \"Residual variance sigma2 must be positive\"\n )\n})\n\ntest_that(\"susie_trendfilter with single changepoint at start\", {\n set.seed(32)\n mu <- c(rep(0, 5), rep(2, 45))\n y <- mu + rnorm(50, sd = 0.3)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n pip <- susie_get_pip(result)\n\n # Should detect changepoint near position 5\n expect_true(any(pip[3:7] > 0.3))\n})\n\ntest_that(\"susie_trendfilter with single changepoint at end\", {\n set.seed(33)\n mu <- c(rep(0, 45), rep(2, 5))\n y <- mu + rnorm(50, sd = 0.3)\n\n result <- susie_trendfilter(y, order = 0, use_mad = FALSE)\n\n pip <- susie_get_pip(result)\n\n # Should detect changepoint near position 45\n expect_true(any(pip[43:47] > 0.3))\n})\n\n# =============================================================================\n# COMPARISON WITH MANUAL CONSTRUCTION\n# =============================================================================\n\ntest_that(\"susie_trendfilter matches manual sparse matrix construction\", {\n set.seed(34)\n with(simulate_tf(0), {\n # Manual approach with explicit X matrix\n result_manual <- susie(X, y, estimate_prior_variance = FALSE,\n standardize = TRUE, max_iter = 5)\n\n # Using susie_trendfilter\n result_tf <- susie_trendfilter(y, order = 0,\n estimate_prior_variance = FALSE,\n standardize = TRUE,\n use_mad = FALSE, max_iter = 5)\n\n # Should produce similar results\n expect_equal(result_tf$alpha, result_manual$alpha, tolerance = 1e-6)\n expect_equal(result_tf$mu, result_manual$mu, tolerance = 1e-6)\n })\n})\n\ntest_that(\"susie_trendfilter order=1 matches manual construction\", {\n set.seed(35)\n with(simulate_tf(1), {\n # Manual approach\n result_manual <- susie(X, y, estimate_prior_variance = FALSE,\n standardize = TRUE, max_iter = 5)\n\n # Using susie_trendfilter\n result_tf <- suppressWarnings(\n susie_trendfilter(y, order = 1,\n estimate_prior_variance = FALSE,\n standardize = TRUE,\n use_mad = FALSE, max_iter = 5)\n )\n\n # Should produce similar results\n expect_equal(result_tf$alpha, result_manual$alpha, tolerance = 1e-6)\n expect_equal(result_tf$mu, result_manual$mu, tolerance = 1e-6)\n })\n})\n\ntest_that(\"susie_trendfilter order=2 matches manual construction\", {\n set.seed(36)\n with(simulate_tf(2), {\n # Manual approach\n result_manual <- susie(X, y, estimate_prior_variance = FALSE,\n standardize = TRUE, max_iter = 5)\n\n # Using susie_trendfilter\n result_tf <- suppressWarnings(\n susie_trendfilter(y, order = 2,\n estimate_prior_variance = FALSE,\n standardize = TRUE,\n use_mad = FALSE, max_iter = 5)\n )\n\n # Should produce similar results\n expect_equal(result_tf$alpha, result_manual$alpha, tolerance = 1e-6)\n expect_equal(result_tf$mu, result_manual$mu, tolerance = 1e-6)\n })\n})\n\n# =============================================================================\n# EXAMPLES FROM DOCUMENTATION\n# =============================================================================\n\ntest_that(\"susie_trendfilter works with documentation example\", {\n set.seed(1)\n mu <- c(rep(0, 50), rep(1, 50), rep(3, 50), rep(-2, 50), rep(0, 200))\n y <- mu + rnorm(400)\n\n s <- susie_trendfilter(y, max_iter = 100)\n\n expect_s3_class(s, \"susie\")\n expect_length(predict(s), 400)\n\n # Should be able to get credible sets\n cs <- susie_get_cs(s)\n expect_type(cs, \"list\")\n})\n" }, { "path": "tests/testthat/test_univariate_regression.R", "content": "context(\"Univariate regression\")\n\n# =============================================================================\n# BASIC FUNCTIONALITY\n# =============================================================================\n\ntest_that(\"univariate_regression returns correct structure\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 1)\n\n result <- univariate_regression(base_data$X, base_data$y)\n\n expect_type(result, \"list\")\n expect_named(result, c(\"betahat\", \"sebetahat\"))\n expect_length(result$betahat, base_data$p)\n expect_length(result$sebetahat, base_data$p)\n expect_type(result$betahat, \"double\")\n expect_type(result$sebetahat, \"double\")\n})\n\ntest_that(\"univariate_regression computes correct coefficients\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 2)\n beta_true <- c(1, -0.5, 0.8, 0, 0.3)\n y <- base_data$X %*% beta_true + rnorm(base_data$n, sd = 0.1)\n\n result <- univariate_regression(base_data$X, y, center = TRUE, scale = FALSE)\n\n # Each betahat should be close to the true beta\n for (i in 1:base_data$p) {\n expect_equal(result$betahat[i], beta_true[i], tolerance = 0.2)\n }\n})\n\ntest_that(\"univariate_regression standard errors are positive\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 3)\n\n result <- univariate_regression(base_data$X, base_data$y)\n\n expect_true(all(result$sebetahat > 0))\n})\n\ntest_that(\"univariate_regression matches manual lm calculation\", {\n base_data <- generate_base_data(n = 50, p = 3, k = 0, seed = 4)\n\n result <- univariate_regression(base_data$X, base_data$y, center = TRUE, scale = FALSE)\n\n # Compare to manual lm for first column\n y_centered <- base_data$y - mean(base_data$y)\n X_centered <- scale(base_data$X, center = TRUE, scale = FALSE)\n manual_fit <- lm(y_centered ~ X_centered[, 1])\n\n expect_equal(result$betahat[1], unname(coef(manual_fit)[2]), tolerance = 1e-10)\n expect_equal(result$sebetahat[1], unname(summary(manual_fit)$coef[2, 2]), tolerance = 1e-10)\n})\n\n# =============================================================================\n# CENTER AND SCALE OPTIONS\n# =============================================================================\n\ntest_that(\"univariate_regression with center=TRUE, scale=FALSE\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 5)\n\n result <- univariate_regression(base_data$X, base_data$y, center = TRUE, scale = FALSE)\n\n expect_length(result$betahat, base_data$p)\n expect_length(result$sebetahat, base_data$p)\n expect_true(all(is.finite(result$betahat)))\n expect_true(all(is.finite(result$sebetahat)))\n})\n\ntest_that(\"univariate_regression with center=TRUE, scale=TRUE\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 6)\n\n result <- univariate_regression(base_data$X, base_data$y, center = TRUE, scale = TRUE)\n\n expect_length(result$betahat, base_data$p)\n expect_length(result$sebetahat, base_data$p)\n expect_true(all(is.finite(result$betahat)))\n expect_true(all(is.finite(result$sebetahat)))\n})\n\ntest_that(\"univariate_regression with center=FALSE, scale=FALSE\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 7)\n\n result <- univariate_regression(base_data$X, base_data$y, center = FALSE, scale = FALSE)\n\n expect_length(result$betahat, base_data$p)\n expect_length(result$sebetahat, base_data$p)\n expect_true(all(is.finite(result$betahat)))\n expect_true(all(is.finite(result$sebetahat)))\n})\n\ntest_that(\"univariate_regression with center=FALSE, scale=TRUE\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 8)\n\n result <- univariate_regression(base_data$X, base_data$y, center = FALSE, scale = TRUE)\n\n expect_length(result$betahat, base_data$p)\n expect_length(result$sebetahat, base_data$p)\n expect_true(all(is.finite(result$betahat)))\n expect_true(all(is.finite(result$sebetahat)))\n})\n\ntest_that(\"univariate_regression scaling affects coefficient magnitude\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 9)\n # Create X with different variances\n X_varied <- matrix(rnorm(base_data$n * base_data$p, sd = rep(c(1, 5, 10, 2, 3), each = base_data$n)), base_data$n, base_data$p)\n\n result_unscaled <- univariate_regression(X_varied, base_data$y, center = TRUE, scale = FALSE)\n result_scaled <- univariate_regression(X_varied, base_data$y, center = TRUE, scale = TRUE)\n\n # Coefficients should differ due to scaling\n expect_false(all(abs(result_unscaled$betahat - result_scaled$betahat) < 0.01))\n})\n\n# =============================================================================\n# COVARIATES (Z PARAMETER)\n# =============================================================================\n\ntest_that(\"univariate_regression with covariates Z\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 10)\n k <- 2\n Z <- matrix(rnorm(base_data$n * k), base_data$n, k)\n\n result <- univariate_regression(base_data$X, base_data$y, Z = Z, center = TRUE)\n\n expect_type(result, \"list\")\n expect_length(result$betahat, base_data$p)\n expect_length(result$sebetahat, base_data$p)\n expect_true(all(is.finite(result$betahat)))\n expect_true(all(is.finite(result$sebetahat)))\n})\n\ntest_that(\"univariate_regression with Z adjusts for confounders\", {\n base_data <- generate_base_data(n = 200, p = 5, k = 0, seed = 11)\n # Create confounder\n Z <- matrix(rnorm(base_data$n), base_data$n, 1)\n # X correlated with Z\n X_confounded <- base_data$X + Z %*% matrix(rnorm(base_data$p), 1, base_data$p)\n # y depends only on Z, not X\n y_confounded <- 2 * Z[, 1] + rnorm(base_data$n, sd = 0.1)\n\n result_no_Z <- univariate_regression(X_confounded, y_confounded, Z = NULL, center = TRUE)\n result_with_Z <- univariate_regression(X_confounded, y_confounded, Z = Z, center = TRUE)\n\n # Without Z, X appears associated with y\n # With Z adjustment, association should be weaker\n expect_true(mean(abs(result_with_Z$betahat)) < mean(abs(result_no_Z$betahat)))\n})\n\ntest_that(\"univariate_regression with Z and return_residuals=TRUE\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 12)\n k <- 2\n Z <- matrix(rnorm(base_data$n * k), base_data$n, k)\n\n result <- univariate_regression(base_data$X, base_data$y, Z = Z, return_residuals = TRUE)\n\n expect_type(result, \"list\")\n expect_named(result, c(\"betahat\", \"sebetahat\", \"residuals\"))\n expect_length(result$residuals, base_data$n)\n expect_type(result$residuals, \"double\")\n})\n\ntest_that(\"univariate_regression return_residuals=TRUE without Z omits residuals\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 13)\n\n result <- univariate_regression(base_data$X, base_data$y, Z = NULL, return_residuals = TRUE)\n\n expect_named(result, c(\"betahat\", \"sebetahat\"))\n expect_false(\"residuals\" %in% names(result))\n})\n\ntest_that(\"univariate_regression residuals from Z are centered\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 14)\n k <- 2\n Z <- matrix(rnorm(base_data$n * k), base_data$n, k)\n\n result <- univariate_regression(base_data$X, base_data$y, Z = Z, return_residuals = TRUE, center = TRUE)\n\n # Residuals should be approximately centered\n expect_equal(mean(result$residuals), 0, tolerance = 1e-10)\n})\n\n# =============================================================================\n# NA HANDLING\n# =============================================================================\n\ntest_that(\"univariate_regression handles NA values in y\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 15)\n base_data$y[c(5, 20, 35)] <- NA\n\n result <- univariate_regression(base_data$X, base_data$y)\n\n expect_length(result$betahat, base_data$p)\n expect_length(result$sebetahat, base_data$p)\n expect_true(all(is.finite(result$betahat)))\n expect_true(all(is.finite(result$sebetahat)))\n})\n\ntest_that(\"univariate_regression removes corresponding X rows when y has NA\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 16)\n beta_true <- rep(1, base_data$p)\n y_with_signal <- base_data$X %*% beta_true + rnorm(base_data$n, sd = 0.1)\n\n # Add NAs\n na_idx <- c(10, 20, 30)\n y_with_signal[na_idx] <- NA\n\n result <- univariate_regression(base_data$X, y_with_signal, center = TRUE)\n\n # Should still produce finite results (NA removal worked)\n expect_true(all(is.finite(result$betahat)))\n expect_true(all(is.finite(result$sebetahat)))\n expect_length(result$betahat, base_data$p)\n})\n\n# =============================================================================\n# EDGE CASES\n# =============================================================================\n\ntest_that(\"univariate_regression with zero-variance column\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 17)\n base_data$X[, 3] <- 5 # Constant column\n\n # Should produce a warning message for the constant column\n expect_message(\n result <- univariate_regression(base_data$X, base_data$y, center = TRUE, scale = FALSE),\n \"WARNING:.*Column 3 has zero variance\"\n )\n\n # Constant column becomes zero after centering\n expect_equal(result$betahat[3], 0)\n expect_equal(result$sebetahat[3], 0)\n})\n\ntest_that(\"univariate_regression with perfect predictor\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 18)\n # Make y perfectly predicted by first column\n y_perfect <- 3 * base_data$X[, 1] + mean(base_data$X[, 1])\n\n result <- univariate_regression(base_data$X, y_perfect, center = TRUE, scale = FALSE)\n\n # First coefficient should be exactly 3, SE should be very small\n expect_equal(result$betahat[1], 3, tolerance = 1e-10)\n expect_true(result$sebetahat[1] < 1e-10)\n})\n\ntest_that(\"univariate_regression with single column X\", {\n base_data <- generate_base_data(n = 100, p = 1, k = 0, seed = 19)\n\n result <- univariate_regression(base_data$X, base_data$y)\n\n expect_length(result$betahat, 1)\n expect_length(result$sebetahat, 1)\n expect_true(is.finite(result$betahat[1]))\n expect_true(is.finite(result$sebetahat[1]))\n})\n\ntest_that(\"univariate_regression with very small sample size\", {\n base_data <- generate_base_data(n = 5, p = 3, k = 0, seed = 20)\n\n result <- univariate_regression(base_data$X, base_data$y)\n\n expect_length(result$betahat, base_data$p)\n expect_length(result$sebetahat, base_data$p)\n})\n\n# =============================================================================\n# Z-SCORES\n# =============================================================================\n\ntest_that(\"univariate_regression enables z-score calculation\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 21)\n beta_true <- c(rep(1, 3), rep(0, 7))\n y_signal <- base_data$X %*% beta_true + rnorm(base_data$n)\n\n result <- univariate_regression(base_data$X, y_signal)\n\n # Calculate z-scores\n z <- result$betahat / result$sebetahat\n\n expect_length(z, base_data$p)\n expect_type(z, \"double\")\n\n # Causal variables should have larger |z|\n expect_true(mean(abs(z[1:3])) > mean(abs(z[4:10])))\n})\n\n# =============================================================================\n# METHOD COMPARISON: LMFIT VS SUMSTATS\n# =============================================================================\n\ntest_that(\"univariate_regression methods lmfit and sumstats agree\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 22)\n\n res1 <- univariate_regression(base_data$X, base_data$y, method = \"lmfit\")\n res2 <- univariate_regression(base_data$X, base_data$y, method = \"sumstats\")\n\n expect_equal(res1$betahat, res2$betahat, tolerance = 1e-8)\n expect_equal(res1$sebetahat, res2$sebetahat, tolerance = 1e-8)\n})\n\ntest_that(\"lmfit and sumstats agree with center=TRUE, scale=FALSE\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 23)\n\n res1 <- univariate_regression(base_data$X, base_data$y, center = TRUE,\n scale = FALSE, method = \"lmfit\")\n res2 <- univariate_regression(base_data$X, base_data$y, center = TRUE,\n scale = FALSE, method = \"sumstats\")\n\n expect_equal(res1$betahat, res2$betahat, tolerance = 1e-8)\n expect_equal(res1$sebetahat, res2$sebetahat, tolerance = 1e-8)\n})\n\ntest_that(\"lmfit and sumstats agree with center=TRUE, scale=TRUE\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 24)\n\n res1 <- univariate_regression(base_data$X, base_data$y, center = TRUE,\n scale = TRUE, method = \"lmfit\")\n res2 <- univariate_regression(base_data$X, base_data$y, center = TRUE,\n scale = TRUE, method = \"sumstats\")\n\n expect_equal(res1$betahat, res2$betahat, tolerance = 1e-8)\n expect_equal(res1$sebetahat, res2$sebetahat, tolerance = 1e-8)\n})\n\ntest_that(\"lmfit and sumstats agree with center=FALSE, scale=FALSE\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 25)\n\n res1 <- univariate_regression(base_data$X, base_data$y, center = FALSE,\n scale = FALSE, method = \"lmfit\")\n res2 <- univariate_regression(base_data$X, base_data$y, center = FALSE,\n scale = FALSE, method = \"sumstats\")\n\n expect_equal(res1$betahat, res2$betahat, tolerance = 1e-8)\n expect_equal(res1$sebetahat, res2$sebetahat, tolerance = 1e-8)\n})\n\ntest_that(\"lmfit and sumstats agree with center=FALSE, scale=TRUE\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 26)\n\n res1 <- univariate_regression(base_data$X, base_data$y, center = FALSE,\n scale = TRUE, method = \"lmfit\")\n res2 <- univariate_regression(base_data$X, base_data$y, center = FALSE,\n scale = TRUE, method = \"sumstats\")\n\n expect_equal(res1$betahat, res2$betahat, tolerance = 1e-8)\n expect_equal(res1$sebetahat, res2$sebetahat, tolerance = 1e-8)\n})\n\ntest_that(\"lmfit and sumstats agree with covariates Z\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 27)\n k <- 3\n Z <- matrix(rnorm(base_data$n * k), base_data$n, k)\n\n res1 <- univariate_regression(base_data$X, base_data$y, Z = Z,\n center = TRUE, method = \"lmfit\")\n res2 <- univariate_regression(base_data$X, base_data$y, Z = Z,\n center = TRUE, method = \"sumstats\")\n\n expect_equal(res1$betahat, res2$betahat, tolerance = 1e-8)\n expect_equal(res1$sebetahat, res2$sebetahat, tolerance = 1e-8)\n})\n\ntest_that(\"lmfit and sumstats agree with NA values in y\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 28)\n base_data$y[c(5, 20, 35)] <- NA\n\n res1 <- univariate_regression(base_data$X, base_data$y, method = \"lmfit\")\n res2 <- univariate_regression(base_data$X, base_data$y, method = \"sumstats\")\n\n expect_equal(res1$betahat, res2$betahat, tolerance = 1e-8)\n expect_equal(res1$sebetahat, res2$sebetahat, tolerance = 1e-8)\n})\n\ntest_that(\"lmfit and sumstats agree with zero-variance column\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 29)\n base_data$X[, 5] <- 3 # Constant column\n\n # Both methods should produce warning messages\n expect_message(\n res1 <- univariate_regression(base_data$X, base_data$y, center = TRUE,\n scale = FALSE, method = \"lmfit\"),\n \"WARNING:.*Column 5 has zero variance\"\n )\n\n expect_message(\n res2 <- univariate_regression(base_data$X, base_data$y, center = TRUE,\n scale = FALSE, method = \"sumstats\"),\n \"WARNING:.*Column 5 has zero variance\"\n )\n\n expect_equal(res1$betahat, res2$betahat, tolerance = 1e-8)\n expect_equal(res1$sebetahat, res2$sebetahat, tolerance = 1e-8)\n})\n\ntest_that(\"lmfit and sumstats agree with single column X\", {\n base_data <- generate_base_data(n = 100, p = 1, k = 0, seed = 30)\n\n res1 <- univariate_regression(base_data$X, base_data$y, method = \"lmfit\")\n res2 <- univariate_regression(base_data$X, base_data$y, method = \"sumstats\")\n\n expect_equal(res1$betahat, res2$betahat, tolerance = 1e-8)\n expect_equal(res1$sebetahat, res2$sebetahat, tolerance = 1e-8)\n})\n\ntest_that(\"lmfit and sumstats agree with large dataset\", {\n base_data <- generate_base_data(n = 500, p = 5000, k = 0, seed = 31)\n\n res1 <- univariate_regression(base_data$X, base_data$y, center = TRUE,\n scale = TRUE, method = \"lmfit\")\n res2 <- univariate_regression(base_data$X, base_data$y, center = TRUE,\n scale = TRUE, method = \"sumstats\")\n\n expect_equal(res1$betahat, res2$betahat, tolerance = 1e-8)\n expect_equal(res1$sebetahat, res2$sebetahat, tolerance = 1e-8)\n})\n\n# =============================================================================\n# COMPARISON WITH SIMPLE LM\n# =============================================================================\n\ntest_that(\"univariate_regression agrees with lm for each column\", {\n base_data <- generate_base_data(n = 50, p = 5, k = 0, seed = 32)\n\n result <- univariate_regression(base_data$X, base_data$y, center = TRUE, scale = FALSE)\n\n # Prepare centered data\n y_c <- base_data$y - mean(base_data$y)\n X_c <- scale(base_data$X, center = TRUE, scale = FALSE)\n\n # Compare each column\n for (i in 1:base_data$p) {\n lm_fit <- lm(y_c ~ X_c[, i])\n lm_coef <- unname(coef(summary(lm_fit))[2, ])\n\n expect_equal(result$betahat[i], lm_coef[1], tolerance = 1e-10)\n expect_equal(result$sebetahat[i], lm_coef[2], tolerance = 1e-10)\n }\n})\n\n# =============================================================================\n# FALLBACK MECHANISM\n# =============================================================================\n\ntest_that(\"univariate_regression fallback works when fast method fails\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 33)\n\n # Normal execution should work\n result <- univariate_regression(base_data$X, base_data$y)\n\n expect_length(result$betahat, base_data$p)\n expect_true(all(is.finite(result$betahat)))\n expect_true(all(is.finite(result$sebetahat)))\n})\n\ntest_that(\"univariate_regression handles nearly singular design matrix\", {\n base_data <- generate_base_data(n = 100, p = 5, k = 0, seed = 34)\n # Make two columns nearly identical\n base_data$X[, 2] <- base_data$X[, 1] + rnorm(base_data$n, sd = 1e-10)\n\n # Should still produce output (possibly via fallback)\n result <- univariate_regression(base_data$X, base_data$y, center = TRUE)\n\n expect_length(result$betahat, base_data$p)\n expect_length(result$sebetahat, base_data$p)\n})\n\n# =============================================================================\n# INTEGRATION TESTS\n# =============================================================================\n\ntest_that(\"univariate_regression output usable for RSS methods\", {\n base_data <- generate_base_data(n = 200, p = 100, k = 0, seed = 35)\n beta_true <- rep(0, base_data$p)\n beta_true[1:5] <- rnorm(5)\n y_causal <- base_data$X %*% beta_true + rnorm(base_data$n)\n\n result <- univariate_regression(base_data$X, y_causal)\n\n # Should be able to compute z-scores\n z <- result$betahat / result$sebetahat\n\n # Should be able to compute correlation matrix\n R <- cor(base_data$X)\n\n # Should be usable with estimate_s_rss\n expect_error(\n s <- estimate_s_rss(z, R, n = base_data$n),\n NA\n )\n})\n\ntest_that(\"univariate_regression with center and scale matches susie preprocessing\", {\n base_data <- generate_base_data(n = 100, p = 50, k = 0, seed = 36)\n\n # This should match what susie does internally for univariate regression\n result <- univariate_regression(base_data$X, base_data$y, center = TRUE, scale = TRUE)\n\n expect_length(result$betahat, base_data$p)\n expect_true(all(is.finite(result$betahat)))\n expect_true(all(is.finite(result$sebetahat)))\n})\n\n# =============================================================================\n# CALC_Z FUNCTION\n# =============================================================================\n\ntest_that(\"calc_z returns correct z-scores for single outcome (vector Y)\", {\n base_data <- generate_base_data(n = 100, p = 10, k = 0, seed = 37)\n\n # Compute z-scores using calc_z\n z <- susieR:::calc_z(base_data$X, base_data$y, center = FALSE, scale = FALSE)\n\n # Manually compute z-scores\n result <- univariate_regression(base_data$X, base_data$y, center = FALSE, scale = FALSE)\n z_manual <- result$betahat / result$sebetahat\n\n expect_equal(z, z_manual)\n expect_length(z, base_data$p)\n expect_type(z, \"double\")\n})\n\ntest_that(\"calc_z returns correct z-scores for multiple outcomes (matrix Y)\", {\n set.seed(38)\n n <- 100\n p <- 10\n m <- 3 # Number of outcomes\n X <- matrix(rnorm(n * p), n, p)\n Y <- matrix(rnorm(n * m), n, m)\n\n # Compute z-scores using calc_z\n z_matrix <- susieR:::calc_z(X, Y, center = FALSE, scale = FALSE)\n\n # Should return a matrix with p rows and m columns\n expect_true(is.matrix(z_matrix))\n expect_equal(nrow(z_matrix), p)\n expect_equal(ncol(z_matrix), m)\n\n # Each column should match manual calculation for that outcome\n for (i in 1:m) {\n result <- univariate_regression(X, Y[, i], center = FALSE, scale = FALSE)\n z_manual <- result$betahat / result$sebetahat\n expect_equal(z_matrix[, i], z_manual)\n }\n})\n\ntest_that(\"calc_z with center=TRUE centers data before computing z-scores\", {\n set.seed(39)\n n <- 100\n p <- 10\n X <- matrix(rnorm(n * p, mean = 5, sd = 2), n, p)\n y <- rnorm(n, mean = 10, sd = 3)\n\n # Compute z-scores with centering\n z_centered <- susieR:::calc_z(X, y, center = TRUE, scale = FALSE)\n\n # Manually compute with centering\n result <- univariate_regression(X, y, center = TRUE, scale = FALSE)\n z_manual <- result$betahat / result$sebetahat\n\n expect_equal(z_centered, z_manual)\n expect_length(z_centered, p)\n})\n\ntest_that(\"calc_z with scale=TRUE scales data before computing z-scores\", {\n set.seed(40)\n n <- 100\n p <- 10\n X <- matrix(rnorm(n * p, sd = c(1, 5, 10, 2, 3, 1, 4, 8, 1, 2)), n, p)\n y <- rnorm(n, sd = 5)\n\n # Compute z-scores with scaling\n z_scaled <- susieR:::calc_z(X, y, center = FALSE, scale = TRUE)\n\n # Manually compute with scaling\n result <- univariate_regression(X, y, center = FALSE, scale = TRUE)\n z_manual <- result$betahat / result$sebetahat\n\n expect_equal(z_scaled, z_manual)\n expect_length(z_scaled, p)\n})\n\ntest_that(\"calc_z with center=TRUE and scale=TRUE\", {\n set.seed(41)\n n <- 100\n p <- 10\n X <- matrix(rnorm(n * p, mean = 3, sd = c(1, 5, 10, 2, 3, 1, 4, 8, 1, 2)), n, p)\n y <- rnorm(n, mean = 7, sd = 5)\n\n # Compute z-scores with both centering and scaling\n z_both <- susieR:::calc_z(X, y, center = TRUE, scale = TRUE)\n\n # Manually compute with both\n result <- univariate_regression(X, y, center = TRUE, scale = TRUE)\n z_manual <- result$betahat / result$sebetahat\n\n expect_equal(z_both, z_manual)\n expect_length(z_both, p)\n})\n\ntest_that(\"calc_z handles matrix Y with different centering/scaling\", {\n set.seed(42)\n n <- 100\n p <- 8\n m <- 4\n # Create data with varying means and scales to ensure differences\n X <- matrix(rnorm(n * p, mean = rep(c(0, 5, -3, 2), each = n * 2)), n, p)\n Y <- matrix(rnorm(n * m, mean = rep(c(0, 10, -5, 3), each = n)), n, m)\n # Add varying scales\n for (i in 1:p) {\n X[, i] <- X[, i] * (i %% 3 + 1)\n }\n\n # Test all combinations\n z1 <- susieR:::calc_z(X, Y, center = FALSE, scale = FALSE)\n z2 <- susieR:::calc_z(X, Y, center = TRUE, scale = FALSE)\n z3 <- susieR:::calc_z(X, Y, center = FALSE, scale = TRUE)\n z4 <- susieR:::calc_z(X, Y, center = TRUE, scale = TRUE)\n\n # All should be matrices with correct dimensions\n expect_equal(dim(z1), c(p, m))\n expect_equal(dim(z2), c(p, m))\n expect_equal(dim(z3), c(p, m))\n expect_equal(dim(z4), c(p, m))\n\n # All should be finite\n expect_true(all(is.finite(z1)))\n expect_true(all(is.finite(z2)))\n expect_true(all(is.finite(z3)))\n expect_true(all(is.finite(z4)))\n})\n\ntest_that(\"calc_z matrix Y branch is tested (is.null(dim(Y)) = FALSE)\", {\n set.seed(43)\n n <- 50\n p <- 5\n m <- 2\n X <- matrix(rnorm(n * p), n, p)\n Y <- matrix(rnorm(n * m), n, m)\n\n # Y is a matrix, so dim(Y) is not NULL\n expect_false(is.null(dim(Y)))\n\n # This should execute the matrix branch\n z_matrix <- susieR:::calc_z(X, Y, center = TRUE, scale = FALSE)\n\n # Verify it's a matrix\n expect_true(is.matrix(z_matrix))\n expect_equal(ncol(z_matrix), m)\n})\n\ntest_that(\"calc_z vector Y branch is tested (is.null(dim(Y)) = TRUE)\", {\n set.seed(44)\n n <- 50\n p <- 5\n X <- matrix(rnorm(n * p), n, p)\n y <- rnorm(n)\n\n # y is a vector, so dim(y) is NULL\n expect_true(is.null(dim(y)))\n\n # This should execute the vector branch\n z_vector <- susieR:::calc_z(X, y, center = TRUE, scale = FALSE)\n\n # Verify it's a vector\n expect_false(is.matrix(z_vector))\n expect_length(z_vector, p)\n})\n" }, { "path": "tests/testthat.R", "content": "library(testthat)\nlibrary(susieR)\ntest_check(\"susieR\")\n" }, { "path": "vignettes/announcements.Rmd", "content": "---\ntitle: \"News and Updates\"\noutput: \n rmarkdown::html_vignette:\n toc: true\n toc_depth: 3\nvignette: >\n %\\VignetteIndexEntry{News and Updates}\n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{UTF-8}\n---\n\n```{r, include = FALSE}\nknitr::opts_chunk$set(\n collapse = TRUE,\n comment = \"#>\"\n)\n```\n\n# Release notes\n## Version 2.0.0 - Major Release\n*Release date: 2026-03-29*\n\n### Release Overview\n\nThis major release introduces **`susieR` 2.0**, a complete architectural redesign that addresses the code duplication and fragmented architecture of the original SuSiE implementation as a result of years of continued development, while adding new features and various performance optimizations, all while maintaining backward compatibility.\n\n`susieR` 2.0 eliminates the duplicative architecture of the original implementation through a unified framework built on modular design principles. The user-facing interface remains largely unchanged, but the implementation now uses generic functions with data-type specific backends through R's S3 dispatch system. A key design insight is that most SuSiE extensions reduce to customizations in either Bayes factor computation (per single-effect regression) or residual variance estimation (on the model objective), and the S3 dispatch architecture exploits this separation so that each extension is a local change without modifying the core IBSS algorithm. This architecture has enabled the integration of multiple SuSiE extensions, and serves as the backbone for the refactored mvsusieR package for multi-trait fine-mapping ([Zou et al. 2026](https://doi.org/10.1038/s41588-025-02486-7)). Beyond architectural improvements, this release introduces new features including unmappable effects modeling, stochastic LD reference with mixture panel support, enhanced computational speed, and improved IBSS refinement procedures.\n\n### New Features\n* **SuSiE-ash Model**: New adaptive shrinkage framework ([Stephens 2017](https://doi.org/10.1093/biostatistics/kxw041)) for unmappable effects, extending SuSiE to handle moderately strong but unmappable effects. SuSiE-ash achieves calibration intermediate between standard SuSiE and the more conservative SuSiE-inf under polygenic architectures while maintaining comparable power.\n* **SuSiE-inf Integration**: Implementation of SuSiE-inf ([Cui et al. 2024](https://www.nature.com/articles/s41588-023-01597-3)), which models infinitesimal effects alongside sparse causal signals to improve fine-mapping calibration when genetic architecture includes polygenic backgrounds.\n* **Servin-Stephens Prior Integration**: New prior option ([Servin and Stephens, 2007](https://doi.org/10.1371/journal.pgen.0030114)) on residual variance estimates in single effect regression (SER) to improve credible set coverage and calibration, particularly useful for small sample studies ([Denault et al. 2025](https://www.biorxiv.org/content/10.1101/2025.05.16.654543v1)). Implemented for both individual-level and summary statistics backends.\n* **Stochastic LD Reference**: Support for using genotype matrices directly, including stochastic genotypes in place of LD correlation matrices in summary statistics models (Sun et al., in preparation), with linear algebra optimizations that cache decompositions and exploit the LD structure for speedup.\n* **Mixture of LD Reference Panels**: Support for combining multiple LD reference panels with adaptive weight optimization within the regularized LD (RSS-lambda) model framework (Sun et al., in preparation), enabling more robust fine-mapping with diverse or mismatched reference populations.\n* **`mvsusieR` Backbone**: The S3 dispatch architecture serves as the shared backbone for mvsusieR, enabling our multi-trait fine-mapping methods to build directly on the susieR 2.0 framework with their own S3 dispatch class.\n\n### Enhancements\n* **Performance improvements for RSS model**: algebraic optimizations improves RSS models, with further gains on large genomic regions when reference genotype matrices replace LD correlation matrices.\n* **Convergence Criteria**: PIP-based convergence option alongside traditional ELBO convergence, particularly useful for methods where ELBO computation is expensive.\n* **Residual Variance Estimation**: Method of Moments option alongside Maximum Likelihood for improved stability.\n* **Block Coordinate Ascent Refinement**: Improved refinement procedure that escapes local optima through alternative initializations and enables residual variance estimation with missing data in multi-trait fine-mapping via `mvsusieR`.\n* **Verbose Diagnostics**: Detailed diagnostic output for monitoring model fitting behavior.\n* **Attainable Coverage**: Post-hoc credible set coverage adjustment as a rough alternative when LD matrices are unavailable for purity filtering.\n* **Unit Test Coverage**: Comprehensive unit tests covering 100% of code.\n" }, { "path": "vignettes/finemapping.Rmd", "content": "---\ntitle: \"Fine-mapping example\"\nauthor: \"Gao Wang\"\ndate: \"`r Sys.Date()`\"\noutput: rmarkdown::html_vignette\nvignette: >\n %\\VignetteIndexEntry{Fine-mapping example}\n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{UTF-8}\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(collapse = TRUE,comment = \"#\",fig.width = 5,\n fig.height = 3,fig.align = \"center\",\n fig.cap = \" \",dpi = 120)\n```\n\nThis vignette demonstrates `susieR` in the context of genetic\nfine-mapping. We use simulated data of expression level of a gene\n($y$) in $N \\approx 600$ individuals. We want to identify with the\ngenotype matrix $X_{N\\times P}$ ($P=1001$) the genetic variables that\ncauses changes in expression level.\n\nThe simulated data set is simulated to have exactly 3 non-zero\neffects.\n\n```{r}\nlibrary(susieR)\nset.seed(1)\n```\n\n## The data-set\n\n```{r}\ndata(N3finemapping)\nattach(N3finemapping)\n```\n\nThe loaded dataset contains regression data $X$ and $y$, along with some other\nrelevant properties in the context of genetic studies. It also\ncontains the \"true\" regression coefficent the data is simulated from.\n\nNotice that we've simulated 2 sets of $Y$ as 2 simulation\nreplicates. Here we'll focus on the first data-set.\n\n```{r}\ndim(Y)\n```\n\nHere are the 3 \"true\" signals in the first data-set:\n\n```{r}\nb <- true_coef[,1]\nplot(b, pch=16, ylab='effect size')\n```\n\n```{r}\nwhich(b != 0)\n```\n\nSo the underlying causal variables are 403, 653 and 773.\n\n## Simple regression summary statistics\n\n`univariate_regression` function can be used to compute \nsummary statistics by fitting univariate simple regression variable by variable.\nThe results are $\\hat{\\beta}$ and $SE(\\hat{\\beta})$ from which z-scores can be\nderived. Again we focus only on results from the first data-set:\n\n```{r}\nsumstats <- univariate_regression(X, Y[,1])\nz_scores <- sumstats$betahat / sumstats$sebetahat\nsusie_plot(z_scores, y = \"z\", b=b)\n```\n\n## Fine-mapping with `susieR`\n\nFor starters, we assume there are at most 10 causal variables, i.e.,\nset `L = 10`, although SuSiE is robust to the choice of `L`.\n\nThe `susieR` function call is:\n\n```{r}\nfitted <- susie(X, Y[,1],\n L = 10,\n\t\tverbose = TRUE)\n```\n\n### Credible sets\n\nBy default, we output 95% credible set:\n\n```{r}\nprint(fitted$sets)\n```\n\nThe 3 causal signals have been captured by the 3 CS reported here. The\n3rd CS contains many variables, including the true causal variable\n`403`. The minimum absolute correlation is 0.86.\n\nIf we use the default 90% coverage for credible sets, we still\ncapture the 3 signals, but \"purity\" of the 3rd CS is now 0.91 and size\nof the CS is also a bit smaller.\n\n```{r}\nsets <- susie_get_cs(fitted,\n X = X,\n\t \t coverage = 0.9,\n min_abs_corr = 0.1)\n```\n\n```{r}\nprint(sets)\n```\n\n### Posterior inclusion probabilities\n\nPreviously we've determined that summing over 3 single effect\nregression models is approperate for our application. Here we\nsummarize the variable selection results by posterior inclusion\nprobability (PIP):\n\n```{r}\nsusie_plot(fitted, y=\"PIP\", b=b)\n```\n\nThe true causal variables are colored red. The 95% CS identified are\ncircled in different colors. Of interest is the cluster around\nposition 400. The true signal is 403 but apparently it does not have\nthe highest PIP. To compare ranking of PIP and original z-score in\nthat CS:\n\n```{r}\ni <- fitted$sets$cs[[3]]\nz3 <- cbind(i,z_scores[i],fitted$pip[i])\ncolnames(z3) <- c('position', 'z-score', 'PIP')\nz3[order(z3[,2], decreasing = TRUE),]\n```\n\n### Choice of priors\n\nNotice that by default SuSiE estimates prior effect size from data. For\nfine-mapping applications, however, we sometimes have knowledge of SuSiE prior effect\nsize since it is parameterized as percentage of variance explained (PVE) by a non-zero effect, \nwhich, in the context of fine-mapping, is related to per-SNP heritability. It is possible\nto use `scaled_prior_variance` to specify this PVE and explicitly set `estimate_prior_variance=FALSE`\nto fix the prior effect to given value.\n\nIn this data-set, SuSiE is robust to choice of priors. Here we\nset PVE to 0.2,\nand compare with previous results:\n\n```{r}\nfitted = susie(X, Y[,1],\n L = 10,\n estimate_residual_variance = TRUE, \n estimate_prior_variance = FALSE, \n scaled_prior_variance = 0.2)\nsusie_plot(fitted, y='PIP', b=b)\n```\n\nwhich largely remains unchanged. \n\n### A note on covariate adjustment\n\nTo include covariate `Z` in SuSiE, one approach is to regress it out from both `y`\nand `X`, and then run SuSiE on the residuals. The code below illustrates the procedure:\n\n```{r, eval=FALSE}\nremove.covariate.effects <- function (X, Z, y) {\n # include the intercept term\n if (any(Z[,1]!=1)) Z = cbind(1, Z)\n A <- forceSymmetric(crossprod(Z))\n SZy <- as.vector(solve(A,c(y %*% Z)))\n SZX <- as.matrix(solve(A,t(Z) %*% X))\n y <- y - c(Z %*% SZy)\n X <- X - Z %*% SZX\n return(list(X = X,y = y,SZy = SZy,SZX = SZX))\n}\n\nout = remove.covariate.effects(X, Z, Y[,1])\nfitted_adjusted = susie(out$X, out$y, L = 10)\n```\n\nNote that the covariates `Z` should have a column of ones as the first column. If not, the above function `remove.covariate.effects`\nwill add such a column to `Z` before regressing it out. \nData will be centered as a result. Also the scale of data is changed after regressing out `Z`. \nThis introduces some subtleties in terms of interpreting the results.\nFor this reason, we provide covariate adjustment procedure as a tip in the documentation\nand not part of `susieR::susie()` function. Cautions should be taken when applying this procedure and interpreting the result from it.\n\n\n## Sufficient statistics: `compute_suff_stat` and `susie_ss`\n\nWhen individual-level data $(X, y)$ are available and the sample size $N$\nis much larger than the number of variables $P$, calling `susie(X, y)`\ndirectly is wasteful: each IBSS iteration touches `X` again, and when many\nresponse vectors are fit against the same `X` (for example, many proteins\nor genes on a shared locus), $X'X$ is rebuilt every time. The sufficient\nstatistics $(X'X, X'y, y'y, n)$ capture everything `susie` needs; once they\nare computed, `susie_ss` can be called directly and $X'X$ reused across\nresponse vectors.\n\nThe function `compute_suff_stat` produces these sufficient statistics from\n$(X, y)$:\n\n```{r}\nss <- compute_suff_stat(X, Y[,1])\nstr(ss)\n```\n\nThey pass directly to `susie_ss`:\n\n```{r}\nfitted_ss <- susie_ss(XtX = ss$XtX, Xty = ss$Xty, yty = ss$yty, n = ss$n,\n X_colmeans = ss$X_colmeans, y_mean = ss$y_mean,\n L = 10, estimate_residual_variance = TRUE)\n```\n\nWith matched hyperparameters, `susie_ss(...)` is numerically equivalent to\nrunning `susie` on $(X, y)$ directly:\n\n```{r}\nfitted <- susie(X, Y[,1], L = 10)\nall.equal(fitted$pip, fitted_ss$pip)\n```\n\nFor a second response vector on the same `X`, only `Xty` and `yty` need to\nbe recomputed; the costly $X'X$ is reused:\n\n```{r}\ny2_centered <- Y[,2] - mean(Y[,2])\nss2 <- ss\nss2$Xty <- drop(y2_centered %*% X)\nss2$yty <- sum(y2_centered^2)\nss2$y_mean <- mean(Y[,2])\nfitted_ss2 <- susie_ss(XtX = ss2$XtX, Xty = ss2$Xty, yty = ss2$yty,\n n = ss2$n, X_colmeans = ss2$X_colmeans,\n y_mean = ss2$y_mean, L = 10)\n```\n\n`susie()` emits a hint suggesting this workflow whenever\n`nrow(X) >= 2 * ncol(X)`.\n\n\n\n## Session information\n\nHere are some details about the computing environment, including the\nversions of R, and the R packages, used to generate these results.\n\n```{r}\nsessionInfo()\n```\n\n[N3finemapping]: https://github.com/stephenslab/susieR/blob/master/inst/datafiles/N3finemapping.rds\n" }, { "path": "vignettes/finemapping_summary_statistics.Rmd", "content": "---\ntitle: \"Fine-mapping with summary statistics\"\nauthor: \"Yuxin Zou and Gao Wang\"\ndate: \"`r Sys.Date()`\"\noutput: rmarkdown::html_vignette\nvignette: >\n %\\VignetteIndexEntry{Fine-mapping with summary statistics}\n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{UTF-8}\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(collapse = TRUE,comment = \"#\",fig.width = 5,\n fig.height = 3,fig.align = \"center\",\n fig.cap = \" \",dpi = 120)\n```\n\nThis vignette demonstrates how to use `susieR` with \"summary\nstatistics\" in the context of genetic fine-mapping. We use the same\nsimulated data as in [fine mapping vignette](finemapping.html). The\nsimulated data are expression levels of a gene ($y$) in $N \\approx 600$\nindividuals. We want to identify with the genotype matrix $X_{N\\times\nP}$ ($P=1001$) the genetic variables that causes changes in expression\nlevel. This data set is shipped with `susieR`. It is simulated to have\nexactly three non-zero effects.\n\n```{r}\nlibrary(susieR)\nset.seed(1)\n```\n\n## The data-set\n\n```{r}\ndata(N3finemapping)\nattach(N3finemapping)\nn = nrow(X)\n```\n\nNotice that we've simulated two sets of $Y$ as two simulation\nreplicates. Here we'll focus on the first data-set.\n\n```{r}\ndim(Y)\n```\n\nHere are the three true signals in the first data-set:\n\n```{r}\nb <- true_coef[,1]\nplot(b, pch=16, ylab='effect size')\n```\n\n```{r}\nwhich(b != 0)\n```\n\nSo the underlying causal variables are 403, 653 and 773.\n\n## Summary statistics from simple regression\n\nSummary statistics of genetic association studies typically contain\neffect sizes ($\\hat{\\beta}$ coefficient from regression) and p-values.\nThese statisticscan be used to perform fine-mapping with given an\nadditional input of correlation matrix between variables. The\ncorrelation matrix in genetics is typically referred to as an \"LD\nmatrix\" (LD is short for linkage disequilibrium). One may use external\nreference panels to estimate it when this matrix cannot be obtained\nfrom samples directly. *Importantly, the LD matrix has to be a matrix\ncontaining estimates of the correlation, $r$, and not $r^2$ or $|r|$.*\nSee also [this vignette](susierss_diagnostic.html) for how to check the\nconsistency of the LD matrix with the summary statistics.\n\nThe `univariate_regression` function can be used to compute summary\nstatistics by fitting univariate simple regression variable by\nvariable. The results are $\\hat{\\beta}$ and $SE(\\hat{\\beta})$ from\nwhich z-scores can be derived. Alternatively, you can obtain z-scores\nfrom $\\hat{\\beta}$ and p-values if you are provided with those\ninformation. For example,\n\n```{r}\nsumstats <- univariate_regression(X, Y[,1])\nz_scores <- sumstats$betahat / sumstats$sebetahat\nsusie_plot(z_scores, y = \"z\", b=b)\n```\n\nFor this example, the correlation matrix can be computed directly from\ndata provided:\n\n```{r}\nR <- cor(X)\n```\n\n## Fine-mapping with `susieR` using summary statistics\n\nBy default, SuSiE assumes at most 10 causal variables, with `L =\n10`, although we note that SuSiE is generally robust to the choice of\n`L`.\n\nSince the individual-level data is available for us here, we can\neasily compute the \"in-sample LD\" matrix, as well as the variance of\n$y$, which is `r round(var(Y[,1]),digits = 4)`. (By \"in-sample\", we\nmeans the LD was computed from the exact same matrix `X` that was used\nto obtain the other statistics.) When we fit SuSiE regression with\nsummary statistics, $\\hat{\\beta}$, $SE(\\hat{\\beta})$, $R$, $n$, and\nvar_y these are also the *sufficient statistics.* With an in-sample\nLD, we can also estimate the residual variance using these sufficient\nstatistics. (Note that if the covariate effects are removed from the\ngenotypes in the univariate regression, it is recommended that the\n\"in-sample\" LD matrix also be computed from the genotypes after the\ncovariate effects have been removed.)\n\n```{r}\nfitted_rss1 <- susie_rss(bhat = sumstats$betahat, shat = sumstats$sebetahat, n = n, R = R, var_y = var(Y[,1]), L = 10,\n estimate_residual_variance = TRUE)\n```\n\nUsing `summary`, we can examine the posterior inclusion probability\n(PIP) for each variable, and the 95% credible sets:\n\n```{r}\nsummary(fitted_rss1)$cs\n```\n\nThe three causal signals have been captured by the three CSs. Note the\nthird CS contains many variables, including the true causal\nvariable 403.\n\nWe can also plot the posterior inclusion probabilities (PIPs):\n\n```{r}\nsusie_plot(fitted_rss1, y=\"PIP\", b=b)\n```\n\nThe true causal variables are shown in red. The 95% CSs are\nshown by three different colours (green, purple, blue).\n\nNote this result is *exactly the same* as running `susie` on the\noriginal individual-level data:\n\n```{r}\nfitted = susie(X, Y[,1], L = 10)\nall.equal(fitted$pip, fitted_rss1$pip)\nall.equal(coef(fitted)[-1], coef(fitted_rss1)[-1])\n```\n\nIf, on the other hand, the variance of $y$ is unknown, we fit can SuSiE\nregression with summary statistics, $\\hat{\\beta}$, $SE(\\hat{\\beta})$,\n$R$ and $n$ (or *z*-scores, $R$ and $n$). The outputted effect estimates\nare now on the standardized $X$ and $y$ scale. Still, we can estimate the\nresidual variance because we have the in-sample LD matrix:\n\n```{r}\nfitted_rss2 = susie_rss(z = z_scores, R = R, n = n, L = 10,\n estimate_residual_variance = TRUE)\n```\n\nThe result is same as if we had run `susie` on the individual-level\ndata, but the output effect estimates are on different scale:\n\n```{r, fig.height=4, fig.width=3.5}\nall.equal(fitted$pip, fitted_rss2$pip)\nplot(coef(fitted)[-1], coef(fitted_rss2)[-1], xlab = 'effects from SuSiE', ylab = 'effects from SuSiE-RSS', xlim=c(-1,1), ylim=c(-0.3,0.3))\n```\n\nSpecifically, without the variance of $y$, these estimates are same as\nif we had applied SuSiE to a standardized $X$ and $y$; that is, as if\n$y$ and the columns of $X$ had been normalized so that $y$ and each\ncolumn of $X$ had a standard deviation of 1.\n\n```{r}\nfitted_standardize = susie(scale(X), scale(Y[,1]), L = 10)\nall.equal(coef(fitted_standardize)[-1], coef(fitted_rss2)[-1])\n```\n\n\n## Fine-mapping with `susieR` using LD matrix from reference panel\n\nWhen the original genotypes are not available, one may use a separate\nreference panel to estimate the LD matrix.\n\nTo illustrate this, we randomly generated 500 samples from $N(0,R)$\nand treated them as reference panel genotype matrix `X_ref`.\n\n```{r echo=F}\nset.seed(1)\ntmp = matrix(rnorm(500*1001), 500, 1001)\neigenR = eigen(R)\neigenR$values[eigenR$values < 1e-10] = 0\nX_ref = tmp %*% (sqrt(eigenR$values) * t(eigenR$vectors))\nR_ref = cor(X_ref)\n```\n\nWe fit the SuSiE regression using out-of sample LD matrix. The\nresidual variance is fixed at 1 because estimating residual variance\nsometimes produces very inaccurate estimates with out-of-sample LD\nmatrix. The output effect estimates are on the standardized $X$ and\n$y$ scale.\n\n```{r}\nfitted_rss3 <- susie_rss(z_scores, R_ref, n=n, L = 10)\n```\n\n```{r}\nsusie_plot(fitted_rss3, y=\"PIP\", b=b)\n```\n\nIn this particular example, the SuSiE result with out-of-sample LD is\nvery similar to using the in-sample LD matrix because the LD matrices\nare quite similar.\n\n```{r, fig.width=3.5,fig.height=4}\nplot(fitted_rss1$pip, fitted_rss3$pip, ylim=c(0,1), xlab='SuSiE PIP', ylab='SuSiE-RSS PIP')\n```\n\nIn some rare cases, the sample size $n$ is unknown. When the sample\nsize is not provided as input to `susie_rss`, this is in effect\nassuming the sample size is infinity and all the effects are small,\nand the estimated PVE for each variant will be close to zero. The\noutputted effect estimates are on the \"noncentrality parameter\" scale.\n\n```{r}\nfitted_rss4 = susie_rss(z_scores, R_ref, L = 10)\nsusie_plot(fitted_rss4, y=\"PIP\", b=b)\n```\n\n## Session information\n\nHere are some details about the computing environment, including the\nversions of R, and the R packages, used to generate these results.\n\n```{r}\nsessionInfo()\n```\n" }, { "path": "vignettes/l0_initialization.Rmd", "content": "---\ntitle: \"SuSiE with L0Learn initialization example\"\nauthor: \"Kaiqian Zhang\"\ndate: \"`r Sys.Date()`\"\noutput: rmarkdown::html_vignette\nvignette: >\n %\\VignetteIndexEntry{SuSiE with L0Learn initialization example}\n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{UTF-8}\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(collapse = TRUE,comment = \"#\")\n```\n\n`susieR` allows for a customized initialization. In this vignette we\ndeomonstrate how to use\n[`L0Learn`](https://github.com/hazimehh/L0Learn) fit to initialize\nsusieR.\n\n```{r, warning=FALSE}\nlibrary(susieR)\nlibrary(L0Learn)\n```\n\n## Simulate data\n\nFirst, we simulate data from the minimal example.\n\n```{r}\nset.seed(1)\nn = 1000\np = 1000\nbeta = rep(0,p)\nbeta[c(1,2,300,400)] = 1\nX = matrix(rnorm(n*p),nrow=n,ncol=p)\ny = X %*% beta + rnorm(n)\n```\n\n## Fit L0Learn \n\nWe start with fitting a L0-regularized model to the simulated data. \n\n```{r}\nset.seed(1)\nL0fit = L0Learn.cvfit(X, y, penalty = \"L0\")\n```\n\nLet's choose the penalty strength parameter that minimizes the\ncross-validation error.\n\n```{r}\nlambdaIndex = which.min(L0fit$cvMeans[[1]]) \nL0coef = as.numeric(coef(L0fit$fit, lambda = L0fit$fit$lambda[[1]][lambdaIndex]))\neffect.beta = L0coef[which(L0coef!=0)][-1]\neffect.index = (which(L0coef!=0)-1)[-1] \nlength(effect.beta)\neffect.beta[1:10]\neffect.index[1:10]\n```\n\nThe L0Learn model finds `r length(effect.beta)` effects, which will be\nused to initialize susie.\n\n## Build an initialization object\n\nWe create an initialization from `l0learn` coefficients using\n`susie_init_coef` function,\n\n```{r}\nset.seed(1)\ns.init = susie_init_coef(effect.index, effect.beta, p)\n```\n\n## Run susieR with initialization\n\nNow, we use `effect.index` and `effect.beta` obtained from L0Learn fit\nto create an `s.init` object. We then run susie with this\ninitialization.\n\n```{r}\nsusieL0.fit = susie(X,y,model_init=s.init)\nsusieL0.fit$sets$cs\n```\n\n## References\n\n1. Hussein Hazimeh and Rahul Mazumder. (2018). Fast Best Subset\nSelection: Coordinate Descent and Local Combinatorial Optimization\nAlgorithms.\n" }, { "path": "vignettes/mwe.Rmd", "content": "---\ntitle: \"A minimal example\"\nauthor: \"Matthew Stephens\"\ndate: \"`r Sys.Date()`\"\noutput: rmarkdown::html_vignette\nvignette: >\n %\\VignetteIndexEntry{minimal example}\n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{UTF-8}\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(collapse = TRUE,comment = \"#\",fig.width = 4.5,\n fig.height = 3,fig.align = \"center\",\n fig.cap = \" \",dpi = 120)\n```\n\nIn this short vignette, we fit a sparse linear regression model with\nup to $L > 0$ non-zero effects. Generally, there is no harm in\nover-stating $L$ (that is, the method is pretty robust to overfitting),\nexcept that computation will grow as $L$ grows.\n\nHere is a minimal example:\n\n```{r}\nlibrary(susieR)\nset.seed(1)\nn <- 1000\np <- 1000\nbeta <- rep(0,p)\nbeta[c(1,2,300,400)] <- 1\nX <- matrix(rnorm(n*p),nrow=n,ncol=p)\ny <- X %*% beta + rnorm(n)\nres <- susie(X,y,L=10)\nplot(coef(res)[-1],pch = 20)\n```\n\nPlot the ground-truth outcomes vs. the predicted outcomes:\n\n```{r fig.height=3.5, fig.width=3.5}\nplot(y,predict(res),pch = 20)\n```\n\n## Session information\n\nHere are some details about the computing environment, including the\nversions of R, and the R packages, used to generate these results.\n\n```{r}\nsessionInfo()\n```\n" }, { "path": "vignettes/small_sample.Rmd", "content": "---\ntitle: Accounting for uncertainty in residual variances for small sample studies\nauthor: William R.P. Denault\ndate: \"`r Sys.Date()`\"\noutput: rmarkdown::html_vignette\nvignette: >\n %\\VignetteIndexEntry{Small data example}\n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{UTF-8}\n---\n\n```{r knitr-opts, include=FALSE}\nknitr::opts_chunk$set(\n comment = \"#\",\n collapse = TRUE,\n results = \"markup\",\n fig.align = \"center\",\n fig.width = 4.5,\n fig.height = 3.2,\n warning = FALSE,\n message = FALSE\n)\n```\n\nThis is vignette is a modified example based on Figure 1 panel B-C-D\nin [Denault et al paper](https://doi.org/10.1101/2025.05.16.654543).\n\n```{r load-pkgs}\nlibrary(susieR)\n```\n\nFor reproducibility, set the seed:\n\n```{r}\nset.seed(1)\n```\n\n## Data\n\nIn this example, we analyze a simulated eQTL data set. The goal\nis to finemap causal variants for expression (eQTLs).\n\n```{r load-data}\ndata(data_small)\ny <- data_small$y\nX <- data_small$X\ndim(X)\n```\n\n## Baseline SuSiE fit\n\nThe original SuSiE method displays signs of misscalibration: the\nresult is highly suspicious as we find 10 credible sets in a data set\ncontaining only 47 samples.\n\n```{r run-susie, fig.height=3.5, fig.width=5, message=FALSE}\nres_susie <- susie(X,y,L = 10,verbose = TRUE)\nres_susie$sets$cs\nsusie_plot(res_susie,y = \"PIP\")\n```\n\nAnother clue is that the fine-mapped SNPs explain >99% of the\nvariation in gene expression, which might be explained by overfitting:\n\n```{r, fig.height=4.5, fig.width=4}\nypred <- predict(res_susie, X)\npve <- 1 - drop(res_susie$sigma2 / var(y))\nround(100 * pve, 3)\nplot(y, ypred, pch = 20,\n xlab = \"observed\",\n ylab = \"predicted\")\nabline(0, 1, col = \"magenta\", lty = \"dotted\")\n```\n\n## SuSiE with Servin-Stephens SER\n\nSetting `estimate_residual_method = \"NIG\"` switches SuSiE\nto a variant of the single-effect regression (SER) model that accounts\nfor uncertainty in the residual variance. This is based on the linear\nregression model for single-SNP association tests described in\n[Servin and Stephens (2007)](https://doi.org/10.1371/journal.pgen.0030114).\n\n```{r run-susie-small, message=FALSE, warning=FALSE} \nres_susie_small <-\n susie(X,y,L = 1,estimate_residual_method = \"NIG\",\n verbose = TRUE)\nres_susie_small$sets$cs\n```\n\nThis analysis looks more plausible as it identifies only 1 CS:\n\n```{r, fig.height=3, fig.width=5}\nsusie_plot(res_susie_small,y = \"PIP\")\n```\n\nAnd, indeed, the predictions with the Servin-Stephens SER do not seem\nto \"overfit\" the expression data quite so strongly.\n\n```{r, fig.height=4.5, fig.width=4}\npred_small <- predict(res_susie_small, X)\nplot(y, ypred, pch = 20,col = \"darkblue\",\n xlab = \"observed\",\n ylab = \"predicted\")\npoints(y, pred_small, pch = 20, col = \"darkorange\")\nabline(0, 1, col = \"magenta\", lty = \"dotted\")\nlegend(\"topleft\", pch = c(20, 20), col = c(\"darkblue\",\"darkorange\"),\n legend = c(\"SuSiE (default Gaussian SER)\",\n \"SuSiE (Servin-Stephens SER)\"))\n```\n \n### References\n\nServin, B. & Stephens, M. (2007). Imputation-based analysis of\nassociation studies: Candidate regions and quantitative traits. *PLoS\nGenetics*, 3(7): e114.\n\nDenault et al (2025). Accounting for uncertainty in residual\nvariances improves calibration for fine-mapping with small sample\nsizes. *bioRxiv* doi:10.1101/2025.05.16.654543.\n" }, { "path": "vignettes/sparse_susie_eval.Rmd", "content": "---\ntitle: \"Evaluation of sparse version of SuSiE\"\nauthor: \"Kaiqian Zhang\"\ndate: \"`r Sys.Date()`\"\noutput: rmarkdown::html_vignette\nvignette: >\n %\\VignetteIndexEntry{SuSiE with sparse matrix operations}\n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{UTF-8}\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(collapse = TRUE,comment = \"#\",fig.width = 4.5,\n fig.height = 3,fig.align = \"center\",\n fig.cap = \" \",dpi = 120)\n```\n\n## Set up environment\n\n```{r, warning=FALSE}\nlibrary(Matrix)\nlibrary(susieR)\nset.seed(1)\n```\n\n## Overview\n\nIn this vignette, we provide line profiles for revised version SuSiE,\nwhich allows for a sparse matrix structure. We compare speed\nperformance when the form of the matrix `X` is dense and sparse.\n\nIn this minimal example, we observe that given a large sparse matrix,\nif it is in the dense form, the speed is around `40%` slower than that\nin a sparse form.\n\n## Simulate data\n\nWe randomly simulate a `n=1000` by `p=1000` dense matrix and a sparse\nmatrix at sparsity $99\\%$, i.e. $99\\%$ entries are zeros.\n\n```{r}\ncreate_sparsity_mat = function(sparsity, n, p) {\n nonzero <- round(n*p*(1-sparsity))\n nonzero.idx <- sample(n*p, nonzero)\n mat <- numeric(n*p)\n mat[nonzero.idx] <- 1\n mat <- matrix(mat, nrow=n, ncol=p)\n return(mat)\n}\n```\n\n```{r}\nn <- 1000\np <- 1000\nbeta <- rep(0,p)\nbeta[c(1,300,400,1000)] <- 10 \nX.dense <- create_sparsity_mat(0.99,n,p)\nX.sparse <- as(X.dense,\"sparseMatrix\")\ny <- c(X.dense %*% beta + rnorm(n))\n```\n\n## `X` in a dense form\n\n```{r}\nsusie.dense <- susie(X.dense,y)\n```\n\n## `X` in a sparse form\n\n```{r}\nsusie.sparse <- susie(X.sparse,y)\n```\n\n## Further step\n\nWe encourage people who are insterested in improving SuSiE can get\ninsights from those line profiles provided.\n" }, { "path": "vignettes/susie_refine.Rmd", "content": "---\ntitle: \"Refine SuSiE model\"\nauthor: \"Yuxin Zou\"\ndate: \"`r Sys.Date()`\"\noutput: rmarkdown::html_vignette\nvignette: >\n %\\VignetteIndexEntry{Refine SuSiE model}\n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{UTF-8}\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(collapse = TRUE,comment = \"#\",fig.width = 5,\n fig.height = 3,fig.align = \"center\",\n fig.cap = \" \",dpi = 120)\n```\n\nIn this vignette, we demonstrate a procedure that helps SuSiE get out of local optimum.\n\nWe simulate phenotype using UK Biobank genotypes from 50,000 individuals. There are 1001 SNPs.\nIt is simulated to have exactly 2 non-zero effects at 234, 287.\n\n```{r}\nlibrary(susieR)\nlibrary(curl)\ndata_file <- tempfile(fileext = \".RData\")\ndata_url <- paste0(\"https://raw.githubusercontent.com/stephenslab/susieR/\",\n \"master/inst/datafiles/FinemappingConvergence1k.RData\")\ncurl_download(data_url,data_file)\nload(data_file)\nb <- FinemappingConvergence$true_coef\nsusie_plot(FinemappingConvergence$z, y = \"z\", b=b)\n```\n\nThe strongest marginal association is a non-effect SNP. \n\nSince the sample size is large, we use sufficient statistics ($X^\\intercal X, X^\\intercal y, y^\\intercal y$ and sample size $n$) to fit susie model. It identifies 2 Credible Sets, one of them is false positive. This is because `susieR` get stuck around a local minimum. \n\n```{r}\nfitted <- with(FinemappingConvergence,\n susie_ss(XtX = XtX, Xty = Xty, yty = yty, n = n))\nsusie_plot(fitted, y=\"PIP\", b=b, main=paste0(\"ELBO = \", round(susie_get_objective(fitted),2)))\n```\n\nOur refine procedure to get out of local optimum is\n\n1. fit a susie model, $s$ (suppose it has $K$ CSs).\n\n2. for CS in $s$, set SNPs in CS to have prior weight 0, fit susie model --> we have K susie models: $t_1, \\cdots, t_K$.\n\n3. for each $k = 1, \\cdots, K$, fit susie with initialization at $t_k$ ($\\alpha, \\mu, \\mu^2$) --> $s_k$\n\n4. if $\\max_k \\text{elbo}(s_k) > \\text{elbo}(s)$, set $s = s_{kmax}$ where $kmax = \\arg_k \\max \\text{elbo}(s_k)$ and go to step 2; if no, break.\n\nWe fit susie model with above procedure by setting `refine = TRUE`.\n\n```{r}\nfitted_refine <- with(FinemappingConvergence,\n susie_ss(XtX = XtX, Xty = Xty, yty = yty,\n\t\t\t\t\t n = n, refine=TRUE))\nsusie_plot(fitted_refine, y=\"PIP\", b=b, main=paste0(\"ELBO = \", round(susie_get_objective(fitted_refine),2)))\n```\n\nWith the refine procedure, it identifies 2 CSs with the true signals, and the achieved evidence lower bound (ELBO) is higher.\n\n## Session information\n\nHere are some details about the computing environment, including the\nversions of R, and the R packages, used to generate these results.\n\n```{r}\nsessionInfo()\n```\n\n\n\n\n" }, { "path": "vignettes/susie_rss.Rmd", "content": "---\ntitle: \"Compare susie_rss variants\"\nauthor: \"Peter Carbonetto\"\ndate: \"`r Sys.Date()`\"\noutput: rmarkdown::html_vignette\nvignette: >\n %\\VignetteIndexEntry{Compare susie_rss variants}\n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{UTF-8}\n---\n\nIn this vignette, we briefly illustrate the different ways\n[susie_rss][susie_rss] can be called, and draw connections between\nrunning `susie_rss` on summary data, and running `susie` on\nindividual-level data.\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(collapse = TRUE,comment = \"#\",fig.width = 5,\n fig.height = 3,fig.align = \"center\",\n dpi = 120)\n```\n\n```{r load-pkgs}\nlibrary(susieR)\n```\n\nSimulate a data set with 200 samples and 1,000 variables, in which the\nonly first 4 variables affect the outcome.\n\n```{r simdata}\nset.seed(1)\nn <- 200\np <- 1000\nbeta <- rep(0,p)\nbeta[1:4] <- 1\nX <- matrix(rnorm(n*p),nrow = n,ncol = p)\nX <- scale(X,center = TRUE,scale = FALSE)\ny <- drop(X %*% beta + rnorm(n))\n```\n\nCompute summary statistics $\\hat{b}_j, \\hat{s}_j$ and the correlation\nmatrix, ${\\bf R}$. These quantities will be provided as input to\nsusie_rss.\n\n```{r sumstats-no-standardize}\nss <- univariate_regression(X,y)\ndat <- compute_suff_stat(X,y,standardize = FALSE)\nR <- cov2cor(dat$XtX)\n```\n\nThe susie and susie_rss analyses produce the exact same results when\nthe summary statistics `bhat`, `shat`, `var_y` and `n` are provided to\nsusie_rss (and when `R` is an \"in sample\" correlation estimate---that\nis, when it was computed from the same matrix `X` that was used to\nobtain the other statistics). If the covariate effects are removed from \nthe genotypes in univariate regression, the in-sample LD matrix should \ncompute from the genotype residuals where the covariate effects have \nbeen removed.\n\n```{r first-comparison, fig.height=3.5, fig.width=3}\nres1 <- susie(X,y,L = 10)\nres2 <- susie_rss(bhat = ss$betahat,shat = ss$sebetahat,R = R,n = n,\n var_y = var(y),L = 10,estimate_residual_variance = TRUE)\nplot(coef(res1),coef(res2),pch = 20,xlab = \"susie\",ylab = \"susie_rss\")\nabline(a = 0,b = 1,col = \"skyblue\",lty = \"dashed\")\n```\n\nWhen some but not all of these statistics are provided, the results\nshould be similar, but not exactly the same.\n\nNext let's compare the susie and susie_rss outputs when ${\\bf X},\ny$ are *standardized* before computing the summary statistics (by\n\"standardize\", we mean that $y$ and the columns of ${\\bf X}$ are each\ndivided by the sample standard deviation so that they each have the\nsame standard deviation).\n\n```{r sumstats-standardize-1}\nss <- univariate_regression(scale(X),scale(y))\ndat <- compute_suff_stat(X,y,standardize = TRUE)\nR <- cov2cor(dat$XtX)\n```\n\nThen we compute the *z*-scores:\n\n```{r sumstats-standardize-2}\nzhat <- ss$betahat/ss$sebetahat\n```\n\nWhen standardizing, providing susie_rss with summary data `z` (or\n`bhat`, `shat`), `R` and `n` is sufficient for susie_rss to recover\nthe same results as susie:\n\n```{r second-comparison, fig.height=3.5, fig.width=6, message=FALSE}\nres1 <- susie(scale(X),scale(y),L = 10)\nres2 <- susie_rss(bhat = ss$betahat,shat = ss$sebetahat,R = R,n = n,\n L = 10,estimate_residual_variance = TRUE)\nres3 <- susie_rss(zhat,R,n = n,L = 10,estimate_residual_variance = TRUE)\nlayout(matrix(1:2,1,2))\nplot(coef(res1),coef(res2),pch = 20,xlab = \"susie\",\n ylab = \"susie_rss(bhat,shat)\")\nabline(a = 0,b = 1,col = \"skyblue\",lty = \"dashed\")\nplot(coef(res1),coef(res3),pch = 20,xlab = \"susie\",ylab = \"susie_rss(z)\")\nabline(a = 0,b = 1,col = \"skyblue\",lty = \"dashed\")\n```\n\nWhen the residual variance is not estimated in susie_rss, the\nsusie_rss results may be close to susie, but may no longer be\nexactly the same:\n\n```{r third-comparison, fig.height=3.5, fig.width=3, message=FALSE}\nres4 <- susie_rss(zhat,R,n = n,L = 10)\nplot(coef(res1),coef(res4),pch = 20,xlab = \"susie\",ylab = \"susie_rss\")\nabline(a = 0,b = 1,col = \"skyblue\",lty = \"dashed\")\n```\n\nWhenever `R` is an \"in sample\" correlation matrix, we recommend\nestimating the residual variance.\n\nWithout providing the sample size, `n`, the coefficients are\ninterpreted as the \"noncentrality parameters\" (NCPs), and are\n(roughly) related to the susie parameters by a factor of $\\sqrt{n}$:\n\n```{r fourth-comparison, fig.height=3.5, fig.width=3, message=FALSE, warning=FALSE}\nres5 <- susie_rss(zhat,R,L = 10)\nplot(coef(res1),coef(res5)/sqrt(n),pch = 20,xlab = \"susie\",\nylab = \"susie_rss/sqrt(n)\")\nabline(a = 0,b = 1,col = \"skyblue\",lty = \"dashed\")\n```\n\nWhenever possible, the sample size, or a reasonable estimate of the\nsample size, should be provided.\n\n[susie_rss]: https://stephenslab.github.io/susieR/reference/susie_rss.html\n" }, { "path": "vignettes/susie_unmappable_effects.Rmd", "content": "---\ntitle: \"Fine-mapping with SuSiE-ash and SuSiE-inf\"\nauthor: \"Alex McCreight\"\ndate: \"`r Sys.Date()`\"\noutput: rmarkdown::html_vignette\nvignette: >\n %\\VignetteIndexEntry{Fine-mapping with SuSiE-ash and SuSiE-inf}\n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{UTF-8}\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(collapse = TRUE,comment = \"#\",fig.width = 5,\n fig.height = 3,fig.align = \"center\",\n dpi = 120)\n```\n\nThis vignette demonstrates how to use the SuSiE-ash and SuSiE-inf models.\nWe use a simulated data set with n = 1000 individuals, p = 5000 variants, and\na complex genetic architecture combining 3 sparse, 5 oligogenic, and 15 polygenic effects.\n\n## Data\n\n```{r}\nlibrary(susieR)\ndata(unmappable_data)\n\nX <- unmappable_data$X\ny <- as.vector(unmappable_data$y)\nb <- unmappable_data$beta\n\nplot(abs(b), ylab = \"Absolute Effect Size\", pch = 16)\npoints(which(b != 0), abs(b[b != 0]), col = 2, pch = 16)\n```\n\n## Summary Statistics and Z-Scores\n\nBefore fitting the models, we can examine the marginal association statistics.\nWe use `univariate_regression()` to compute effect sizes and standard errors,\nthen derive z-scores:\n\n```{r}\nsumstats <- univariate_regression(X, y)\nz_scores <- sumstats$betahat / sumstats$sebetahat\n```\n\nThe z-scores show the strength of marginal association for each variant.\nRed points indicate non-zero effect sizes:\n\n```{r}\nsusie_plot(z_scores, y = \"z\", b = b, add_legend = TRUE)\n```\n\nHere we can see the signal landscape before fine-mapping. Note that \nsome causal variants have strong z-scores while others may be weaker\nor masked by LD with nearby variants.\n\nNotably, variant 2714 has the largest true effect size in the simulation:\n\n```{r}\nstrongest_idx <- which.max(abs(b))\ncat(\"Strongest effect variant:\", strongest_idx, \"\\n\")\ncat(\"True effect size:\", round(b[strongest_idx], 3), \"\\n\")\ncat(\"Marginal z-score:\", round(z_scores[strongest_idx], 3), \"\\n\")\ncat(\"Marginal p-value:\", format.pval(2 * pnorm(-abs(z_scores[strongest_idx]))), \"\\n\")\n```\n\nDespite having the largest true effect, this variant has a very small marginal z-score and \na large p-value. This illustrates a fundamental challenge in fine-mapping: the marginal \nassociation of a large-effect causal variant can be masked by other variants in LD, \nwhile smaller-effect variants may show stronger marginal signals. \nThis masking makes it difficult to identify the true causal variants from marginal statistics alone.\n\n## Step 1: Standard SuSiE and False Positives\n\nWe first fit standard SuSiE:\n\n```{r}\nt0 <- proc.time()\nfit_susie <- susie(X, y, L = 10)\nt1 <- proc.time()\nt1 - t0\nsusie_plot(fit_susie, y = \"PIP\", b = b, main = \"SuSiE (standard)\", add_legend = TRUE)\n```\n\nWe set `L = 10` to allow SuSiE to capture up to 10 sparse effects. \nHowever, given the complex architecture with 23 true causal variants, this may be insufficient.\n\nTo see which true effects the credible sets capture, we plot the CS on\nthe true effect sizes:\n\n```{r}\nplot_cs_effects <- function(fit, b, main = \"\") {\n colors <- c(\"dodgerblue2\", \"green4\", \"#6A3D9A\", \"#FF7F00\", \"gold1\", \"firebrick2\")\n plot(abs(b), pch = 16, ylab = \"Absolute Effect Size\", main = main)\n if (!is.null(fit$sets$cs)) {\n for (i in rev(seq_along(fit$sets$cs))) {\n cs_idx <- fit$sets$cs[[i]]\n points(cs_idx, abs(b[cs_idx]), col = colors[(i-1) %% 6 + 1], pch = 16, cex = 1.5)\n }\n }\n \n cat(sprintf(\"True causals: %s\\n\", paste(which(b != 0), collapse=\", \")))\n for (i in seq_along(fit$sets$cs)) {\n cs_idx <- fit$sets$cs[[i]]\n sentinel <- cs_idx[which.max(fit$pip[cs_idx])]\n tp <- any(b[cs_idx] != 0)\n cat(sprintf(\" CS%d: %d %s\\n\", i, sentinel, ifelse(tp, \"TP\", \"FP\")))\n }\n}\n\nplot_cs_effects(fit_susie, b, main = \"SuSiE CS on true effects\")\n```\n\nSuSiE identifies 5 credible sets, but examining them more closely reveals a problem.\nMany of these credible sets appear to be false positives arising from\nsynthetic associations.\n\nA synthetic association occurs when a non-causal variant shows an association\nwith the phenotype because it is in LD with true causal variants. The non-causal\nvariant \"borrows\" signal from correlated effect variants, and when it is\ncorrelated with multiple effect variants, these contributions can accumulate\nto create an inflated signal.\n\nLet's examine one of the false positive credible sets to see this in action:\n\n```{r}\nnonzero_idx <- which(b != 0)\nfp_cs <- fit_susie$sets$cs[[\"L4\"]]\ntop_var <- fp_cs[which.max(fit_susie$pip[fp_cs])]\n\ncat(\"False positive CS top variant:\", top_var, \"\\n\")\ncat(\"True effect (beta):\", b[top_var], \"\\n\")\ncat(\"Z-score:\", round(z_scores[top_var], 2), \"\\n\\n\")\n\ncat(\"LD with true effect variants and their contributions:\\n\")\ncontributions <- data.frame(\n variant = nonzero_idx,\n r = round(sapply(nonzero_idx, function(v) cor(X[, top_var], X[, v])), 2),\n beta = round(b[nonzero_idx], 2)\n)\ncontributions$r_times_beta <- round(contributions$r * contributions$beta, 2)\ncontributions <- contributions[order(-abs(contributions$r_times_beta)), ]\nprint(head(contributions[abs(contributions$r) > 0.1, ], 6), row.names = FALSE)\n```\n\nVariant `r top_var` has **no true effect** (beta = 0), yet it has a z-score of\n`r round(z_scores[top_var], 2)`. This synthetic signal arises because it is\ncorrelated with multiple effect variants. Notice that:\n\n- It has **negative LD** with negative-effect variants (2714, 2939, 2943), giving **positive** contributions\n- It has **positive LD** with a positive-effect variant (2903), also giving a **positive** contribution\n\nThese contributions accumulate to create a synthetic signal at the non-causal\nvariant, which SuSiE then incorrectly identifies as a distinct effect. The other\nfalse positive credible sets arise from the same artifact.\n\n## Step 2: Increasing Purity to Reduce False Positives\n\nOne approach to reduce false positives is to increase the purity threshold.\nBy default, SuSiE uses `min_abs_corr = 0.5`. Let's try `min_abs_corr = 0.8`:\n\n```{r}\ncs_pure <- susie_get_cs(fit_susie, X = X, min_abs_corr = 0.8)\ncat(\"Number of CSs with purity >= 0.8:\", length(cs_pure$cs), \"\\n\")\n```\n\nRaising the purity threshold removes some false positives, but not all of them.\nSome false positive credible sets have high purity because the non-causal\nvariants within them are highly correlated with each other. These sets pass the\npurity filter yet still fail to contain any true causal variants.\n\n## Step 3: Fitting SuSiE-inf\n\nSuSiE-inf models an infinitesimal component to account for unmappable effects:\n\n```{r}\nt0 <- proc.time()\nfit_inf <- susie(X, y, L = 10, unmappable_effects = \"inf\")\nt1 <- proc.time()\nt1 - t0\nsusie_plot(fit_inf, y = \"PIP\", b = b, main = \"SuSiE-inf\", add_legend = TRUE)\n```\n\n(Note that it may take several minutes to fit the SuSiE-Inf model.)\n\n```{r}\nplot_cs_effects(fit_inf, b, main = \"SuSiE-inf CS on true effects\")\n```\n\nSuSiE-inf is more conservative and finds only 1 credible set, eliminating the\nfalse positives. However, it also loses the true signal around position 3500\nthat standard SuSiE correctly identified.\n\nRemarkably, SuSiE-inf identifies the variant with the strongest true effect, the \nsame variant we noted earlier has a very small marginal z-score and large p-value:\n\n```{r}\nif (length(fit_inf$sets$cs) > 0) {\n inf_cs <- fit_inf$sets$cs[[1]]\n cat(\"SuSiE-inf CS contains variant\", strongest_idx, \":\", strongest_idx %in% inf_cs, \"\\n\")\n cat(\"This variant has the largest true effect (beta =\", round(b[strongest_idx], 3), \n \") but marginal z-score of only\", round(z_scores[strongest_idx], 3), \"\\n\")\n}\n```\n\nThis is a striking, as SuSiE-inf recovers the strongest causal signal that is completely \ninvisible in marginal statistics. The intuition is that by modeling background polygenic \neffects, SuSiE-inf effectively conditions on other variants, revealing signals that are otherwise masked.\n\nHowever, for other signals, even if we lower the coverage threshold, we cannot recover \nthem, potentially because SuSiE-inf was too aggressive removing them early-on in the SuSiE fit:\n\n```{r}\nfor (cov in c(0.9, 0.8, 0.7, 0.5)) {\n cs <- susie_get_cs(fit_inf, X = X, coverage = cov)\n cat(sprintf(\"Coverage=%.1f: %d credible sets\\n\", cov, length(cs$cs)))\n}\n```\n\n## Step 4: SuSiE-ash Achieves the Middle Ground\n\nSuSiE-ash uses adaptive shrinkage to model the unmappable effects, providing\na middle ground between standard SuSiE and SuSiE-inf:\n\n```{r}\nt0 <- proc.time()\nfit_ash <- susie(X, y, L = 10, unmappable_effects = \"ash\", verbose = TRUE)\nt1 <- proc.time()\nt1 - t0\nsusie_plot(fit_ash, y = \"PIP\", b = b, main = \"SuSiE-ash\", add_legend = TRUE)\n```\n\n(Note that it may take several minutes to fit the SuSiE-ash model.)\n\n```{r}\nplot_cs_effects(fit_ash, b, main = \"SuSiE-ash CS on true effects\")\n```\n\nSuSiE-ash finds 3 correct credible sets.\n\nStill, it does not discover all 23 causal variants, nor does it recover the strongest effect (variant 2714) that SuSiE-inf found.\nHowever, the adaptive shrinkage approach allows SuSiE-ash to distinguish between true\nsparse signals and the polygenic background more effectively than either\nstandard SuSiE or SuSiE-inf alone.\n\n\nSuSiE-ash can also be used with summary statistics via `susie_ss()`, using\n`mr.ash.rss` as the backend for the adaptive shrinkage component. This enables\nfine-mapping with unmappable effects when only sufficient statistics (X'X, X'y,\ny'y) are available.\n\n```{r}\nXtX <- crossprod(X)\nXty <- crossprod(X, y)\nyty <- sum(y^2)\nn <- nrow(X)\n\nt0 <- proc.time()\nfit_ash_ss <- susie_ss(XtX = XtX, Xty = Xty, yty = yty, n = n,\n L = 10, unmappable_effects = \"ash\", verbose = TRUE)\nt1 <- proc.time()\nt1 - t0\nsusie_plot(fit_ash_ss, y = \"PIP\", b = b, main = \"SuSiE-ash (SS)\", add_legend = TRUE)\n```\n\n```{r}\nplot_cs_effects(fit_ash_ss, b, main = \"SuSiE-ash (SS) CS on true effects\")\n```\n\nWe can verify the agreement between the two approaches:\n\n```{r}\npip_ind <- susie_get_pip(fit_ash)\npip_ss <- susie_get_pip(fit_ash_ss)\ncat(\"Max |PIP difference|:\", max(abs(pip_ind - pip_ss)), \"\\n\")\ncat(\"PIP correlation:\", cor(pip_ind, pip_ss), \"\\n\")\ncat(\"Max |theta difference|:\", max(abs(fit_ash$theta - fit_ash_ss$theta)), \"\\n\")\n```\n\nWhen only GWAS summary statistics are available, `susie_rss()` can be used.\nFor best agreement with individual-level analysis, we recommend providing\neffect sizes (`bhat`), standard errors (`shat`), and the phenotypic variance\n(`var_y`) along with the in-sample LD matrix (`R`) and sample size (`n`).\nThis preserves the original data scale, allowing the adaptive shrinkage\ncomponent to calibrate correctly:\n\n```{r}\nR <- cor(X)\nbhat <- sumstats$betahat\nshat <- sumstats$sebetahat\n\nt0 <- proc.time()\nfit_ash_rss <- susie_rss(bhat = bhat, shat = shat, R = R,\n var_y = var(y), n = n,\n L = 10, unmappable_effects = \"ash\",\n estimate_residual_variance = TRUE, verbose = TRUE)\nt1 <- proc.time()\nt1 - t0\nsusie_plot(fit_ash_rss, y = \"PIP\", b = b, main = \"SuSiE-ash (RSS)\", add_legend = TRUE)\n```\n\n```{r}\nplot_cs_effects(fit_ash_rss, b, main = \"SuSiE-ash (RSS) CS on true effects\")\n```\n\nWith `bhat`, `shat`, `var_y`, and in-sample LD, `susie_rss` results match\n`susie_ss` closely:\n\n```{r}\npip_rss <- susie_get_pip(fit_ash_rss)\ncat(\"Max |PIP difference| (SS vs RSS):\", max(abs(pip_ss - pip_rss)), \"\\n\")\ncat(\"PIP correlation (SS vs RSS):\", cor(pip_ss, pip_rss), \"\\n\")\n```\n\nWhen only z-scores and an LD matrix are available (without `bhat`, `shat`,\nor `var_y`), `susie_rss` operates on a standardized scale where `var(y) = 1`.\nThe credible sets are typically still correct, but the estimated `sigma2`\nwill be on the standardized scale rather than the original scale.\nNote that when the LD matrix is not computed from the same sample as the\nsummary statistics (out-of-sample LD), setting\n`estimate_residual_variance = FALSE` may be more appropriate to avoid\nbias from LD mismatch.\n\n## Summary\n\n| Method | Credible Sets | False Positives |\n|--------|---------------|-----------------|\n| SuSiE (purity=0.5) | 5 | 4 |\n| SuSiE (purity=0.8) | 3 | 2 |\n| SuSiE-inf | 1 | 0 |\n| SuSiE-ash | 3 | 0 |\n| SuSiE-ash (SS) | 3 | 0 |\n| SuSiE-ash (RSS) | 3 | 0 |\n\n## What if we increase L for standard SuSiE?\n\nSince the true simulation has 23 causal variants, \none might ask: what if we simply increase `L` to give SuSiE more capacity? \nLet's try `L = 40`:\n\n```{r}\nt0 <- proc.time()\nfit_susie_L40 <- susie(X, y, L = 40)\nt1 <- proc.time()\nt1 - t0\nsusie_plot(fit_susie_L40, y = \"PIP\", b = b, main = \"SuSiE (L=40)\", add_legend = TRUE)\nplot_cs_effects(fit_susie_L40, b, main = \"SuSiE L=40 CS on true effects\")\n```\n\nWith `L = 40`, standard SuSiE does improve! Now it captures 4 CS with two of them true positives. \nHowever, it still produces false positives and takes considerably longer to converge.\n\nThe rationale for SuSiE-ash is to avoid this concern: rather than specifying a large `L` to account \nfor all potential effects, we use a reasonable `L` for sparse signals and let the adaptive shrinkage \ncomponent absorb effects that cannot be mapped due to insufficiently specified `L`. \nThis provides a more principled and computationally efficient approach.\n\nNaturally as a result, SuSiE-ash is more robust to the choice of `L` compared to SuSiE. \nFor this example, setting `L` anywhere from 5 to 40 yields similar results, \nunlike standard SuSiE where performance varies substantially with `L`. \n(Readers can verify this on their own with this data-set)\n\n## Session Information\n\n```{r}\nsessionInfo()\n```\n" }, { "path": "vignettes/susierss_diagnostic.Rmd", "content": "---\ntitle: \"Diagnostic for fine-mapping with summary statistics\"\nauthor: \"Yuxin Zou\"\ndate: \"`r Sys.Date()`\"\noutput: rmarkdown::html_vignette\nvignette: >\n %\\VignetteIndexEntry{Diagnostic for fine-mapping with summary statistics}\n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{UTF-8}\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(collapse = TRUE,comment = \"#\",fig.width = 5,\n fig.height = 3,fig.align = \"center\",\n fig.cap = \" \",dpi = 120)\n```\n\nThis vignette demonstrates the use of the diagnostic plot for\nassessing consistency of the summary statistics and the reference LD\nmatrix.\n\nThe `susie_rss` assumes the LD matrix accurately estimate the\ncorrelations among SNPs from the original GWAS genotype\ndata. Typically, the LD matrix comes from some public database of\ngenotypes in a suitable reference population. The inaccurate LD\ninformation leads to unreliable fine-mapping result.\n\nThe diagnostic for consistency between summary statistics and\nrefenrence LD matrix is based on the RSS model under the null with\nregularized LD matrix.\n$$\n\\hat{z} | R, \\lambda \\sim N(0, (1-\\lambda)R + \\lambda I), 0<\\lambda<1\n$$\nThe parameter $\\lambda$ is estimated by maximum likelihood. A larger\n$\\lambda$ means a greater inconsistency between summary statistics and\nthe LD matrix. The expected z score is computed for each SNP,\n$E(\\hat{z}_j | \\hat{z}_{-j})$, and plotted against the observed z\nscores.\n\n```{r}\nlibrary(susieR)\nlibrary(curl)\n```\n\n## LD information from the original genotype data\n\nWe demonstrate the diagnostic plot in a simple case, the LD matrix is\nestimated from the original genotype data. In this case, we expect the\ndiagnostic plot to confirm that the LD matrix is consistent with the\nz scores.\n\nWe use the same simulated data as in\n[fine mapping vignette](finemapping.html).\n\n```{r}\ndata(\"N3finemapping\")\nn = nrow(N3finemapping$X)\nb = N3finemapping$true_coef[,1]\nsumstats <- univariate_regression(N3finemapping$X, N3finemapping$Y[,1])\nz_scores <- sumstats$betahat / sumstats$sebetahat\nRin = cor(N3finemapping$X)\nattr(Rin, \"eigen\") = eigen(Rin, symmetric = TRUE)\nsusie_plot(z_scores, y = \"z\", b=b)\n```\n\nThe estimated $\\lambda$ is\n```{r}\nlambda = estimate_s_rss(z_scores, Rin, n=n)\nlambda\n```\n\nThe plot for the observed z scores vs the expected z scores is \n```{r}\ncondz_in = kriging_rss(z_scores, Rin, n=n)\ncondz_in$plot\n```\n\nSummary of SuSiE Credible Sets:\n```{r}\nfit <- susie_rss(z_scores, Rin, n=n, estimate_residual_variance = TRUE)\nsusie_plot(fit,y = \"PIP\", b=b)\n```\n\n## LD information from the reference panel\n\nWe use another simulated data where the LD matrix is estimated from a\nreference panel. In this example data set, there is one association\nsignal in the simulated data (red point), and there is one SNP with\nmismatched reference and alternative allele between summary statistics\nand the reference panel (yellow point).\n\n**Note:** In some versions of [PLINK][plink], these mismatches can\noccur when [PLINK automatically flips the alleles to make the minor\nallele be the effect\nallele](https://github.com/stephenslab/susieR/issues/148), leading to\ndifferent allele encodings in the z scores and LD matrix. Adding the\nflag `--keep-allele-order` will disable this behaviour in PLINK.\n\n```{r}\ndata_file <- tempfile(fileext = \".RData\")\ndata_url <- paste0(\"https://raw.githubusercontent.com/stephenslab/susieR/\",\n \"master/inst/datafiles/SummaryConsistency1k.RData\")\ncurl_download(data_url,data_file)\nload(data_file)\nzflip = SummaryConsistency$z\nld = SummaryConsistency$ldref\nn=10000\nb = numeric(length(zflip))\nb[SummaryConsistency$signal_id] = zflip[SummaryConsistency$signal_id]\nplot(zflip, pch = 16, col = \"#767676\", main = \"Marginal Associations\", \n xlab=\"SNP\", ylab = \"z scores\")\npoints(SummaryConsistency$signal_id, zflip[SummaryConsistency$signal_id], col=2, pch=16)\npoints(SummaryConsistency$flip_id, zflip[SummaryConsistency$flip_id], col=7, pch=16)\n```\nUsing the data with misaligned allele, SuSiE-RSS identifies a true positive CS containing the true effect SNP; and a false positive CS that incorrectly contains the mismatched SNP.\n```{r}\nfit = susie_rss(zflip, ld, n=n)\nsusie_plot(fit, y='PIP', b=b)\npoints(SummaryConsistency$flip_id, fit$pip[SummaryConsistency$flip_id], col=7, pch=16)\n```\n\nThe estimated $\\lambda$ is\n```{r}\nlambda = estimate_s_rss(zflip, ld, n=n)\nlambda\n```\n\nIn the diagnostic plot, the mismatched SNP shows the largest difference between observed and expected z-scores, and therefore appears furthest away from the diagonal.\n\n```{r}\ncondz = kriging_rss(zflip, ld, n=n)\ncondz$plot\n```\n\nAfter fixing the allele encoding, SuSiE-RSS identifies a single true positive CS containing the true-effect SNP, and the formerly mismatched SNP is (correctly) not included in a CS.\n\n```{r}\nz = zflip\nz[SummaryConsistency$flip_id] = -z[SummaryConsistency$flip_id]\nfit = susie_rss(z, ld, n=n)\nsusie_plot(fit, y='PIP', b=b)\n```\n\n## Session information\n\nHere are some details about the computing environment, including the\nversions of R, and the R packages, used to generate these results.\n\n```{r session-info}\nsessionInfo()\n```\n\n[plink]: https://www.cog-genomics.org/plink\n" }, { "path": "vignettes/trend_filtering.Rmd", "content": "---\ntitle: \"Trend filtering\"\nauthor: \"Matthew Stephens\"\ndate: \"`r Sys.Date()`\"\noutput: rmarkdown::html_vignette\nvignette: >\n %\\VignetteIndexEntry{Trend filtering}\n %\\VignetteEngine{knitr::rmarkdown}\n %\\VignetteEncoding{UTF-8}\n---\n\n```{r setup, include=FALSE}\nknitr::opts_chunk$set(collapse = TRUE,comment = \"#\",fig.width = 4.5,\n fig.height = 3,fig.align = \"center\",\n fig.cap = \" \",dpi = 120)\n```\n\n# Introduction\n\nAlthough we developed SuSiE primarily with the goal of performing\nvariable selection in highly sparse settings -- and, in particular,\nfor genetic fine-mapping -- the approach also has considerable\npotential for application to other large-scale regression\nproblems. Here we briefly illustrate this potential by applying it to\na non-parametric regression problem that at first sight seems to be\nill-suited to our approach. In particular, it does not involve strict\nsparsity, and the underlying correlation structure of the explanatory\nvariables is very different from the \"blocky\" covariance structure of\ngenetic data that SuSiE was designed for. Nonetheless, we will see\nthat SuSiE performs well here despite this (partly due to its ability\nto capture non-sparse signals via Bayesian Model Averaging).\n\nSpecifically, consider the non-parametric regression:\n$$y_t = \\mu_t + e_t \\quad t=1,\\dots,T$$\nwhere the goal is to estimate the underlying mean, $\\mu_t$, under the assumption that it varies smoothly (or, more precisely, in a spatially-structured way) with $t$.\nOne very simple way to capture spatial structure in $\\mu$ is to model it\nas a (sparse) linear combination of step functions:\n$$\\mu = Xb$$ \nwhere the $j$th column of $X$ is the step function with a step at $j$ ($j = 1,\\dots,(T-1)$); that is $x_{tj}=0$ for $t<=j$ and 1 for $t>j$.\nThe $j$th element of $b$ therefore determines the change in the mean $|\\mu_j-\\mu_{j+1}|$, and an assumption that $b$ is sparse encapsulates an\nassumption that $\\mu$ is spatially structured (indeed, piecewise constant).\n\nThis very simple approach is essentially 0th-order trend filtering\n(Tibshirani, 2014, *Annals of Statistics* 42, 285--323). Note that\nhigher-order trend filtering can be similarly implemented using\ndifferent basis functions; here we use 0th order only for simplicity.\n\n\n# Examples\n\nHere we apply SuSiE to perform 0th order trend filtering in some simple simulated examples. We have implemented in `susieR` 0.6.0 a funciton `susie_trendfilter` which internally creates $X$ matrix with step functions in the columns to match input $y$. The algebra have been optimized to work on such trendfiltering matrices. Here we simulate some data where $\\mu$ is a step function with four steps, a 0th order trendfiltering problem. The regression is truly sparse and SuSiE should do well.\n\n```{r}\nlibrary(susieR)\nset.seed(1)\nn=1000\nmu = c(rep(0,100),rep(1,100),rep(3,100),rep(-2,100),rep(0,600))\ny = mu + rnorm(n)\ns = susie_trendfilter(y, 0, L=10)\n```\n\nPlot results: the truth is black, and susie estimate is red.\n```{r}\nplot(y,pch=\".\")\nlines(mu,col=1,lwd=3)\nlines(predict(s),col=2,lwd=2)\ns$sigma2\n```\n\nIn the next example mu increases linearly. Thus we are approximating a\nlinear function by step functions. Here the truth is not trully\n\"sparse\", so we might expect performance to be poor, but it is not too\nbad.\n\n```{r}\nset.seed(1)\nmu = seq(0,4,length=1000)\ny = mu + rnorm(n)\ns = susie_trendfilter(y,0,L=10)\nplot(y,pch=\".\")\nlines(mu,col=1,lwd=3)\nlines(predict(s),col=2,lwd=2)\n```\n\nCompare with the genlasso (lasso-based) solution (blue). (This will\nrequire installation of the `genlasso` package, which is not available\non CRAN, but can be installed from GitHub.)\n\n```{r, eval=FALSE}\n# install.packages(\"remotes\")\n# remotes::install_github(\"glmgen/genlasso\")\ny.tf = trendfilter(y,ord=0)\ny.tf.cv = cv.trendfilter(y.tf)\nplot(y,pch=\".\")\nlines(mu,col=1,lwd=3)\nlines(predict(s),col=2,lwd=2)\nlines(y.tf$fit[,which(y.tf$lambda==y.tf.cv$lambda.min)],col=4,lwd=2)\n```\n\nWhat happens if we have linear trend plus a sudden change.\n\n```{r, eval=FALSE}\nset.seed(1)\nmu = seq(0,4,length=1000)\nmu = mu + c(rep(0,500),rep(4,500))\ny = mu + rnorm(n)\ns = susie_trendfilter(y,0,L=10)\ny.tf = trendfilter(y,ord=0)\ny.tf.cv = cv.trendfilter(y.tf)\nplot(y,pch=\".\")\nlines(mu,col=1,lwd=3)\nlines(predict(s),col=2,lwd=2)\nlines(y.tf$fit[,which(y.tf$lambda==y.tf.cv$lambda.min)],col=4,lwd=2)\n```\n\nThe two fits seem similar in accuracy. We can check this numerically:\n```{r, eval=FALSE}\nsqrt(mean((mu-y.tf$fit[,which(y.tf$lambda==y.tf.cv$lambda.min)])^2))\nsqrt(mean((mu-predict(s))^2))\n```\n\n" } ]