`,
+ 'log:check': `Devtools checks`
+ }});
diff --git a/.github/workflows/dsBaseClient_test_suite.yaml b/.github/workflows/dsBaseClient_test_suite.yaml
index fb4ed9893..c094b4a41 100644
--- a/.github/workflows/dsBaseClient_test_suite.yaml
+++ b/.github/workflows/dsBaseClient_test_suite.yaml
@@ -1,245 +1,839 @@
################################################################################
+# trigger CI
# DataSHIELD GHA test suite - dsBaseClient
-# Adapted from `armadillo_azure-pipelines.yml` by Roberto Villegas-Diaz
+# Replaces azure-pipelines.yml / opal_azure-pipelines.yml / armadillo_azure-pipelines.yml.
#
-# Inside the root directory $(Pipeline.Workspace) will be a file tree like:
-# /dsBaseClient <- Checked out version of datashield/dsBaseClient
-# /dsBaseClient/logs <- Where results of tests and logs are collated
-# /testStatus <- Checked out version of datashield/testStatus
+# This is one of three separate workflow files, each its own named check on a
+# PR/run: this one (all the actual test execution), check.yaml (doc-sync +
+# R CMD check), lint.yaml (lintr). Split so each shows as its own category
+# rather than one graph mixing test execution with static checks.
#
-# As of Sept. 2025 this takes ~ 95 mins to run.
+# Structure (all jobs below run in parallel except where "needs" says otherwise):
+# opal-dsbase (matrix x8) - dsBase suite against Opal, one shard per
+# category, plus a dsdanger entry, all grouped under
+# one summary box.
+# opal-report - needs opal-dsbase; merges results, computes its own
+# pass/fail, posts its own row into the shared PR
+# comment (see .github/scripts/post-ci-comment.js).
+# armadillo-dsbase (matrix x8) - dsBase suite against Armadillo, same split.
+# armadillo-report - needs armadillo-dsbase; same as opal-report, plus
+# coverage (computed here only - see comment at that
+# step for why one backend's figure is sufficient).
+#
+# There is no separate combining/summary job: dsBaseClient's own R/ source
+# never branches on backend, so Armadillo and Opal results are independently
+# meaningful and each report job stands alone (gate on both being required
+# checks in branch protection, rather than one job that waits on both).
+#
+# The dsBase suite (matching TEST_FILTER_DSBASE - same 292 files the Azure
+# pipelines run) is split into 7 shards - smk (116 files, 2 shards), perf (51
+# fixed 30s-loop benchmarks, 3 shards - by far the slowest per-file), arg (1
+# shard), and misc (1 shard) - each shard with its own testthat filter
+# substring. smk/perf are split by the first letter of the function name
+# (after any "ds." prefix) rather than an enumerated file list, so newly
+# added test files fall into a bucket automatically. The small dsDanger suite
+# is folded in as an 8th matrix entry (steps gated on matrix.category ==
+# 'dsdanger') rather than a standalone job, so it groups under the same
+# summary box instead of its own. This is one job with a matrix (not split
+# into separate job definitions per category) so all entries share one
+# summary box in the run graph, and so they don't share a reusable workflow
+# name - GitHub's default same-name concurrency cap of 2 would otherwise
+# throttle them to 2-at-a-time. Setup (checkout through installing dsBase)
+# lives in a shared composite action (setup-armadillo-with-dsbase /
+# setup-opal-with-dsbase), used by every matrix entry including dsdanger, so
+# that part stays DRY.
+#
+# Each dsbase/dsdanger job spins up its OWN backend instance (isolated - no
+# shared server state / concurrency risk between categories running at once).
+#
+# Opal runs via docker-compose (docker-compose_opal.yml).
+# Armadillo runs as a plain `java -jar` process (not docker-compose): Armadillo
+# self-manages its Rock container over the host Docker socket
+# (docker-management-enabled: true / docker-run-in-container: false), which skips
+# building/pulling the old custom armadillo_citest image. See
+# molgenis-service-armadillo's application.template.yml for that flag pairing.
+#
+# Every job starts its backend as the very first step so it boots in the
+# background while R dependencies install, instead of paying for both serially.
+#
+# As of Sept. 2025 the single-backend, dsBase-only, unsharded version of this
+# took ~ 95 mins; the full (Opal+Armadillo, dsBase+dsDanger) unsharded run is
+# well over an hour.
################################################################################
name: dsBaseClient tests' suite
on:
push:
+ branches: [main, master, 'v*-dev']
+ pull_request:
+ workflow_dispatch:
+ inputs:
+ dsbase-ref:
+ description: dsBase branch, tag or SHA to test against
+ required: false
+ default: v7.0-dev
schedule:
- cron: '0 0 * * 0' # Weekly
- cron: '0 1 * * *' # Nightly
+# A new push to the same ref supersedes any run still in progress for it, so
+# we don't burn compute on stale commits. Scoped by event_name too, so a
+# schedule/workflow_dispatch run is never auto-cancelled by an unrelated push.
+concurrency:
+ group: ${{ github.workflow }}-${{ github.ref }}-${{ github.event_name }}
+ cancel-in-progress: ${{ github.event_name == 'push' || github.event_name == 'pull_request' }}
+
+permissions:
+ contents: read
+
+env:
+ _r_check_system_clock_: 0
+ PROJECT_NAME: dsBaseClient
+ BRANCH_NAME: ${{ github.head_ref || github.ref_name }}
+ DSBASE_REF: ${{ inputs.dsbase-ref || 'v7.0-dev' }}
+ R_KEEP_PKG_SOURCE: yes
+ # Selects perf_files/__perf-profile.csv as the perf
+ # test reference rates/tolerances (see tests/testthat/perf_tests/perf_rate.R).
+ # Reuses the existing azure-pipeline reference files rather than adding new
+ # ones, matching what the old Azure pipelines set via perf.profile.
+ PERF_PROFILE: github-workflows
+ # dsBase shards get their filter from matrix.filter per entry instead.
+ TEST_FILTER_DSDANGER: '__dgr-|datachk_dgr-|smk_dgr-|arg_dgr-|disc_dgr-|smk_expt_dgr-|expt_dgr-|math_dgr-'
+
jobs:
- dsBaseClient_test_suite:
+
+ # Runs immediately (no `needs`) so the two test rows reset to pending as
+ # soon as a new commit lands, rather than showing the previous commit's
+ # result for the ~20-60 min the matrix jobs take to complete.
+ mark-pending:
+ name: Mark tests pending
runs-on: ubuntu-latest
- timeout-minutes: 120
+ timeout-minutes: 5
permissions:
contents: read
-
- # These should all be constant, except TEST_FILTER. This can be used to test
- # subsets of test files in the testthat directory. Options are like:
- # '*' <- Run all tests.
- # 'asNumericDS*' <- Run all asNumericDS tests, i.e. all the arg, etc. tests.
- # '*_smk_*' <- Run all the smoke tests for all functions.
+ pull-requests: write
+ steps:
+ - name: Checkout dsBaseClient
+ uses: actions/checkout@v5
+ with:
+ path: dsBaseClient
+
+ - name: Mark pending
+ uses: actions/github-script@v8
+ with:
+ script: |
+ const postCiComment = require('${{ github.workspace }}/dsBaseClient/.github/scripts/post-ci-comment.js');
+ await postCiComment({ github, context, updates: {
+ 'row:tests-armadillo': `
Armadillo unit tests
⏳ pending
`,
+ 'row:tests-opal': `
Opal unit tests
⏳ pending
`,
+ 'row:coverage': `
Test coverage
⏳ pending
`,
+ 'ver:armadillo': `_pending_`,
+ 'ver:opal': `_pending_`,
+ 'log:tests-armadillo': `_pending_`,
+ 'log:tests-opal': `_pending_`,
+ 'log:coverage': `_pending_`
+ }});
+
+ ################################################################################
+ # Opal - dsBase suite, sharded, plus dsDanger folded in as an extra matrix
+ # entry. Each entry is a fully isolated job with its own Opal instance.
+ ################################################################################
+ # One job, 8-entry matrix, so all entries group under a single summary box
+ # in the run graph (previously split into 3 category-group jobs calling a
+ # reusable workflow - reverted since that lost the combined summary and,
+ # worse, made all calls share the reusable workflow's name, which triggers
+ # GitHub's default same-name concurrency cap of 2 and throttled the shards
+ # to 2-at-a-time instead of running in parallel).
+ opal-dsbase:
+ name: Opal tests (${{ matrix.category }})
+ runs-on: ubuntu-latest
+ timeout-minutes: 60
+ strategy:
+ fail-fast: false
+ # smk and perf are split by the first letter of the function name
+ # (after any "ds." prefix) rather than an enumerated file list, so
+ # newly added test files fall into a bucket automatically. dsdanger is
+ # a separate, smaller suite (steps below are gated on
+ # matrix.category == 'dsdanger') folded in here so it groups under this
+ # job's summary box instead of a standalone job.
+ matrix:
+ include:
+ - category: smk-1
+ filter: 'smk-ds.[a-lA-L]|smk-(checkClass|isDefined)'
+ - category: smk-2
+ filter: 'smk-ds.[m-vM-V]'
+ - category: arg
+ filter: 'arg-'
+ - category: perf-1
+ filter: 'perf-ds.[a-cA-C]'
+ - category: perf-2
+ filter: 'perf-ds.[d-mD-M]'
+ - category: perf-3
+ filter: 'perf-ds.[n-vN-V]|perf-(conndisconn|void)'
+ - category: misc
+ filter: 'datachk-|disc-|expt-|smk_expt-|math-|_-'
+ - category: dsdanger
env:
- TEST_FILTER: '_-|datachk-|smk-|arg-|disc-|perf-|smk_expt-|expt-|math-'
- _r_check_system_clock_: 0
- WORKFLOW_ID: ${{ github.run_id }}-${{ github.run_attempt }}
PROJECT_NAME: dsBaseClient
- BRANCH_NAME: ${{ github.head_ref || github.ref_name }}
- REPO_OWNER: ${{ github.repository_owner }}
- R_KEEP_PKG_SOURCE: yes
- GITHUB_TOKEN: ${{ github.token || 'placeholder-token' }}
-
+ DS_DRIVER: OpalDriver
+ DSDANGER_REF: '6.3.4'
steps:
- name: Checkout dsBaseClient
- uses: actions/checkout@v4
+ uses: actions/checkout@v5
with:
path: dsBaseClient
- - name: Checkout testStatus
- if: ${{ github.actor != 'nektos/act' }} # for local deployment only
- uses: actions/checkout@v4
- with:
- repository: ${{ env.REPO_OWNER }}/testStatus
- ref: master
- path: testStatus
- persist-credentials: false
- token: ${{ env.GITHUB_TOKEN }}
-
- - name: Uninstall default MySQL
+ - uses: ./dsBaseClient/.github/actions/setup-opal-with-dsbase
+ with:
+ dsbase-ref: ${{ env.DSBASE_REF }}
+
+ - name: Install dsDangerClient
+ if: matrix.category == 'dsdanger'
+ run: |
+ R -q -e "
+ ref <- Sys.getenv('BRANCH_NAME')
+ ok <- tryCatch({ pak::pkg_install(sprintf('github::datashield/dsDangerClient@%s', ref)); TRUE }, error = function(e) FALSE)
+ if (!ok) pak::pkg_install('github::datashield/dsDangerClient')"
+
+ - name: Install dsDanger package on Opal server
+ if: matrix.category == 'dsdanger'
+ run: |
+ R -q -e "library(opalr); opal <- opal.login(username = 'administrator', password = 'datashield_test&', url = 'http://localhost:8080'); opal.put(opal, 'system', 'conf', 'general', '_rPackage'); opal.logout(opal)"
+ R -q -e "library(opalr); opal <- opal.login('administrator','datashield_test&', url='http://localhost:8080/'); dsadmin.install_github_package(opal, 'dsDanger', username = 'datashield', ref = '${{ env.DSDANGER_REF }}'); opal.logout(opal)"
+ working-directory: dsBaseClient
+
+ - name: Run dsBase tests with JUnit report
+ if: matrix.category != 'dsdanger'
+ run: |
+ R -q -e '
+ devtools::load_all(quiet = TRUE);
+ library(testthat);
+ output_file <- file("test_console_output_dsbase.txt");
+ sink(output_file, split = TRUE);
+ junit_rep <- JunitReporter$new(file = file.path(getwd(), "test_results_dsbase.xml"));
+ progress_rep <- ProgressReporter$new(max_failures = 999999);
+ multi_rep <- MultiReporter$new(reporters = list(progress_rep, junit_rep));
+ options("datashield.return_errors" = FALSE, "default_driver" = "${{ env.DS_DRIVER }}");
+ test_dir("tests/testthat", filter = "${{ matrix.filter }}", reporter = multi_rep, stop_on_failure = FALSE)' || R_EXIT=$?
+ cat test_console_output_dsbase.txt
+ n_tests=$(grep -c ' entries in test_results_dsbase.xml) - treating as a failure rather than a silent pass."
+ R_EXIT=1
+ fi
+ n_failed=$(grep -oE '<(failure|error)[ >]' test_results_dsbase.xml | wc -l | tr -d ' ')
+ if [ "${R_EXIT:-0}" -eq 0 ] && [ "${n_failed:-0}" -gt 0 ]; then
+ echo "$n_failed test failure(s)/error(s) in test_results_dsbase.xml - failing this shard."
+ R_EXIT=1
+ fi
+ exit "${R_EXIT:-0}"
+ working-directory: dsBaseClient
+
+ - name: Run dsDanger tests with JUnit report
+ if: matrix.category == 'dsdanger'
+ run: |
+ R -q -e '
+ devtools::load_all(quiet = TRUE);
+ library(testthat);
+ output_file <- file("test_console_output_dsdanger.txt");
+ sink(output_file, split = TRUE);
+ junit_rep <- JunitReporter$new(file = file.path(getwd(), "test_results_dsdanger.xml"));
+ progress_rep <- ProgressReporter$new(max_failures = 999999);
+ multi_rep <- MultiReporter$new(reporters = list(progress_rep, junit_rep));
+ options("datashield.return_errors" = FALSE, "default_driver" = "${{ env.DS_DRIVER }}");
+ test_dir("tests/testthat", filter = "${{ env.TEST_FILTER_DSDANGER }}", reporter = multi_rep, stop_on_failure = FALSE)' || R_EXIT=$?
+ cat test_console_output_dsdanger.txt
+ n_tests=$(grep -c ' entries in test_results_dsdanger.xml) - treating as a failure rather than a silent pass."
+ R_EXIT=1
+ fi
+ n_failed=$(grep -oE '<(failure|error)[ >]' test_results_dsdanger.xml | wc -l | tr -d ' ')
+ if [ "${R_EXIT:-0}" -eq 0 ] && [ "${n_failed:-0}" -gt 0 ]; then
+ echo "$n_failed test failure(s)/error(s) in test_results_dsdanger.xml - failing this shard."
+ R_EXIT=1
+ fi
+ exit "${R_EXIT:-0}"
+ working-directory: dsBaseClient
+
+ # Written regardless of outcome so opal-report can tell a shard that
+ # never reported (crashed in setup, before any test XML existed) apart
+ # from one that reported 0 failures - job.status already reflects the
+ # test step's exit code by this point. mkdir -p so this still succeeds
+ # even if checkout itself is what failed. Written under dsBaseClient/,
+ # alongside everything else in the same upload below, so upload-artifact
+ # doesn't widen its common-ancestor computation to the workspace root
+ # and shift every other file down an extra directory level.
+ - name: Record shard outcome
+ if: always()
run: |
- curl https://bazel.build/bazel-release.pub.gpg | sudo apt-key add -
- sudo service mysql stop || true
- sudo apt-get update
- sudo apt-get remove --purge mysql-client mysql-server mysql-common -y
- sudo apt-get autoremove -y
- sudo apt-get autoclean -y
- sudo rm -rf /var/lib/mysql/
-
- - uses: r-lib/actions/setup-pandoc@v2
+ mkdir -p dsBaseClient
+ echo "${{ job.status }}" > dsBaseClient/shard_status.txt
+
+ - name: Upload shard results
+ if: always() && matrix.category != 'dsdanger'
+ uses: actions/upload-artifact@v6
+ with:
+ name: opal-dsbase-${{ matrix.category }}
+ path: |
+ dsBaseClient/test_results_dsbase.xml
+ dsBaseClient/test_console_output_dsbase.txt
+ dsBaseClient/tests/testthat/data_files/dsbase_version.txt
+ dsBaseClient/shard_status.txt
+
+ - name: Upload dsDanger results
+ if: always() && matrix.category == 'dsdanger'
+ uses: actions/upload-artifact@v6
+ with:
+ name: opal-dsdanger
+ path: |
+ dsBaseClient/test_results_dsdanger.xml
+ dsBaseClient/test_console_output_dsdanger.txt
+ dsBaseClient/shard_status.txt
+
+
+ ################################################################################
+ # Opal - merge all matrix entry results and publish the report.
+ ################################################################################
+ opal-report:
+ name: Opal report
+ needs: [opal-dsbase]
+ if: always()
+ runs-on: ubuntu-latest
+ timeout-minutes: 30
+ permissions:
+ contents: read
+ pull-requests: write
+ steps:
+ - name: Checkout dsBaseClient
+ uses: actions/checkout@v5
+ with:
+ path: dsBaseClient
- uses: r-lib/actions/setup-r@v2
with:
r-version: release
- http-user-agent: release
use-public-rspm: true
- - name: Install R and dependencies
- run: |
- sudo apt-get install --no-install-recommends software-properties-common dirmngr -y
- wget -qO- https://cloud.r-project.org/bin/linux/ubuntu/marutter_pubkey.asc | sudo tee -a /etc/apt/trusted.gpg.d/cran_ubuntu_key.asc
- sudo add-apt-repository "deb https://cloud.r-project.org/bin/linux/ubuntu $(lsb_release -cs)-cran40/"
- sudo apt-get update -qq
- sudo apt-get upgrade -y
- sudo apt-get install -qq libxml2-dev libcurl4-openssl-dev libssl-dev libgsl-dev libgit2-dev r-base -y
- sudo apt-get install -qq libharfbuzz-dev libfribidi-dev libmagick++-dev xml-twig-tools -y
- sudo R -q -e "install.packages(c('devtools','covr','fields','meta','metafor','ggplot2','gridExtra','data.table','DSI','DSOpal','DSLite','MolgenisAuth','MolgenisArmadillo','DSMolgenisArmadillo','DescTools','e1071'), repos='https://cloud.r-project.org')"
- sudo R -q -e "devtools::install_github(repo='datashield/dsDangerClient', ref=Sys.getenv('BRANCH_NAME'))"
-
- uses: r-lib/actions/setup-r-dependencies@v2
+ env:
+ PKG_INCLUDE_LINKINGTO: true
+ with:
+ working-directory: dsBaseClient
+ dependencies: 'c("Depends", "Imports", "LinkingTo")'
+ extra-packages: |
+ cran::xml2
+
+ - name: Download shard/dsdanger results
+ uses: actions/download-artifact@v7
with:
- dependencies: 'c("Imports")'
- extra-packages: |
- any::rcmdcheck
- cran::devtools
- cran::git2r
- cran::RCurl
- cran::readr
- cran::magrittr
- cran::xml2
- cran::purrr
- cran::dplyr
- cran::stringr
- cran::tidyr
- cran::quarto
- cran::knitr
- cran::kableExtra
- cran::rmarkdown
- cran::downlit
- needs: check
-
- - name: Check manual updated
+ pattern: 'opal-*'
+ path: dsBaseClient/artifacts
+
+ - name: Merge JUnit results
run: |
- orig_sum=$(find man -type f | sort -u | xargs cat | md5sum)
- R -q -e "devtools::document()"
- new_sum=$(find man -type f | sort -u | xargs cat | md5sum)
- if [ "$orig_sum" != "$new_sum" ]; then
- echo "Your committed man/*.Rd files are out of sync with the R headers."
- exit 1
- fi
+ mkdir -p logs
+ cat artifacts/*/test_console_output_*.txt > logs/test_console_output.txt
+
+ Rscript -e '
+ xml_files <- list.files("artifacts", pattern = "^test_results_.*\\.xml$", recursive = TRUE, full.names = TRUE)
+ docs <- lapply(xml_files, xml2::read_xml)
+ root <- xml2::xml_new_root("testsuites")
+ for (doc in docs) {
+ for (s in xml2::xml_find_all(doc, ".//testsuite")) xml2::xml_add_child(root, s)
+ }
+ xml2::write_xml(root, "logs/test_results.xml")
+ '
working-directory: dsBaseClient
- continue-on-error: true
- - name: Devtools checks
+ - name: Upload merged results
+ uses: actions/upload-artifact@v6
+ with:
+ name: opal-report-results
+ path: |
+ dsBaseClient/logs/test_results.xml
+ dsBaseClient/logs/test_console_output.txt
+
+ - name: Compute results & write summary
+ id: results
+ env:
+ OPAL_DSBASE_RESULT: ${{ needs.opal-dsbase.result }}
run: |
- R -q -e "devtools::check(args = c('--no-examples', '--no-tests'))" | tee azure-pipelines_check.Rout
- grep --quiet "^0 errors" azure-pipelines_check.Rout && grep --quiet " 0 warnings" azure-pipelines_check.Rout && grep --quiet " 0 notes" azure-pipelines_check.Rout
- working-directory: dsBaseClient
- continue-on-error: true
-
- - name: Start Armadillo docker-compose
- run: docker compose -f docker-compose_armadillo.yml up -d --build
+ Rscript -e '
+ source(".github/scripts/summarise-junit.R")
+ res <- summarise_junit("logs/test_results.xml", "Opal", "artifacts")
+ writeLines(res$summary, Sys.getenv("GITHUB_STEP_SUMMARY"))
+ cat(res$summary, sep = "\n")
+
+ version <- find_dsbase_version("artifacts")
+
+ # needs.opal-dsbase.result is "failure" if ANY matrix shard did not
+ # succeed (even if the shards that DID upload results show 0
+ # failures) - a shard that never reported must not look like a pass.
+ shard_ok <- Sys.getenv("OPAL_DSBASE_RESULT") == "success"
+ ok <- res$ok && shard_ok
+ # Only a fallback: the usual case (a shard crashed/reported 0
+ # tests) is already named above via res$shard_problems - this
+ # covers the rare gap where a shard job failed without leaving
+ # any trace summarise_junit() could identify.
+ if (!shard_ok && length(res$shard_problems) == 0) {
+ message("One or more Opal dsbase/dsdanger matrix entries did not succeed, but none could be identified from their uploaded results.")
+ }
+
+ out <- Sys.getenv("GITHUB_OUTPUT")
+ cat(
+ sprintf("ok=%s\n", tolower(ok)),
+ sprintf("tally=%s\n", res$tally),
+ sprintf("version=%s\n", version),
+ file = out, append = TRUE, sep = ""
+ )
+
+ if (!ok) message("Opal tests failed.")
+ quit(save = "no", status = if (ok) 0 else 1)
+ '
working-directory: dsBaseClient
- - name: Install test datasets
+ - name: Post PR comment
+ if: always()
+ uses: actions/github-script@v8
+ with:
+ script: |
+ // steps.results.outputs.* come back empty (not "true"/"false") if
+ // that step never got far enough to write them - e.g. it errored
+ // or was skipped outright because an earlier step failed. Fall
+ // back to something informative rather than a blank tally.
+ const ok = '${{ steps.results.outputs.ok }}' === 'true';
+ const tally = '${{ steps.results.outputs.tally }}' || 'error - see log';
+ const version = '${{ steps.results.outputs.version }}' || 'unknown';
+ // #summary- scrolls straight to this job's summary card
+ // (the pass/fail tally written via GITHUB_STEP_SUMMARY) instead
+ // of just the top of the run page.
+ const runUrl = `${context.serverUrl}/${context.repo.owner}/${context.repo.repo}/actions/runs/${context.runId}#summary-${{ job.check_run_id }}`;
+
+ const postCiComment = require('${{ github.workspace }}/dsBaseClient/.github/scripts/post-ci-comment.js');
+ await postCiComment({ github, context, updates: {
+ 'row:tests-opal': `
Opal unit tests
${ok ? '✅' : '❌'} ${tally}
`,
+ 'ver:opal': `\`${version}\``,
+ 'log:tests-opal': `Opal unit tests`
+ }});
+
+
+ ################################################################################
+ # Armadillo - dsBase suite, sharded 4 ways. Each shard downloads and runs its
+ # own Armadillo jar instance.
+ #
+ # Runs as a plain `java -jar` process instead of docker-compose: Armadillo
+ # self-manages its own Rock container over the host Docker socket
+ # (docker-management-enabled: true / docker-run-in-container: false), which
+ # avoids building/pulling the old custom armadillo_citest image and its
+ # dockerised Armadillo layer. The latest GitHub release jar is downloaded at
+ # run time. No process is restarted after installing dsBase - install then
+ # whitelist directly.
+ ################################################################################
+ # One job, 8-entry matrix, so all entries group under a single summary box
+ # in the run graph (previously split into 3 category-group jobs calling a
+ # reusable workflow - reverted since that lost the combined summary and,
+ # worse, made all calls share the reusable workflow's name, which triggers
+ # GitHub's default same-name concurrency cap of 2 and throttled the shards
+ # to 2-at-a-time instead of running in parallel).
+ armadillo-dsbase:
+ name: Armadillo tests (${{ matrix.category }})
+ runs-on: ubuntu-latest
+ timeout-minutes: 60
+ strategy:
+ fail-fast: false
+ # smk and perf are split by the first letter of the function name
+ # (after any "ds." prefix) rather than an enumerated file list, so
+ # newly added test files fall into a bucket automatically. dsdanger is
+ # a separate, smaller suite (steps below are gated on
+ # matrix.category == 'dsdanger') folded in here so it groups under this
+ # job's summary box instead of a standalone job.
+ matrix:
+ include:
+ - category: smk-1
+ filter: 'smk-ds.[a-lA-L]|smk-(checkClass|isDefined)'
+ - category: smk-2
+ filter: 'smk-ds.[m-vM-V]'
+ - category: arg
+ filter: 'arg-'
+ - category: perf-1
+ filter: 'perf-ds.[a-cA-C]'
+ - category: perf-2
+ filter: 'perf-ds.[d-mD-M]'
+ - category: perf-3
+ filter: 'perf-ds.[n-vN-V]|perf-(conndisconn|void)'
+ - category: misc
+ filter: 'datachk-|disc-|expt-|smk_expt-|math-|_-'
+ - category: dsdanger
+ env:
+ PROJECT_NAME: dsBaseClient
+ DS_DRIVER: ArmadilloDriver
+ DSDANGER_TARBALL: dsDanger_6.3.4.tar.gz
+ steps:
+ - name: Checkout dsBaseClient
+ uses: actions/checkout@v5
+ with:
+ path: dsBaseClient
+
+ - uses: ./dsBaseClient/.github/actions/setup-armadillo-with-dsbase
+ with:
+ dsbase-ref: ${{ env.DSBASE_REF }}
+
+ - name: Install dsDangerClient
+ if: matrix.category == 'dsdanger'
run: |
- sleep 60
- R -q -f "molgenis_armadillo-upload_testing_datasets.R"
- working-directory: dsBaseClient/tests/testthat/data_files
+ R -q -e "
+ ref <- Sys.getenv('BRANCH_NAME')
+ ok <- tryCatch({ pak::pkg_install(sprintf('github::datashield/dsDangerClient@%s', ref)); TRUE }, error = function(e) FALSE)
+ if (!ok) pak::pkg_install('github::datashield/dsDangerClient')"
- - name: Install dsBase to Armadillo
+ - name: Install dsDanger package on Armadillo server
+ if: matrix.category == 'dsdanger'
run: |
- curl -u admin:admin -X GET http://localhost:8080/packages
- curl -u admin:admin -H 'Content-Type: multipart/form-data' -F "file=@dsBase_6.3.4-permissive.tar.gz" -X POST http://localhost:8080/install-package
- sleep 60
- docker restart dsbaseclient-armadillo-1
- sleep 30
- curl -u admin:admin -X POST http://localhost:8080/whitelist/dsBase
+ curl -u admin:admin http://localhost:8080/whitelist
+ install_status=$(curl -u admin:admin -H 'Content-Type: multipart/form-data' -F "file=@${{ env.DSDANGER_TARBALL }}" -o /dev/null -w '%{http_code}' -X POST http://localhost:8080/install-package)
+ if [ "$install_status" != "200" ]; then
+ echo "dsDanger install request failed with HTTP status $install_status"
+ exit 1
+ fi
+
+ for i in $(seq 1 30); do
+ packages_json=$(curl -sf -u admin:admin -X GET http://localhost:8080/packages || true)
+ if echo "$packages_json" | jq -e '.[] | select(.name == "dsDanger")' >/dev/null 2>&1; then
+ break
+ fi
+ sleep 10
+ done
+
+ curl -u admin:admin -X POST http://localhost:8080/whitelist/dsDanger
+ curl -u admin:admin http://localhost:8080/whitelist
working-directory: dsBaseClient
-
- - name: Run tests with coverage & JUnit report
+
+ - name: Run dsBase tests with coverage & JUnit report
+ if: matrix.category != 'dsdanger'
run: |
- mkdir -p logs
- R -q -e "devtools::reload();"
+ R -q -e "devtools::load_all();"
R -q -e '
- write.csv(
- covr::coverage_to_list(
- covr::package_coverage(
- type = c("none"),
- code = c('"'"'
- output_file <- file("test_console_output.txt");
- sink(output_file);
- sink(output_file, type = "message");
- junit_rep <- testthat::JunitReporter$new(file = file.path(getwd(), "test_results.xml"));
- progress_rep <- testthat::ProgressReporter$new(max_failures = 999999);
- multi_rep <- testthat::MultiReporter$new(reporters = list(progress_rep, junit_rep));
- options("datashield.return_errors" = FALSE, "default_driver" = "ArmadilloDriver");
- testthat::test_package("${{ env.PROJECT_NAME }}", filter = "${{ env.TEST_FILTER }}", reporter = multi_rep, stop_on_failure = FALSE)'"'"'
- )
- )
- ),
- "coveragelist.csv"
- )'
-
- mv coveragelist.csv logs/
- mv test_* logs/
+ cov <- covr::package_coverage(
+ type = c("none"),
+ code = c('"'"'
+ output_file <- file("test_console_output_dsbase.txt");
+ sink(output_file, split = TRUE);
+ junit_rep <- testthat::JunitReporter$new(file = file.path(getwd(), "test_results_dsbase.xml"));
+ progress_rep <- testthat::ProgressReporter$new(max_failures = 999999);
+ multi_rep <- testthat::MultiReporter$new(reporters = list(progress_rep, junit_rep));
+ options("datashield.return_errors" = FALSE, "default_driver" = "${{ env.DS_DRIVER }}");
+ testthat::test_package("${{ env.PROJECT_NAME }}", filter = "${{ matrix.filter }}", reporter = multi_rep, stop_on_failure = FALSE)'"'"'
+ )
+ )
+ saveRDS(cov, "coverage.rds")
+ write.csv(covr::coverage_to_list(cov), "coveragelist.csv")
+ covr::to_cobertura(cov, "cobertura.xml")' || R_EXIT=$?
+ cat test_console_output_dsbase.txt
+ n_tests=$(grep -c ' entries in test_results_dsbase.xml) - treating as a failure rather than a silent pass."
+ R_EXIT=1
+ fi
+ n_failed=$(grep -oE '<(failure|error)[ >]' test_results_dsbase.xml | wc -l | tr -d ' ')
+ if [ "${R_EXIT:-0}" -eq 0 ] && [ "${n_failed:-0}" -gt 0 ]; then
+ echo "$n_failed test failure(s)/error(s) in test_results_dsbase.xml - failing this shard."
+ R_EXIT=1
+ fi
+ exit "${R_EXIT:-0}"
working-directory: dsBaseClient
-
- - name: Check for JUnit errors
- run: |
- issue_count=$(sed 's/failures="0" errors="0"//' test_results.xml | grep -c errors= || true)
- echo "Number of testsuites with issues: $issue_count"
- sed 's/failures="0" errors="0"//' test_results.xml | grep errors= > issues.log || true
- cat issues.log || true
- # continue with workflow even when some tests fail
- exit 0
- working-directory: dsBaseClient/logs
-
- - name: Write versions to file
- run: |
- echo "branch:${{ env.BRANCH_NAME }}" > ${{ env.WORKFLOW_ID }}.txt
- echo "os:$(lsb_release -ds)" >> ${{ env.WORKFLOW_ID }}.txt
- echo "R:$(R --version | head -n1)" >> ${{ env.WORKFLOW_ID }}.txt
- working-directory: dsBaseClient/logs
-
- - name: Parse results from testthat and covr
+
+ - name: Run dsDanger tests with JUnit report
+ if: matrix.category == 'dsdanger'
run: |
- Rscript --verbose --vanilla ../testStatus/source/parse_test_report.R logs/
+ R -q -e '
+ devtools::load_all(quiet = TRUE);
+ library(testthat);
+ output_file <- file("test_console_output_dsdanger.txt");
+ sink(output_file, split = TRUE);
+ junit_rep <- JunitReporter$new(file = file.path(getwd(), "test_results_dsdanger.xml"));
+ progress_rep <- ProgressReporter$new(max_failures = 999999);
+ multi_rep <- MultiReporter$new(reporters = list(progress_rep, junit_rep));
+ options("datashield.return_errors" = FALSE, "default_driver" = "${{ env.DS_DRIVER }}");
+ test_dir("tests/testthat", filter = "${{ env.TEST_FILTER_DSDANGER }}", reporter = multi_rep, stop_on_failure = FALSE)' || R_EXIT=$?
+ cat test_console_output_dsdanger.txt
+ n_tests=$(grep -c ' entries in test_results_dsdanger.xml) - treating as a failure rather than a silent pass."
+ R_EXIT=1
+ fi
+ n_failed=$(grep -oE '<(failure|error)[ >]' test_results_dsdanger.xml | wc -l | tr -d ' ')
+ if [ "${R_EXIT:-0}" -eq 0 ] && [ "${n_failed:-0}" -gt 0 ]; then
+ echo "$n_failed test failure(s)/error(s) in test_results_dsdanger.xml - failing this shard."
+ R_EXIT=1
+ fi
+ exit "${R_EXIT:-0}"
working-directory: dsBaseClient
-
- - name: Render report
+
+ # Written regardless of outcome so armadillo-report can tell a shard
+ # that never reported (crashed in setup, before any test XML existed)
+ # apart from one that reported 0 failures, and so the coverage step
+ # below knows how many Codecov sessions to actually expect. mkdir -p so
+ # this still succeeds even if checkout itself is what failed. Written
+ # under dsBaseClient/, alongside everything else in the same upload
+ # below, so upload-artifact doesn't widen its common-ancestor
+ # computation to the workspace root and shift every other file down an
+ # extra directory level.
+ - name: Record shard outcome
+ if: always()
run: |
- cd testStatus
-
- mkdir -p new/logs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/${{ env.WORKFLOW_ID }}/
- mkdir -p new/docs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/${{ env.WORKFLOW_ID }}/
- mkdir -p new/docs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/latest/
-
- # Copy logs to new logs directory location
- cp -rv ../dsBaseClient/logs/* new/logs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/${{ env.WORKFLOW_ID }}/
- cp -rv ../dsBaseClient/logs/${{ env.WORKFLOW_ID }}.txt new/logs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/${{ env.WORKFLOW_ID }}/
-
- R -e 'input_dir <- file.path("../new/logs", Sys.getenv("PROJECT_NAME"), Sys.getenv("BRANCH_NAME"), Sys.getenv("WORKFLOW_ID")); quarto::quarto_render("source/test_report.qmd", execute_params = list(input_dir = input_dir))'
- mv source/test_report.html new/docs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/${{ env.WORKFLOW_ID }}/index.html
- cp -r new/docs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/${{ env.WORKFLOW_ID }}/* new/docs/${{ env.PROJECT_NAME }}/${{ env.BRANCH_NAME }}/latest
-
+ mkdir -p dsBaseClient
+ echo "${{ job.status }}" > dsBaseClient/shard_status.txt
+
+ - name: Upload shard results
+ if: always() && matrix.category != 'dsdanger'
+ uses: actions/upload-artifact@v6
+ with:
+ name: armadillo-dsbase-${{ matrix.category }}
+ path: |
+ dsBaseClient/test_results_dsbase.xml
+ dsBaseClient/test_console_output_dsbase.txt
+ dsBaseClient/coveragelist.csv
+ dsBaseClient/coverage.rds
+ dsBaseClient/dsbase_version.txt
+ dsBaseClient/shard_status.txt
+
+ - name: Upload dsDanger results
+ if: always() && matrix.category == 'dsdanger'
+ uses: actions/upload-artifact@v6
+ with:
+ name: armadillo-dsdanger
+ path: |
+ dsBaseClient/test_results_dsdanger.xml
+ dsBaseClient/test_console_output_dsdanger.txt
+ dsBaseClient/shard_status.txt
+
+ - name: Upload coverage to Codecov
+ if: always() && matrix.category != 'dsdanger'
+ uses: codecov/codecov-action@v6
+ with:
+ token: ${{ secrets.CODECOV_TOKEN }}
+ files: dsBaseClient/cobertura.xml
+ flags: armadillo-${{ matrix.category }}
+ fail_ci_if_error: false
+
+
+ ################################################################################
+ # Armadillo - merge all matrix entry results and publish the report.
+ ################################################################################
+ armadillo-report:
+ name: Armadillo report
+ needs: [armadillo-dsbase]
+ if: always()
+ runs-on: ubuntu-latest
+ timeout-minutes: 30
+ permissions:
+ contents: read
+ pull-requests: write
+ steps:
+ - name: Checkout dsBaseClient
+ uses: actions/checkout@v5
+ with:
+ path: dsBaseClient
+
+ - uses: r-lib/actions/setup-r@v2
+ with:
+ r-version: release
+ use-public-rspm: true
+
+ - uses: r-lib/actions/setup-r-dependencies@v2
env:
- PROJECT_NAME: ${{ env.PROJECT_NAME }}
- BRANCH_NAME: ${{ env.BRANCH_NAME }}
- WORKFLOW_ID: ${{ env.WORKFLOW_ID }}
-
- - name: Upload test logs
- uses: actions/upload-artifact@v4
+ PKG_INCLUDE_LINKINGTO: true
+ with:
+ working-directory: dsBaseClient
+ dependencies: 'c("Depends", "Imports", "LinkingTo")'
+ extra-packages: |
+ cran::xml2
+
+ - name: Download shard/dsdanger results
+ uses: actions/download-artifact@v7
+ with:
+ pattern: 'armadillo-*'
+ path: dsBaseClient/artifacts
+
+ - name: Merge JUnit results
+ run: |
+ mkdir -p logs
+ cat artifacts/*/test_console_output_*.txt > logs/test_console_output.txt
+
+ Rscript -e '
+ xml_files <- list.files("artifacts", pattern = "^test_results_.*\\.xml$", recursive = TRUE, full.names = TRUE)
+ docs <- lapply(xml_files, xml2::read_xml)
+ root <- xml2::xml_new_root("testsuites")
+ for (doc in docs) {
+ for (s in xml2::xml_find_all(doc, ".//testsuite")) xml2::xml_add_child(root, s)
+ }
+ xml2::write_xml(root, "logs/test_results.xml")
+ '
+ working-directory: dsBaseClient
+
+ - name: Upload merged results
+ uses: actions/upload-artifact@v6
+ with:
+ name: armadillo-report-results
+ path: |
+ dsBaseClient/logs/test_results.xml
+ dsBaseClient/logs/test_console_output.txt
+
+ - name: Compute coverage
+ id: coverage
+ # Codecov already computes patch (diff) coverage for this commit from
+ # the cobertura.xml uploaded by each armadillo-dsbase shard, gated at
+ # 80% in codecov.yml - that is the branch-level figure we want here.
+ # We used to poll the "codecov/patch" GitHub commit status for it,
+ # but this repo's Codecov integration never posts that status/check
+ # (confirmed via the GitHub API - only the PR comment feature is
+ # active), so we poll Codecov's own public API instead, which has
+ # the same data regardless of GitHub status-posting being enabled.
+ uses: actions/github-script@v8
with:
- name: dsbaseclient-logs
- path: testStatus/new
+ script: |
+ let prNumber = context.payload.pull_request?.number;
+ if (!prNumber) {
+ const branch = context.ref.replace('refs/heads/', '');
+ const prs = await github.rest.pulls.list({
+ owner: context.repo.owner, repo: context.repo.repo,
+ head: `${context.repo.owner}:${branch}`, state: 'open'
+ });
+ prNumber = prs.data[0]?.number;
+ }
+
+ // One session per armadillo-dsbase shard that uploads coverage
+ // (dsdanger is excluded - see the matrix above); Codecov's report
+ // isn't final until all of them have landed. Counted from each
+ // shard's own shard_status.txt (written in armadillo-dsbase,
+ // downloaded above) rather than hardcoded, so a shard that never
+ // got as far as generating cobertura.xml isn't waited on forever,
+ // and this doesn't need updating if the matrix is resharded.
+ const fs = require('fs');
+ const artifactsDir = 'dsBaseClient/artifacts';
+ let expectedSessions = 0;
+ if (fs.existsSync(artifactsDir)) {
+ for (const dir of fs.readdirSync(artifactsDir)) {
+ if (dir.includes('dsdanger')) continue;
+ const statusFile = `${artifactsDir}/${dir}/shard_status.txt`;
+ if (fs.existsSync(statusFile) && fs.readFileSync(statusFile, 'utf8').trim() === 'success') {
+ expectedSessions++;
+ }
+ }
+ }
+ const EXPECTED_SESSIONS = Math.max(expectedSessions, 1);
+ const THRESHOLD = 80;
+
+ let icon = '❓';
+ let text = 'no PR found to look up patch coverage for';
+ let project = 'unknown';
+ let url = `https://app.codecov.io/gh/${context.repo.owner}/${context.repo.repo}/commit/${context.sha}`;
+
+ if (prNumber) {
+ url = `https://app.codecov.io/gh/${context.repo.owner}/${context.repo.repo}/pull/${prNumber}`;
+ icon = '❓';
+ text = 'no codecov patch data found after polling';
+ for (let i = 0; i < 18; i++) {
+ if (i > 0) await new Promise(r => setTimeout(r, 10000));
+ const res = await fetch(`https://api.codecov.io/api/v2/github/${context.repo.owner}/repos/${context.repo.repo}/pulls/${prNumber}/`);
+ if (!res.ok) continue;
+ const data = await res.json();
+
+ // Whole-project total (informational only per codecov.yml) -
+ // report it as soon as it's available, independent of the
+ // patch-readiness gate below.
+ if (typeof data.head_totals?.coverage === 'number') {
+ project = `${data.head_totals.coverage.toFixed(1)}%`;
+ }
- - name: Dump environment info
+ if ((data.head_totals?.sessions ?? 0) < EXPECTED_SESSIONS) continue;
+
+ // Codecov returns patch: null, rather than a zeroed object,
+ // when the PR touches no covr-instrumented line at all.
+ const { hits, misses, partials, coverage } = data.patch ?? { hits: 0, misses: 0, partials: 0 };
+ if (hits + misses + partials === 0) {
+ icon = 'ℹ️';
+ text = 'no coverable lines changed';
+ } else {
+ icon = coverage >= THRESHOLD ? '✅' : '❌';
+ text = `${coverage.toFixed(1)}% vs ${THRESHOLD}% target`;
+ }
+ break;
+ }
+ }
+
+ core.setOutput('icon', icon);
+ core.setOutput('text', text);
+ core.setOutput('project', project);
+ core.setOutput('url', url);
+
+ - name: Compute results & write summary
+ id: results
+ env:
+ ARMADILLO_DSBASE_RESULT: ${{ needs.armadillo-dsbase.result }}
run: |
- echo -e "\n#############################"
- echo -e "ls /: ######################"
- ls -al .
- echo -e "\n#############################"
- echo -e "lscpu: ######################"
- lscpu
- echo -e "\n#############################"
- echo -e "memory: #####################"
- free -m
- echo -e "\n#############################"
- echo -e "env: ########################"
- env
- echo -e "\n#############################"
- echo -e "R sessionInfo(): ############"
- R -e 'sessionInfo()'
- sudo apt install tree -y
- tree .
-
\ No newline at end of file
+ Rscript -e '
+ source(".github/scripts/summarise-junit.R")
+ res <- summarise_junit("logs/test_results.xml", "Armadillo", "artifacts")
+ writeLines(res$summary, Sys.getenv("GITHUB_STEP_SUMMARY"))
+ cat(res$summary, sep = "\n")
+
+ version <- find_dsbase_version("artifacts")
+
+ # needs.armadillo-dsbase.result is "failure" if ANY matrix shard did
+ # not succeed (even if the shards that DID upload results show 0
+ # failures) - a shard that never reported must not look like a pass.
+ shard_ok <- Sys.getenv("ARMADILLO_DSBASE_RESULT") == "success"
+ ok <- res$ok && shard_ok
+ # Only a fallback: the usual case (a shard crashed/reported 0
+ # tests) is already named above via res$shard_problems - this
+ # covers the rare gap where a shard job failed without leaving
+ # any trace summarise_junit() could identify.
+ if (!shard_ok && length(res$shard_problems) == 0) {
+ message("One or more Armadillo dsbase/dsdanger matrix entries did not succeed, but none could be identified from their uploaded results.")
+ }
+
+ out <- Sys.getenv("GITHUB_OUTPUT")
+ cat(
+ sprintf("ok=%s\n", tolower(ok)),
+ sprintf("tally=%s\n", res$tally),
+ sprintf("version=%s\n", version),
+ file = out, append = TRUE, sep = ""
+ )
+
+ if (!ok) message("Armadillo tests failed.")
+ quit(save = "no", status = if (ok) 0 else 1)
+ '
+ working-directory: dsBaseClient
+
+ - name: Post PR comment
+ if: always()
+ uses: actions/github-script@v8
+ with:
+ script: |
+ // steps.results.outputs.* come back empty (not "true"/"false") if
+ // that step never got far enough to write them - e.g. it errored
+ // or was skipped outright because an earlier step failed. Fall
+ // back to something informative rather than a blank tally.
+ const ok = '${{ steps.results.outputs.ok }}' === 'true';
+ const tally = '${{ steps.results.outputs.tally }}' || 'error - see log';
+ const version = '${{ steps.results.outputs.version }}' || 'unknown';
+ const coverageIcon = '${{ steps.coverage.outputs.icon }}' || '❓';
+ const coverageText = '${{ steps.coverage.outputs.text }}' || 'error - see log';
+ const coverageProject = '${{ steps.coverage.outputs.project }}' || 'unknown';
+ // #summary- scrolls straight to this job's summary card
+ // (the pass/fail tally written via GITHUB_STEP_SUMMARY) instead
+ // of just the top of the run page.
+ const runUrl = `${context.serverUrl}/${context.repo.owner}/${context.repo.repo}/actions/runs/${context.runId}#summary-${{ job.check_run_id }}`;
+ const codecovUrl = '${{ steps.coverage.outputs.url }}' || `https://app.codecov.io/gh/${context.repo.owner}/${context.repo.repo}/commit/${context.sha}`;
+
+ const postCiComment = require('${{ github.workspace }}/dsBaseClient/.github/scripts/post-ci-comment.js');
+ await postCiComment({ github, context, updates: {
+ 'row:tests-armadillo': `
`,
+ 'ver:armadillo': `\`${version}\``,
+ 'log:tests-armadillo': `Armadillo unit tests`,
+ 'log:coverage': `Codecov`
+ }});
+
diff --git a/.github/workflows/lint.yaml b/.github/workflows/lint.yaml
new file mode 100644
index 000000000..746076fba
--- /dev/null
+++ b/.github/workflows/lint.yaml
@@ -0,0 +1,157 @@
+name: Lint
+
+on:
+ push:
+ branches: [main, master, 'v*-dev']
+ pull_request:
+
+# A new push to the same ref supersedes any run still in progress for it, so
+# we don't burn compute on stale commits.
+concurrency:
+ group: ${{ github.workflow }}-${{ github.ref }}-${{ github.event_name }}
+ cancel-in-progress: true
+
+permissions:
+ contents: read
+
+jobs:
+ lint:
+ name: R lint (lintr)
+ runs-on: ubuntu-latest
+ timeout-minutes: 15
+ permissions:
+ contents: read
+ security-events: write
+ pull-requests: write
+ steps:
+ - uses: actions/checkout@v5
+ with:
+ fetch-depth: 0
+
+ - name: Mark pending
+ if: github.event_name == 'pull_request'
+ uses: actions/github-script@v8
+ with:
+ script: |
+ const postCiComment = require('${{ github.workspace }}/.github/scripts/post-ci-comment.js');
+ await postCiComment({ github, context, updates: {
+ 'row:lint': `
Code quality
⏳ pending
`,
+ 'log:lint': `_pending_`
+ }});
+
+ - uses: r-lib/actions/setup-r@v2
+ with:
+ r-version: release
+ use-public-rspm: true
+
+ - uses: r-lib/actions/setup-r-dependencies@v2
+ env:
+ PKG_INCLUDE_LINKINGTO: true
+ with:
+ dependencies: 'c("Depends", "Imports", "LinkingTo")'
+ extra-packages: |
+ local::.
+ cran::lintr
+ cran::jsonlite
+
+ - name: Get PR diff
+ if: github.event_name == 'pull_request'
+ id: changed
+ run: |
+ # Three-dot diff (against the merge-base) rather than two-dot: when
+ # the base branch has diverged and gained its own independent
+ # commits, a plain two-dot diff shows those too, not just what this
+ # PR actually added - matching what GitHub's own "Files changed"
+ # tab and Advanced Security baseline compare against.
+ patch=$(git diff --unified=0 "${{ github.event.pull_request.base.sha }}...${{ github.event.pull_request.head.sha }}" -- '*.R' '*.Rmd')
+ echo "patch<> "$GITHUB_ENV"
+ echo "$patch" >> "$GITHUB_ENV"
+ echo "DIFF_PATCH_EOF" >> "$GITHUB_ENV"
+
+ - name: Lint
+ id: lint
+ env:
+ IS_PR: ${{ github.event_name == 'pull_request' }}
+ DIFF_PATCH: ${{ env.patch }}
+ run: |
+ Rscript -e '
+ al <- lintr::available_linters()
+ keep <- vapply(al$tags, function(t) any(t %in% c("correctness", "common_mistakes", "robustness")), logical(1))
+ sel <- al$linter[keep]
+ linter_funs <- lapply(sel, function(n) get(n, envir = asNamespace("lintr"))())
+ names(linter_funs) <- sel
+ lints <- lintr::lint_package(linters = linter_funs)
+ cat("n lints:", length(lints), "\n")
+ print(lints) # emits ::warning file=...,line=...:: annotations (auto-detects GitHub Actions)
+ lintr::sarif_output(lints, "lintr_results.sarif")
+
+ is_pr <- Sys.getenv("IS_PR") == "true"
+
+ # A finding only counts as "new" if the PR diff actually added or
+ # changed that exact line - matching a file merely being touched
+ # elsewhere (the old approach) blamed PRs for pre-existing issues
+ # anywhere in a file they only partly edited.
+ parse_added_lines <- function(patch) {
+ added <- new.env()
+ cur_file <- NULL
+ for (ln in strsplit(patch, "\n")[[1]]) {
+ if (startsWith(ln, "+++ ")) {
+ path <- sub("^\\+\\+\\+ b/", "", ln)
+ cur_file <- if (identical(path, "/dev/null")) NULL else path
+ } else if (!is.null(cur_file) && startsWith(ln, "@@")) {
+ m <- regmatches(ln, regexpr("\\+[0-9]+(,[0-9]+)?", ln))
+ if (length(m) == 1 && nzchar(m)) {
+ parts <- strsplit(sub("^\\+", "", m), ",")[[1]]
+ new_start <- as.integer(parts[1])
+ new_count <- if (length(parts) > 1) as.integer(parts[2]) else 1L
+ if (new_count > 0) {
+ existing <- if (is.null(added[[cur_file]])) integer(0) else added[[cur_file]]
+ added[[cur_file]] <- c(existing, seq(new_start, length.out = new_count))
+ }
+ }
+ }
+ }
+ added
+ }
+
+ added_lines <- if (is_pr) parse_added_lines(Sys.getenv("DIFF_PATCH")) else new.env()
+ is_new <- vapply(lints, function(l) {
+ lines <- added_lines[[l$filename]]
+ !is.null(lines) && l$line_number %in% lines
+ }, logical(1))
+ n_new <- sum(is_new)
+ n_total <- length(lints)
+
+ cat(
+ sprintf("n_new=%d\n", n_new),
+ sprintf("n_total=%d\n", n_total),
+ file = Sys.getenv("GITHUB_OUTPUT"), append = TRUE, sep = ""
+ )
+
+ if (n_new > 0) {
+ message(sprintf("Lint found %d issue(s) in files changed by this PR - see the annotations above or the SARIF upload for details.", n_new))
+ }
+ quit(save = "no", status = if (n_new > 0) 1 else 0)
+ '
+
+ - name: Upload lint results
+ if: always()
+ uses: github/codeql-action/upload-sarif@v4
+ with:
+ sarif_file: lintr_results.sarif
+
+ - name: Post PR comment
+ if: always() && github.event_name == 'pull_request'
+ uses: actions/github-script@v8
+ with:
+ script: |
+ const nNew = parseInt('${{ steps.lint.outputs.n_new }}' || '0', 10);
+ const nTotal = '${{ steps.lint.outputs.n_total }}' || 'unknown';
+ const ok = nNew === 0;
+ const runUrl = `${context.serverUrl}/${context.repo.owner}/${context.repo.repo}/actions/runs/${context.runId}`;
+
+ const postCiComment = require('${{ github.workspace }}/.github/scripts/post-ci-comment.js');
+ await postCiComment({ github, context, updates: {
+ 'row:lint': `
Code quality
${ok ? '✅ 0 new findings' : `❌ ${nNew} new finding${nNew === 1 ? '' : 's'}`} (package total: ${nTotal})
`,
+ 'log:lint': `Code quality`
+ }});
diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml
index bfc9f4db3..d316baaf3 100644
--- a/.github/workflows/pkgdown.yaml
+++ b/.github/workflows/pkgdown.yaml
@@ -23,7 +23,7 @@ jobs:
permissions:
contents: write
steps:
- - uses: actions/checkout@v4
+ - uses: actions/checkout@v5
- uses: r-lib/actions/setup-pandoc@v2
@@ -42,7 +42,7 @@ jobs:
- name: Deploy to GitHub pages 🚀
if: github.event_name != 'pull_request'
- uses: JamesIves/github-pages-deploy-action@v4.5.0
+ uses: JamesIves/github-pages-deploy-action@v4.9.0
with:
clean: false
branch: gh-pages
diff --git a/.gitignore b/.gitignore
index 60d56797e..1f5f8c99e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -12,3 +12,5 @@ azure-pipelines.Rout
tests/testthat/connection_to_datasets/local_settings.csv
tests/docker/armadillo/standard/logs/
tests/docker/armadillo/standard/data/
+lintr_results.sarif
+tests/testthat/Rplots.pdf
diff --git a/DESCRIPTION b/DESCRIPTION
index 348fb26e8..dd838b8c2 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,11 +1,11 @@
Package: dsBaseClient
Title: 'DataSHIELD' Client Side Base Functions
-Version: 6.3.5.9000
+Version: 7.0.0.9000
Description: Base 'DataSHIELD' functions for the client side. 'DataSHIELD' is a software package which allows
you to do non-disclosive federated analysis on sensitive data. 'DataSHIELD' analytic functions have
been designed to only share non disclosive summary statistics, with built in automated output
checking based on statistical disclosure control. With data sites setting the threshold values for
- the automated output checks. For more details, see citation("dsBaseClient").
+ the automated output checks. For more details, see citation('dsBaseClient').
Authors@R: c(person(given = "Paul",
family = "Burton",
role = c("aut"),
@@ -56,12 +56,18 @@ Authors@R: c(person(given = "Paul",
family = "Wheater",
role = c("aut", "cre"),
email = "stuart.wheater@arjuna.com",
- comment = c(ORCID = "0009-0003-2419-1964")))
+ comment = c(ORCID = "0009-0003-2419-1964")),
+ person(given = "Tim",
+ family = "Cadman",
+ role = c("aut"),
+ comment = c(ORCID = "0000-0002-7682-5645",
+ affiliation = "Genomics Coordination Centre, UMCG, Netherlands")))
License: GPL-3
Depends:
- R (>= 4.0.0),
- DSI (>= 1.7.1)
+ R (>= 4.1.0),
+ DSI (>= 1.8.0)
Imports:
+ cli,
fields,
metafor,
meta,
@@ -69,7 +75,8 @@ Imports:
gridExtra,
data.table,
methods,
- dplyr
+ dplyr,
+ cli
Suggests:
lme4,
httr,
@@ -81,6 +88,6 @@ Suggests:
DSOpal,
DSMolgenisArmadillo,
DSLite
-RoxygenNote: 7.3.3
Encoding: UTF-8
Language: en-GB
+Config/roxygen2/version: 8.1.0
diff --git a/NAMESPACE b/NAMESPACE
index a41b8f0af..88498755c 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -89,7 +89,6 @@ export(ds.rBinom)
export(ds.rNorm)
export(ds.rPois)
export(ds.rUnif)
-export(ds.ranksSecure)
export(ds.rbind)
export(ds.reShape)
export(ds.recodeLevels)
@@ -120,7 +119,11 @@ export(ds.var)
export(ds.vectorCalc)
import(DSI)
import(data.table)
-importFrom(stats,as.formula)
-importFrom(stats,na.omit)
-importFrom(stats,ts)
-importFrom(stats,weighted.mean)
+importFrom(DSI,datashield.connections_find)
+importFrom(cli,cli_abort)
+importFrom(stats,
+ as.formula,
+ na.omit,
+ ts,
+ weighted.mean
+)
diff --git a/R/checkClass.R b/R/checkClass.R
index 779eca1e0..08b89bd51 100644
--- a/R/checkClass.R
+++ b/R/checkClass.R
@@ -13,7 +13,7 @@
checkClass <- function(datasources=NULL, obj=NULL){
# check the class of the input object
cally <- call("classDS", obj)
- classesBy <- DSI::datashield.aggregate(datasources, cally, async = FALSE)
+ classesBy <- DSI::datashield.aggregate(datasources, cally)
classes <- unique(unlist(classesBy))
for (n in names(classesBy)) {
if (!all(classes == classesBy[[n]])) {
diff --git a/R/ds.Boole.R b/R/ds.Boole.R
index 252346bfd..c435e4c6f 100644
--- a/R/ds.Boole.R
+++ b/R/ds.Boole.R
@@ -37,11 +37,8 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.Boole} returns the object specified by the \code{newobj} argument
-#' which is written to the server-side. Also, two validity messages are returned
-#' to the client-side indicating the name of the \code{newobj} which
-#' has been created in each data source and if
-#' it is in a valid form.
+#' @return \code{ds.Boole} returns the object specified by the \code{newobj} argument
+#' which is written to the server-side.
#' @examples
#'
#' \dontrun{
@@ -102,19 +99,12 @@
#' }
#'
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.Boole<-function(V1=NULL, V2=NULL, Boolean.operator=NULL, numeric.output=TRUE, na.assign="NA",newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if user has provided the name of the column or scalar that holds V1
if(is.null(V1)){
@@ -178,88 +168,8 @@ ds.Boole<-function(V1=NULL, V2=NULL, Boolean.operator=NULL, numeric.output=TRUE,
}
# CALL THE MAIN SERVER SIDE FUNCTION
- calltext <- call("BooleDS", V1, V2, BO.n, na.assign,numeric.output)
+ calltext <- call("BooleDS", V1, V2, BO.n, na.assign, numeric.output)
DSI::datashield.assign(datasources, newobj, calltext)
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.Boole
diff --git a/R/ds.abs.R b/R/ds.abs.R
index 41c204551..cc4523f32 100644
--- a/R/ds.abs.R
+++ b/R/ds.abs.R
@@ -17,6 +17,7 @@
#' the input numeric or integer vector specified in the argument \code{x}. The created vectors
#' are stored in the servers.
#' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -72,41 +73,17 @@
#'
ds.abs <- function(x=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input object!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
-
- # call the internal function that checks the input object(s) is(are) of the same class in all studies.
- if(!('numeric' %in% typ) && !('integer' %in% typ)){
- stop("Only objects of type 'numeric' or 'integer' are allowed.", call.=FALSE)
- }
-
- # create a name by default if the user did not provide a name for the new variable
if(is.null(newobj)){
newobj <- "abs.newobj"
}
- # call the server side function that does the operation
cally <- call("absDS", x)
DSI::datashield.assign(datasources, newobj, cally)
- # check that the new object has been created and display a message accordingly
- finalcheck <- isAssigned(datasources, newobj)
-
}
diff --git a/R/ds.asCharacter.R b/R/ds.asCharacter.R
index c0bd4ce0a..623e43dbe 100644
--- a/R/ds.asCharacter.R
+++ b/R/ds.asCharacter.R
@@ -13,9 +13,7 @@
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.asCharacter} returns the object converted into a class character
-#' that is written to the server-side. Also, two validity messages are returned to the client-side
-#' indicating the name of the \code{newobj} which has been created in each data source and if
-#' it is in a valid form.
+#' that is written to the server-side.
#' @examples
#' \dontrun{
#' ## Version 6, for version 5 see the Wiki
@@ -53,115 +51,22 @@
#'
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.asCharacter <- function(x.name=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x.name)){
stop("Please provide the name of the input vector!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x.name)
-
- # create a name by default if user did not provide a name for the new variable
if(is.null(newobj)){
newobj <- "ascharacter.newobj"
}
- # call the server side function that does the job
-
calltext <- call("asCharacterDS", x.name)
-
DSI::datashield.assign(datasources, newobj, calltext)
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
-
}
-# ds.asCharacter
diff --git a/R/ds.asDataMatrix.R b/R/ds.asDataMatrix.R
index 7b4833bbd..bdfa9fdd0 100644
--- a/R/ds.asDataMatrix.R
+++ b/R/ds.asDataMatrix.R
@@ -12,11 +12,7 @@
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.asDataMatrix} returns the object converted into a matrix
-#' that is written to the server-side. Also, two validity messages are returned
-#' to the client-side
-#' indicating the name of the \code{newobj} which
-#' has been created in each data source and if
-#' it is in a valid form.
+#' that is written to the server-side.
#' @examples
#' \dontrun{
#' ## Version 6, for version 5 see the Wiki
@@ -54,113 +50,22 @@
#'
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.asDataMatrix <- function(x.name=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x.name)){
stop("Please provide the name of the input vector!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x.name)
-
- # create a name by default if user did not provide a name for the new variable
if(is.null(newobj)){
newobj <- "asdatamatrix.newobj"
}
- # call the server side function that does the job
calltext <- call("asDataMatrixDS", x.name)
DSI::datashield.assign(datasources, newobj, calltext)
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
-
}
-# ds.asDataMatrix
diff --git a/R/ds.asFactor.R b/R/ds.asFactor.R
index 8e5fbd090..e6b6e7ce2 100644
--- a/R/ds.asFactor.R
+++ b/R/ds.asFactor.R
@@ -133,10 +133,8 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.asFactor} returns the unique levels of the converted
-#' variable in ascending order and a validity
-#' message with the name of the created object on the client-side and
-#' the output matrix or vector in the server-side.
+#' @return \code{ds.asFactor} returns the unique levels of the converted
+#' variable in ascending order. The output matrix or vector is written to the server-side.
#'
#' @examples
#' \dontrun{
@@ -185,19 +183,12 @@
#' datashield.logout(connections)
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
ds.asFactor <- function(input.var.name=NULL, newobj.name=NULL, forced.factor.levels=NULL, fixed.dummy.vars=FALSE,
baseline.level=1, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if user has provided the name of the column that holds the input variable
if(is.null(input.var.name)){
@@ -248,58 +239,7 @@ ds.asFactor <- function(input.var.name=NULL, newobj.name=NULL, forced.factor.lev
calltext2 <- call("asFactorDS2", input.var.name, all.unique.levels.transmit, fixed.dummy.vars, baseline.level)
DSI::datashield.assign(datasources, newobj.name, calltext2)
-##########################################################################################################
-#MODULE 5: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj.name #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("Data object <", test.obj.name, "> correctly created in all specified data sources") #
- #
- return(list(all.unique.levels=all.unique.levels,return.message=return.message)) #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources")#
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message<-list(return.message.1,return.message.2) #
- #
- return.info<-object.info #
- #
-return(list(all.unique.levels=all.unique.levels,return.info=return.info,return.message=return.message)) #
- #
- } #
-#END OF MODULE 5 #
-##########################################################################################################
-
+ return(list(all.unique.levels=all.unique.levels))
}
#ds.asFactor
diff --git a/R/ds.asFactorSimple.R b/R/ds.asFactorSimple.R
index 313f7b408..fc092d352 100644
--- a/R/ds.asFactorSimple.R
+++ b/R/ds.asFactorSimple.R
@@ -17,23 +17,14 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return an output vector of class factor to the serverside. In addition, returns a validity
-#' message with the name of the created object on the client-side and if creation fails an
-#' error message which can be viewed using datashield.errors().
+#' @return an output vector of class factor written to the serverside.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.asFactorSimple <- function(input.var.name=NULL, newobj.name=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if user has provided the name of the column that holds the input variable
if(is.null(input.var.name)){
@@ -55,58 +46,5 @@ ds.asFactorSimple <- function(input.var.name=NULL, newobj.name=NULL, datasources
calltext0 <- call("asFactorSimpleDS", input.var.name)
DSI::datashield.assign(datasources, newobj.name, calltext0)
-##########################################################################################################
-#MODULE 5: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj.name #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("Data object <", test.obj.name, "> correctly created in all specified data sources") #
- #
- return(list(return.message=return.message)) #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources")#
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message<-list(return.message.1,return.message.2) #
- #
- return.info<-object.info #
- #
-return(list(return.info=return.info,return.message=return.message)) #
- #
- } #
-#END OF MODULE 5 #
-##########################################################################################################
-
-
}
#ds.asFactorSimple
diff --git a/R/ds.asInteger.R b/R/ds.asInteger.R
index 9b3b1a397..0e9670df0 100644
--- a/R/ds.asInteger.R
+++ b/R/ds.asInteger.R
@@ -26,10 +26,7 @@
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.asInteger} returns the R object converted into an integer
-#' that is written to the server-side. Also, two validity messages are returned to the
-#' client-side indicating the name of the \code{newobj} which
-#' has been created in each data source and if
-#' it is in a valid form.
+#' that is written to the server-side.
#' @examples
#' \dontrun{
#' ## Version 6, for version 5 see the Wiki
@@ -68,109 +65,21 @@
#'
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
ds.asInteger <- function(x.name=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x.name)){
stop("Please provide the name of the input vector!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x.name)
-
- # create a name by default if user did not provide a name for the new variable
if(is.null(newobj)){
newobj <- "asinteger.newobj"
}
- # call the server side function that does the job
calltext <- call("asIntegerDS", x.name)
DSI::datashield.assign(datasources, newobj, calltext)
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # # #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
-# ds.asInteger
diff --git a/R/ds.asList.R b/R/ds.asList.R
index d73668785..83007f5a3 100644
--- a/R/ds.asList.R
+++ b/R/ds.asList.R
@@ -13,9 +13,7 @@
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.asList} returns the R object converted into a list
-#' which is written to the server-side. Also, two validity messages are returned to the
-#' client-side indicating the name of the \code{newobj} which has been created in each data
-#' source and if it is in a valid form.
+#' which is written to the server-side.
#' @examples
#' \dontrun{
#' ## Version 6, for version 5 see the Wiki
@@ -54,41 +52,22 @@
#'
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.asList <- function(x.name=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x.name)){
stop("Please provide the name of the input vector!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x.name)
-
- # create a name by default if user did not provide a name for the new variable
if(is.null(newobj)){
newobj <- "aslist.newobj"
}
- # call the server side function that does the job
-
calltext <- call("asListDS", x.name, newobj)
-
out.message <- DSI::datashield.aggregate(datasources, calltext)
-# print(out.message)
-
-#Don't include assign function completion module as it can print out an unhelpful
-#warning message when newobj is a list
}
-# ds.asList
diff --git a/R/ds.asLogical.R b/R/ds.asLogical.R
index 2ddc33cfe..85617edcf 100644
--- a/R/ds.asLogical.R
+++ b/R/ds.asLogical.R
@@ -12,10 +12,7 @@
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.asLogical} returns the R object converted into a logical
-#' that is written to the server-side. Also, two validity messages are returned
-#' to the client-side indicating the name of the \code{newobj} which
-#' has been created in each data source and if
-#' it is in a valid form.
+#' that is written to the server-side.
#' @examples
#' \dontrun{
#' ## Version 6, for version 5 see the Wiki
@@ -54,113 +51,22 @@
#'
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.asLogical <- function(x.name=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x.name)){
stop("Please provide the name of the input vector!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x.name)
-
- # create a name by default if user did not provide a name for the new variable
if(is.null(newobj)){
newobj <- "aslogical.newobj"
}
- # call the server side function that does the job
calltext <- call("asLogicalDS", x.name)
DSI::datashield.assign(datasources, newobj, calltext)
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
-
}
-# ds.asLogical
diff --git a/R/ds.asMatrix.R b/R/ds.asMatrix.R
index 1c5b0ced7..f39803773 100644
--- a/R/ds.asMatrix.R
+++ b/R/ds.asMatrix.R
@@ -15,9 +15,7 @@
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.asMatrix} returns the object converted into a matrix
-#' that is written to the server-side. Also, two validity messages are returned
-#' to the client-side indicating the name of the \code{newobj} which
-#' has been created in each data source and if it is in a valid form.
+#' that is written to the server-side.
#' @examples
#' \dontrun{
#' ## Version 6, for version 5 see the Wiki
@@ -55,113 +53,22 @@
#'
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.asMatrix <- function(x.name=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x.name)){
stop("Please provide the name of the input vector!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x.name)
-
- # create a name by default if user did not provide a name for the new variable
if(is.null(newobj)){
newobj <- "asmatrix.newobj"
}
- # call the server side function that does the job
calltext <- call("asMatrixDS", x.name)
DSI::datashield.assign(datasources, newobj, calltext)
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
-
}
-# ds.asMatrix
diff --git a/R/ds.asNumeric.R b/R/ds.asNumeric.R
index 3e2b445fa..803a6308d 100644
--- a/R/ds.asNumeric.R
+++ b/R/ds.asNumeric.R
@@ -26,10 +26,7 @@
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.asNumeric} returns the R object converted into a numeric class
-#' that is written to the server-side. Also, two validity messages are returned
-#' to the client-side indicating the name of the \code{newobj} which
-#' has been created in each data source and if
-#' it is in a valid form.
+#' that is written to the server-side.
#' @examples
#' \dontrun{
#' ## Version 6, for version 5 see the Wiki
@@ -68,112 +65,22 @@
#'
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.asNumeric <- function(x.name=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x.name)){
stop("Please provide the name of the input vector!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x.name)
-
- # create a name by default if user did not provide a name for the new variable
if(is.null(newobj)){
newobj <- "asnumeric.newobj"
}
- # call the server side function that does the job
calltext <- call("asNumericDS", x.name)
DSI::datashield.assign(datasources, newobj, calltext)
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
-# ds.asNumeric
diff --git a/R/ds.assign.R b/R/ds.assign.R
index 25b71c74e..79c373d5c 100644
--- a/R/ds.assign.R
+++ b/R/ds.assign.R
@@ -16,6 +16,7 @@
#' @return \code{ds.assign} returns the R object assigned to a name
#' that is written to the server-side.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -56,15 +57,7 @@
#'
ds.assign <- function(toAssign=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(toAssign)){
stop("Please give the name of object to assign or an expression to evaluate and assign.!\n", call.=FALSE)
@@ -78,7 +71,4 @@ ds.assign <- function(toAssign=NULL, newobj=NULL, datasources=NULL){
# now do the business
DSI::datashield.assign(datasources, newobj, as.symbol(toAssign))
- # check that the new object has been created and display a message accordingly
- finalcheck <- isAssigned(datasources, newobj)
-
}
diff --git a/R/ds.boxPlot.R b/R/ds.boxPlot.R
index d89c54709..e02aab96a 100644
--- a/R/ds.boxPlot.R
+++ b/R/ds.boxPlot.R
@@ -15,6 +15,7 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} (default \code{NULL}) objects obtained after login
#'
#' @return \code{ggplot} object
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -86,55 +87,22 @@
ds.boxPlot <- function(x, variables = NULL, group = NULL, group2 = NULL, xlabel = "x axis",
ylabel = "y axis", type = "pooled", datasources = NULL){
- if (is.null(datasources)) {
- datasources <- DSI::datashield.connections_find()
- }
+ datasources <- .set_datasources(datasources)
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
-
# Ensure type is 'pooled' or 'split'
if((length(type) == 1) && (! any(type %in% c("pooled", "split")))){
stop("[type] can only be set to 'pooled' or 'split'")
}
-
- # Check if x is defined and that it is of class "numeric" or "data.frame"
- isDefined(datasources, x)
- cls <- checkClass(datasources, x)
+
+ # Determine class of x for dispatch
+ cls <- datashield.aggregate(datasources, call("classDS", x))
+ .checkClassConsistency(lapply(cls, function(study.class) list(class = study.class)), object_name = x)
+ cls <- unique(unlist(cls))
+
if(!any(c("numeric", "data.frame") %in% cls)){
stop("The selected object is not a data frame nor a numerical vector")
}
-
- # If x is a "data.frame" check that the variables exist, and if they are "numeric"
- # also check if the grouping variables [group, group2] exist and are of class factor
- if("data.frame" %in% cls){
- # Check that all variables exist
- lapply(variables, function(i){
- isDefined(datasources, paste0(x, "$", i))
- })
- # Check all variables are of class "numeric"
- variable_classes <- unlist(lapply(variables, function(i){
- checkClass(datasources, paste0(x, "$", i))
- }))
- if(!all(variable_classes == "numeric")){
- stop("[", paste(variables[variable_classes != "numeric"], collapse = ", "), "] variable(s) are not of class 'numeric'")
- }
- # Check if grouping variables exist
- if(!is.null(group)){isDefined(datasources, paste0(x, "$", group))}
- if(!is.null(group2)){isDefined(datasources, paste0(x, "$", group2))}
- # Check if groupings are of class "factor"
- if(!is.null(group)){
- group_class <- checkClass(datasources, paste0(x, "$", group))
- if(group_class != "factor"){stop("[", group, "] is not of class 'factor'")}
- }
- if(!is.null(group2)){
- group_class2 <- checkClass(datasources, paste0(x, "$", group2))
- if(group_class2 != "factor"){stop("[", group2, "] is not of class 'factor'")}
- }
- }
-
+
# Once all checks are passed, call the appropiate server functions
if("data.frame" %in% cls){
ds.boxPlotGG_table(x, variables, group, group2, xlabel, ylabel, type, datasources)
diff --git a/R/ds.boxPlotGG.R b/R/ds.boxPlotGG.R
index e09fa8d6d..e562d9719 100644
--- a/R/ds.boxPlotGG.R
+++ b/R/ds.boxPlotGG.R
@@ -20,51 +20,41 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} (default \code{NULL}) objects obtained after login
#'
#' @return \code{ggplot} object
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
ds.boxPlotGG <- function(x, group = NULL, group2 = NULL, xlabel = "x axis", ylabel = "y axis", type = "pooled", datasources = NULL){
x_var <- lower <- upper <- ymin <- ymax <- middle <- fill <- NULL
- if (is.null(datasources)) {
- datasources <- DSI::datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
- cally <- paste0("boxPlotGGDS(", x, ", ",
- if(is.null(group)){paste0("NULL")}else{paste0("'",group,"'")}, ", ",
- if(is.null(group2)){paste0("NULL")}else{paste0("'",group2,"'")}, ")")
-
- pt <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ plot_data <- datashield.aggregate(datasources, call("boxPlotGGDS", data_table.name=x, group=group, group2=group2))
if(type == "pooled"){
num_servers <- length(names(datasources))
- pt_merged <- NULL
+ plot_data_merged <- NULL
for(i in 1:num_servers){
- pt_merged <- rbind(pt_merged, pt[[i]]$data)
+ plot_data_merged <- rbind(plot_data_merged, plot_data[[i]]$data)
}
- pt_merged <- data.table::data.table(pt_merged)
+ plot_data_merged <- data.table::data.table(plot_data_merged)
if(!is.null(group) & is.null(group2)){
- pt_merged <- computeWeightedMeans(pt_merged,
+ plot_data_merged <- computeWeightedMeans(plot_data_merged,
variables = c("ymin", "lower", "middle", "upper", "ymax"),
weight = "n",
by = c("group", "x"))
}
else if(!is.null(group) & !is.null(group2)){
- pt_merged <- computeWeightedMeans(pt_merged,
+ plot_data_merged <- computeWeightedMeans(plot_data_merged,
variables = c("ymin", "lower", "middle", "upper", "ymax"),
weight = "n",
by = c("group", "group2", "x"))
}
else{
- pt_merged <- computeWeightedMeans(pt_merged,
+ plot_data_merged <- computeWeightedMeans(plot_data_merged,
variables = c("ymin", "lower", "middle", "upper", "ymax"),
weight = "n",
by = c("x"))
}
- if(pt[[1]][[length(pt[[1]])]] == "single_group"){
- plt <- ggplot2::ggplot(pt_merged) +
+ if(plot_data[[1]][[length(plot_data[[1]])]] == "single_group"){
+ plt <- ggplot2::ggplot(plot_data_merged) +
ggplot2::geom_boxplot(stat = "identity", ggplot2::aes(x=x, lower=lower,
upper=upper, ymin=ymin,
ymax=ymax, middle=middle,
@@ -74,8 +64,8 @@ ds.boxPlotGG <- function(x, group = NULL, group2 = NULL, xlabel = "x axis", ylab
ggplot2::ylab(ylabel) +
ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 1))
}
- else if(pt[[1]][[length(pt[[1]])]] == "double_group"){
- plt <- ggplot2::ggplot(pt_merged) +
+ else if(plot_data[[1]][[length(plot_data[[1]])]] == "double_group"){
+ plt <- ggplot2::ggplot(plot_data_merged) +
ggplot2::geom_boxplot(stat = "identity", ggplot2::aes(x=x, lower=lower,
upper=upper, ymin=ymin,
ymax=ymax, middle=middle,
@@ -87,7 +77,7 @@ ds.boxPlotGG <- function(x, group = NULL, group2 = NULL, xlabel = "x axis", ylab
ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 1))
}
else{
- plt <- ggplot2::ggplot(pt_merged) +
+ plt <- ggplot2::ggplot(plot_data_merged) +
ggplot2::geom_boxplot(stat = "identity", ggplot2::aes(x=x, lower=lower,
upper=upper, ymin=ymin,
ymax=ymax, middle=middle)) +
@@ -102,8 +92,8 @@ ds.boxPlotGG <- function(x, group = NULL, group2 = NULL, xlabel = "x axis", ylab
num_servers <- length(names(datasources))
plt <- NULL
for(i in 1:num_servers){
- if(pt[[i]][[length(pt[[i]])]] == "single_group"){
- plt[[i]] <- ggplot2::ggplot(pt[[i]][[1]]) +
+ if(plot_data[[i]][[length(plot_data[[i]])]] == "single_group"){
+ plt[[i]] <- ggplot2::ggplot(plot_data[[i]][[1]]) +
ggplot2::geom_boxplot(stat = "identity", ggplot2::aes(x=x, lower=lower,
upper=upper, ymin=ymin,
ymax=ymax, middle=middle,
@@ -114,8 +104,8 @@ ds.boxPlotGG <- function(x, group = NULL, group2 = NULL, xlabel = "x axis", ylab
ggplot2::ggtitle(paste0("Server: ", names(datasources[i]))) +
ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 1))
}
- else if(pt[[i]][[length(pt[[i]])]] == "double_group"){
- plt[[i]] <- ggplot2::ggplot(pt[[i]][[1]]) +
+ else if(plot_data[[i]][[length(plot_data[[i]])]] == "double_group"){
+ plt[[i]] <- ggplot2::ggplot(plot_data[[i]][[1]]) +
ggplot2::geom_boxplot(stat = "identity", ggplot2::aes(x=x, lower=lower,
upper=upper, ymin=ymin,
ymax=ymax, middle=middle,
@@ -128,7 +118,7 @@ ds.boxPlotGG <- function(x, group = NULL, group2 = NULL, xlabel = "x axis", ylab
ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, hjust = 1))
}
else{
- plt[[i]] <- ggplot2::ggplot(pt[[i]][[1]]) +
+ plt[[i]] <- ggplot2::ggplot(plot_data[[i]][[1]]) +
ggplot2::geom_boxplot(stat = "identity", ggplot2::aes(x=x, lower=lower,
upper=upper, ymin=ymin,
ymax=ymax, middle=middle)) +
diff --git a/R/ds.boxPlotGG_data_Treatment.R b/R/ds.boxPlotGG_data_Treatment.R
index 40f89730a..84d32e1ab 100644
--- a/R/ds.boxPlotGG_data_Treatment.R
+++ b/R/ds.boxPlotGG_data_Treatment.R
@@ -16,23 +16,13 @@
#' Column 'group': (Optional) Values of the grouping variable \cr
#' Column 'group2': (Optional) Values of the second grouping variable \cr
#'
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
ds.boxPlotGG_data_Treatment <- function(table, variables, group = NULL, group2 = NULL, datasources = NULL){
- if (is.null(datasources)) {
- datasources <- DSI::datashield.connections_find()
- }
+ datasources <- .set_datasources(datasources)
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
-
- cally <- paste0("boxPlotGG_data_TreatmentDS(", table, ", c('",
- paste0(variables, collapse = "','"), "'), ",
- if(is.null(group)){paste0("NULL")}else{paste0("'",group,"'")}, ", ",
- if(is.null(group2)){paste0("NULL")}else{paste0("'",group2,"'")}, ")")
- DSI::datashield.assign.expr(datasources, "boxPlotRawData", as.symbol(cally))
+ datashield.assign.expr(datasources, "boxPlotRawData", call("boxPlotGG_data_TreatmentDS", table.name = table, variables = variables, group = group, group2 = group2))
}
diff --git a/R/ds.boxPlotGG_data_Treatment_numeric.R b/R/ds.boxPlotGG_data_Treatment_numeric.R
index 0cf4b383d..b80baca6d 100644
--- a/R/ds.boxPlotGG_data_Treatment_numeric.R
+++ b/R/ds.boxPlotGG_data_Treatment_numeric.R
@@ -11,19 +11,12 @@
#' Column 'x': Names on the X axis of the boxplot, aka name of the vector (vector argument) \cr
#' Column 'value': Values for that variable \cr
#'
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
ds.boxPlotGG_data_Treatment_numeric <- function(vector, datasources = NULL){
- if (is.null(datasources)) {
- datasources <- DSI::datashield.connections_find()
- }
+ datasources <- .set_datasources(datasources)
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
-
- cally <- paste0("boxPlotGG_data_Treatment_numericDS(", vector, ")")
- DSI::datashield.assign.expr(datasources, "boxPlotRawDataNumeric", as.symbol(cally))
+ datashield.assign.expr(datasources, "boxPlotRawDataNumeric", call("boxPlotGG_data_Treatment_numericDS", vector.name = vector))
}
diff --git a/R/ds.boxPlotGG_numeric.R b/R/ds.boxPlotGG_numeric.R
index c1996628a..e3d4a679f 100644
--- a/R/ds.boxPlotGG_numeric.R
+++ b/R/ds.boxPlotGG_numeric.R
@@ -8,17 +8,11 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} (default \code{NULL}) objects obtained after login
#'
#' @return \code{ggplot} object
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
ds.boxPlotGG_numeric <- function(x, xlabel = "x axis", ylabel = "y axis", type = "pooled", datasources = NULL){
- if (is.null(datasources)) {
- datasources <- DSI::datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
ds.boxPlotGG_data_Treatment_numeric(x, datasources)
diff --git a/R/ds.boxPlotGG_table.R b/R/ds.boxPlotGG_table.R
index ebe9eb4ce..936caf769 100644
--- a/R/ds.boxPlotGG_table.R
+++ b/R/ds.boxPlotGG_table.R
@@ -13,18 +13,12 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} (default \code{NULL}) objects obtained after login
#'
#' @return \code{ggplot} object
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
ds.boxPlotGG_table <- function(x, variables, group = NULL, group2 = NULL, xlabel = "x axis",
ylabel = "y axis", type = "pooled", datasources = NULL){
- if (is.null(datasources)) {
- datasources <- DSI::datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
ds.boxPlotGG_data_Treatment(x, variables, group, group2, datasources)
diff --git a/R/ds.c.R b/R/ds.c.R
index 2093ac013..7be360a44 100644
--- a/R/ds.c.R
+++ b/R/ds.c.R
@@ -10,7 +10,9 @@
#' @param x a vector of character string providing the names of the objects to be combined.
#' @param newobj a character string that provides the name for the output object
#' that is stored on the data servers. Default \code{c.newobj}.
-#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
+#' @param classConsistencyCheck logical. If TRUE, verifies that each input object has
+#' the same class across all studies before concatenation. Default TRUE.
+#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.c} returns the vector of concatenating R
@@ -53,19 +55,12 @@
#'
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
-#'
-ds.c <- function(x=NULL, newobj=NULL, datasources=NULL){
+#'
+ds.c <- function(x=NULL, newobj=NULL, datasources=NULL, classConsistencyCheck=TRUE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("x=NULL. Please provide the names of the objects to concatenate!", call.=FALSE)
@@ -76,19 +71,14 @@ ds.c <- function(x=NULL, newobj=NULL, datasources=NULL){
newobj <- "c.newobj"
}
- # check if the input object(s) is(are) defined in all the studies
- lapply(x, function(k){isDefined(datasources, obj=k)})
-
- # call the internal function that checks the input object(s) is(are) of the same class in all studies.
- for(i in 1:length(x)){
- typ <- checkClass(datasources, x[i])
+ if(classConsistencyCheck){
+ for(i in seq_along(x)){
+ checkClass(datasources, x[i])
+ }
}
# call the server side function that does the job
- cally <- paste0("cDS(list(",paste(x,collapse=","),"))")
- DSI::datashield.assign(datasources, newobj, as.symbol(cally))
-
- # check that the new object has been created and display a message accordingly
- finalcheck <- isAssigned(datasources, newobj)
+ cally <- call("cDS", x)
+ DSI::datashield.assign(datasources, newobj, cally)
}
diff --git a/R/ds.cbind.R b/R/ds.cbind.R
index e21cb961c..0f85ca990 100644
--- a/R/ds.cbind.R
+++ b/R/ds.cbind.R
@@ -30,17 +30,16 @@
#' @param force.colnames can be NULL (recommended) or a vector of characters that specifies
#' column names of the output object. If it is not NULL the user should take some caution.
#' For more information see \strong{Details}.
-#' @param newobj a character string that provides the name for the output variable
-#' that is stored on the data servers. Defaults \code{cbind.newobj}.
-#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
+#' @param classConsistencyCheck logical. If TRUE, verifies that each input object has the same class across all studies. Default TRUE.
+#' @param newobj a character string that provides the name for the output variable
+#' that is stored on the data servers. Defaults \code{cbind.newobj}.
+#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @param notify.of.progress specifies if console output should be produced to indicate
#' progress. Default FALSE.
-#' @return \code{ds.cbind} returns a data frame combining the columns of the R
-#' objects specified in the function which is written to the server-side.
-#' It also returns to the client-side two messages with the name of \code{newobj}
-#' that has been created in each data source and \code{DataSHIELD.checks} result.
+#' @return \code{ds.cbind} returns a data frame combining the columns of the R
+#' objects specified in the function which is written to the server-side.
#' @examples
#'
#' \dontrun{
@@ -113,37 +112,29 @@
#' }
#'
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
-#'
-ds.cbind <- function(x=NULL, DataSHIELD.checks=FALSE, force.colnames=NULL, newobj=NULL, datasources=NULL, notify.of.progress=FALSE){
-
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
+#'
+ds.cbind <- function(x=NULL, DataSHIELD.checks=FALSE, force.colnames=NULL, newobj=NULL, datasources=NULL, notify.of.progress=FALSE, classConsistencyCheck=TRUE){
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide a vector of character strings holding the name of the input elements!", call.=FALSE)
}
if(DataSHIELD.checks){
-
- # check if the input object(s) is(are) defined in all the studies
- lapply(x, function(k){isDefined(datasources, obj=k)})
-
+
# call the internal function that checks the input object(s) is(are) of the same legal class in all studies.
+ if(classConsistencyCheck){
for(i in 1:length(x)){
typ <- checkClass(datasources, x[i])
if(!('data.frame' %in% typ) & !('matrix' %in% typ) & !('factor' %in% typ) & !('character' %in% typ) & !('numeric' %in% typ) & !('integer' %in% typ) & !('logical' %in% typ)){
stop("Only objects of type 'data.frame', 'matrix', 'numeric', 'integer', 'character', 'factor' and 'logical' are allowed.", call.=FALSE)
}
}
-
+ }
+
# check that there are no duplicated column names in the input components
for(j in 1:length(datasources)){
colNames <- list()
@@ -158,10 +149,10 @@ ds.cbind <- function(x=NULL, DataSHIELD.checks=FALSE, force.colnames=NULL, newob
colNames <- unlist(colNames)
if(anyDuplicated(colNames) != 0){
message("\n Warning: Some column names in study", j, "are duplicated and a suffix '.k' will be added to the kth replicate \n")
- }
- }
- }
-
+ }
+ }
+ }
+
# check that the number of rows is the same in all componets to be cbind
for(j in 1:length(datasources)){
nrows <- list()
@@ -178,8 +169,8 @@ ds.cbind <- function(x=NULL, DataSHIELD.checks=FALSE, force.colnames=NULL, newob
if(any(nrows != nrows[1])){
stop("The number of rows is not the same in all of the components to be cbind", call.=FALSE)
}
- }
-
+ }
+
}
# check newobj not actively declared as null
@@ -238,63 +229,6 @@ ds.cbind <- function(x=NULL, DataSHIELD.checks=FALSE, force.colnames=NULL, newob
DSI::datashield.assign(datasources[std], newobj, calltext)
}
- #############################################################################################################
- # DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED
-
- # SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION
- test.obj.name <- newobj
-
- # CALL SEVERSIDE FUNCTION
- calltext <- call("testObjExistsDS", test.obj.name)
- object.info <- DSI::datashield.aggregate(datasources, calltext)
-
- # CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS
- # AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS
- num.datasources <- length(object.info)
-
- obj.name.exists.in.all.sources <- TRUE
- obj.non.null.in.all.sources <- TRUE
-
- for(j in 1:num.datasources){
- if(!object.info[[j]]$test.obj.exists){
- obj.name.exists.in.all.sources <- FALSE
- }
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){
- obj.non.null.in.all.sources <- FALSE
- }
- }
-
- if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){
- return.message <- paste0("A data object <", test.obj.name, "> has been created in all specified data sources")
- }else{
- return.message.1 <- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources")
- return.message.2 <- paste0("It is either ABSENT and/or has no valid content/class,see return.info above")
- return.message.3 <- paste0("Please use ds.ls() to identify where missing")
- return.message <- list(return.message.1,return.message.2,return.message.3)
- }
-
- calltext <- call("messageDS", test.obj.name)
- studyside.message <- DSI::datashield.aggregate(datasources, calltext)
- no.errors <- TRUE
- for(nd in 1:num.datasources){
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){
- no.errors <- FALSE
- }
- }
-
- if(no.errors){
- validity.check <- paste0("<",test.obj.name, "> appears valid in all sources")
- return(list(is.object.created=return.message,validity.check=validity.check))
- }
-
- if(!no.errors){
- validity.check <- paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:")
- return(list(is.object.created=return.message,validity.check=validity.check,
- studyside.messages=studyside.message))
- }
-
- # END OF CHECK OBJECT CREATED CORECTLY MODULE
- #######################################################################################################
}
#ds.cbind
diff --git a/R/ds.changeRefGroup.R b/R/ds.changeRefGroup.R
index 4bd5080ae..a06ac1435 100644
--- a/R/ds.changeRefGroup.R
+++ b/R/ds.changeRefGroup.R
@@ -28,6 +28,7 @@
#' @return \code{ds.changeRefGroup} returns a new vector with the specified level as a reference
#' which is written to the server-side.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @seealso \code{\link{ds.cbind}} Combines objects column-wise.
#' @seealso \code{\link{ds.levels}} to obtain the levels (categories) of a vector of type factor.
#' @seealso \code{\link{ds.colnames}} to obtain the column names of a matrix or a data frame
@@ -109,15 +110,7 @@
#' @export
ds.changeRefGroup <- function(x=NULL, ref=NULL, newobj=NULL, reorderByRef=FALSE, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of a vector of type factor!", call.=FALSE)
@@ -132,26 +125,12 @@ ds.changeRefGroup <- function(x=NULL, ref=NULL, newobj=NULL, reorderByRef=FALSE,
newobj <- "changerefgroup.newobj"
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
-
- # if input vector is not a factor stop
- if(!('factor' %in% typ)){
- stop("The input vector must be a factor!", call.=FALSE)
- }
-
if(reorderByRef){
warning("'reorderByRef' is set to TRUE. Please read the documentation for possible consequences!", call.=FALSE)
}
# call the server side function that will recode the levels
- cally <- paste0('changeRefGroupDS(', x, ",'", ref, "',", reorderByRef,")")
- DSI::datashield.assign(datasources, newobj, as.symbol(cally))
-
- # check that the new object has been created and display a message accordingly
- finalcheck <- isAssigned(datasources, newobj)
+ calltext <- call("changeRefGroupDS", x, ref, reorderByRef)
+ DSI::datashield.assign(datasources, newobj, calltext)
}
diff --git a/R/ds.class.R b/R/ds.class.R
index 036848ad8..ab6e89378 100644
--- a/R/ds.class.R
+++ b/R/ds.class.R
@@ -11,6 +11,7 @@
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.class} returns the type of the R object.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @seealso \code{\link{ds.exists}} to verify if an object is defined (exists) on the server-side.
#' @examples
#' \dontrun{
@@ -54,23 +55,12 @@
#'
ds.class <- function(x=NULL, datasources=NULL) {
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input object!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- defined <- isDefined(datasources, x)
-
cally <- call('classDS', x)
output <- DSI::datashield.aggregate(datasources, cally)
diff --git a/R/ds.colnames.R b/R/ds.colnames.R
index a9e802523..06e647284 100644
--- a/R/ds.colnames.R
+++ b/R/ds.colnames.R
@@ -1,69 +1,59 @@
#'
#' @title Produces column names of the R object in the server-side
-#' @description Retrieves column names of an R object on the server-side.
+#' @description Retrieves column names of an R object on the server-side.
#' This function is similar to R function \code{colnames}.
-#' @details The input is restricted to the object of type \code{data.frame} or \code{matrix}.
-#'
+#' @details The input is restricted to the object of type \code{data.frame} or \code{matrix}.
+#'
#' Server function called: \code{colnamesDS}
#' @param x a character string providing the name of the input data frame or matrix.
-#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
+#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.colnames} returns the column names of
-#' the specified server-side data frame or matrix.
+#' @return \code{ds.colnames} returns the column names of
+#' the specified server-side data frame or matrix.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @seealso \code{\link{ds.dim}} to obtain the dimensions of a matrix or a data frame.
-#' @examples
+#' @examples
#' \dontrun{
-#'
+#'
#' ## Version 6, for version 5 see the Wiki
#' # Connecting to the Opal servers
-#'
+#'
#' require('DSI')
#' require('DSOpal')
#' require('dsBaseClient')
-#'
+#'
#' builder <- DSI::newDSLoginBuilder()
-#' builder$append(server = "study1",
-#' url = "http://192.168.56.100:8080/",
-#' user = "administrator", password = "datashield_test&",
+#' builder$append(server = "study1",
+#' url = "http://192.168.56.100:8080/",
+#' user = "administrator", password = "datashield_test&",
#' table = "CNSIM.CNSIM1", driver = "OpalDriver")
-#' builder$append(server = "study2",
-#' url = "http://192.168.56.100:8080/",
-#' user = "administrator", password = "datashield_test&",
+#' builder$append(server = "study2",
+#' url = "http://192.168.56.100:8080/",
+#' user = "administrator", password = "datashield_test&",
#' table = "CNSIM.CNSIM2", driver = "OpalDriver")
#' builder$append(server = "study3",
-#' url = "http://192.168.56.100:8080/",
-#' user = "administrator", password = "datashield_test&",
+#' url = "http://192.168.56.100:8080/",
+#' user = "administrator", password = "datashield_test&",
#' table = "CNSIM.CNSIM3", driver = "OpalDriver")
#' logindata <- builder$build()
-#'
+#'
#' # Log onto the remote Opal training servers
-#' connections <- DSI::datashield.login(logins = logindata, assign = TRUE, symbol = "D")
-#'
+#' connections <- DSI::datashield.login(logins = logindata, assign = TRUE, symbol = "D")
+#'
#' # Getting column names of the R objects stored in the server-side
#' ds.colnames(x = "D",
#' datasources = connections[1]) #only the first server ("study1") is used
#' # Clear the Datashield R sessions and logout
-#' datashield.logout(connections)
+#' datashield.logout(connections)
#' }
#' @export
#'
ds.colnames <- function(x=NULL, datasources=NULL) {
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
-
- if(is.null(x)){
- stop("Please provide the name of a data.frame or matrix!", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
+ .check_df_name_provided(x)
cally <- call("colnamesDS", x)
column_names <- DSI::datashield.aggregate(datasources, cally)
diff --git a/R/ds.completeCases.R b/R/ds.completeCases.R
index ed95bf6d3..107f70de6 100644
--- a/R/ds.completeCases.R
+++ b/R/ds.completeCases.R
@@ -68,123 +68,22 @@
#' }
#'
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.completeCases <- function(x1=NULL, newobj=NULL, datasources=NULL){
-
- # if no connection login details are provided look for 'connection' objects in the environment
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
- # check if a value has been provided for x1
if(is.null(x1)){
return("Error: x1 must be a character string naming a serverside data.frame, matrix or vector")
}
-
- # check if the input object is defined in all the studies
- isDefined(datasources, x1)
-
- # rename target object for transfer (not strictly necessary as string will pass parser anyway)
- # but maintains consistency with other functions
- x1.transmit <- x1
- # if no value specified for output object, then specify a default
if(is.null(newobj)){
newobj <- paste0(x1,"_complete.cases")
}
- # CALL THE MAIN SERVER SIDE FUNCTION
- calltext <- call("completeCasesDS", x1.transmit)
+ calltext <- call("completeCasesDS", x1)
DSI::datashield.assign(datasources, newobj, calltext)
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
-#ds.completeCases
-
-
diff --git a/R/ds.contourPlot.R b/R/ds.contourPlot.R
index f1fbb3bd8..42084006c 100644
--- a/R/ds.contourPlot.R
+++ b/R/ds.contourPlot.R
@@ -53,8 +53,10 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
+#' @template classConsistencyCheckFalse
#' @return \code{ds.contourPlot} returns a contour plot to the client-side.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -101,17 +103,9 @@
#' }
#' @export
#'
-ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=20, method="smallCellsRule", k=3, noise=0.25, datasources=NULL){
+ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=20, method="smallCellsRule", k=3, noise=0.25, datasources=NULL, classConsistencyCheck=FALSE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("x=NULL. Please provide the names of two numeric vectors!", call.=FALSE)
@@ -119,28 +113,10 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2
if(is.null(y)){
stop("y=NULL. Please provide the names of two numeric vectors!", call.=FALSE)
}
-
+
# Save par and setup reseting of par values
old_par <- graphics::par(no.readonly = TRUE)
on.exit(graphics::par(old_par), add = TRUE)
-
- # check if the input objects are defined in all the studies
- isDefined(datasources, x)
- isDefined(datasources, y)
-
- # call the internal function that checks the input object(s) is(are) of the same class in all studies.
- typ.x <- checkClass(datasources, x)
- typ.y <- checkClass(datasources, y)
-
- # the input objects must be numeric or integer vectors
- if(!('integer' %in% typ.x) & !('numeric' %in% typ.x)){
- message(paste0(x, " is of type ", typ.x, "!"))
- stop("The input objects must be integer or numeric vectors.", call.=FALSE)
- }
- if(!('integer' %in% typ.y) & !('numeric' %in% typ.y)){
- message(paste0(y, " is of type ", typ.y, "!"))
- stop("The input objects must be integer or numeric vectors.", call.=FALSE)
- }
# the argument method must be either "smallCellsRule" or "deterministic" or "probabilistic"
if(method != 'smallCellsRule' & method != 'deterministic' & method != 'probabilistic'){
@@ -167,8 +143,11 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2
method.indicator <- 1
# call the server-side function that generates the x and y coordinates of the centroids
- cally <- paste0("heatmapPlotDS(", x, ",", y, ",", k, ",", noise, ",", method.indicator, ")")
- anonymous.data <- DSI::datashield.aggregate(datasources, cally)
+ anonymous.data <- datashield.aggregate(datasources, call("heatmapPlotDS", x.name=x, y.name=y, k=k, noise=noise, method.indicator=method.indicator))
+ if(classConsistencyCheck){
+ .checkClassConsistency(anonymous.data, field = "class.x", object_name = x)
+ .checkClassConsistency(anonymous.data, field = "class.y", object_name = y)
+ }
pooled.points.x <- c()
pooled.points.y <- c()
@@ -183,8 +162,11 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2
method.indicator <- 2
# call the server-side function that generates the x and y coordinates of the anonymous.data
- cally <- paste0("heatmapPlotDS(", x, ",", y, ",", k, ",", noise, ",", method.indicator, ")")
- anonymous.data <- DSI::datashield.aggregate(datasources, cally)
+ anonymous.data <- datashield.aggregate(datasources, call("heatmapPlotDS", x.name=x, y.name=y, k=k, noise=noise, method.indicator=method.indicator))
+ if(classConsistencyCheck){
+ .checkClassConsistency(anonymous.data, field = "class.x", object_name = x)
+ .checkClassConsistency(anonymous.data, field = "class.y", object_name = y)
+ }
pooled.points.x <- c()
pooled.points.y <- c()
@@ -199,11 +181,9 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2
if(method=='smallCellsRule'){
# get the range from each study and produce the 'global' range
- cally <- paste0("rangeDS(", x, ")")
- x.ranges <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ x.ranges <- datashield.aggregate(datasources, call("rangeDS", x))
- cally <- paste0("rangeDS(", y, ")")
- y.ranges <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ y.ranges <- datashield.aggregate(datasources, call("rangeDS", y))
x.minrs <- c()
x.maxrs <- c()
@@ -224,9 +204,12 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2
y.global.max <- y.range.arg[2]
# generate the grid density object to plot
- cally <- paste0("densityGridDS(",x,",",y,",",limits=T,",",x.global.min,",",
- x.global.max,",",y.global.min,",",y.global.max,",",numints, ")")
- grid.density.obj <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ grid.density.obj <- datashield.aggregate(datasources, call("densityGridDS", x=x, y=y, limits=TRUE, x.min=x.global.min, x.max=x.global.max, y.min=y.global.min, y.max=y.global.max, numints=numints))
+ if(classConsistencyCheck){
+ .checkClassConsistency(grid.density.obj, field = "class.x", object_name = x)
+ .checkClassConsistency(grid.density.obj, field = "class.y", object_name = y)
+ }
+ grid.density.obj <- lapply(grid.density.obj, function(r) r$grid)
numcol <- dim(grid.density.obj[[1]])[2]
@@ -376,10 +359,12 @@ ds.contourPlot <- function(x=NULL, y=NULL, type='combine', show='all', numints=2
if(method=="smallCellsRule"){
# generate the grid density object to plot
- num_intervals <- numints
- cally <- paste0("densityGridDS(",x,",",y,",",'limits=FALSE',",",'x.min=NULL',",",
- 'x.max=NULL',",",'y.min=NULL',",",'y.max=NULL',",",numints=num_intervals, ")")
- grid.density.obj <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ grid.density.obj <- datashield.aggregate(datasources, call("densityGridDS", x=x, y=y, limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=numints))
+ if(classConsistencyCheck){
+ .checkClassConsistency(grid.density.obj, field = "class.x", object_name = x)
+ .checkClassConsistency(grid.density.obj, field = "class.y", object_name = y)
+ }
+ grid.density.obj <- lapply(grid.density.obj, function(r) r$grid)
numcol <- dim(grid.density.obj[[1]])[2]
}
diff --git a/R/ds.cor.R b/R/ds.cor.R
index 53fb22db4..9c0ef8e1d 100644
--- a/R/ds.cor.R
+++ b/R/ds.cor.R
@@ -30,6 +30,7 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
+#' @template classConsistencyCheckTrue
#' @return \code{ds.cor} returns a list containing the number of missing values in each variable,
#' the number of missing variables casewise, the correlation matrix,
#' the number of used complete cases. The function applies two disclosure controls. The first disclosure
@@ -37,6 +38,7 @@
#' percentage is pre-specified by the 'nfilter.glm'). The second disclosure control checks that none of them is dichotomous
#' with a level having fewer counts than the pre-specified 'nfilter.tab' threshold.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -79,56 +81,25 @@
#' }
#' @export
#'
-ds.cor <- function(x=NULL, y=NULL, type="split", datasources=NULL){
+ds.cor <- function(x=NULL, y=NULL, type="split", datasources=NULL, classConsistencyCheck=TRUE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("x=NULL. Please provide the name of a matrix or dataframe or the names of two numeric vectors!", call.=FALSE)
- }else{
- isDefined(datasources, x)
- }
-
- # check the type of the input objects
- typ <- checkClass(datasources, x)
-
- if(('numeric' %in% typ) | ('integer' %in% typ) | ('factor' %in% typ)){
- if(is.null(y)){
- stop("If x is a numeric vector, y must be a numeric vector!", call.=FALSE)
- }else{
- isDefined(datasources, y)
- typ2 <- checkClass(datasources, y)
- }
- }
-
- if(('matrix' %in% typ) | ('data.frame' %in% typ) & !(is.null(y))){
- y <- NULL
- warning("x is a matrix or a dataframe; y will be ignored and a correlation matrix computed for x!")
}
# name of the studies to be used in the output
stdnames <- names(datasources)
# call the server side function
- if(('matrix' %in% typ) | ('data.frame' %in% typ)){
- calltext <- call("corDS", x, NULL)
- }else{
- if(!(is.null(y))){
- calltext <- call("corDS", x, y)
- }else{
- calltext <- call("corDS", x, NULL)
- }
- }
+ calltext <- call("corDS", x, y)
output <- DSI::datashield.aggregate(datasources, calltext)
-
+
+ if(classConsistencyCheck){
+ .checkClassConsistency(output)
+ }
+
if (type=="split"){
covariance <- list()
sqrt.diag <- list()
diff --git a/R/ds.corTest.R b/R/ds.corTest.R
index 3c9e42a81..95b59d0c8 100644
--- a/R/ds.corTest.R
+++ b/R/ds.corTest.R
@@ -22,8 +22,10 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
+#' @template classConsistencyCheckFalse
#' @return \code{ds.corTest} returns to the client-side the results of the correlation test.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -63,17 +65,9 @@
#'
#' }
#'
-ds.corTest <- function(x=NULL, y=NULL, method="pearson", exact=NULL, conf.level=0.95, type='split', datasources=NULL){
+ds.corTest <- function(x=NULL, y=NULL, method="pearson", exact=NULL, conf.level=0.95, type='split', datasources=NULL, classConsistencyCheck=FALSE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("x=NULL. Please provide the names of the 1st numeric vector!", call.=FALSE)
@@ -85,19 +79,18 @@ ds.corTest <- function(x=NULL, y=NULL, method="pearson", exact=NULL, conf.level=
if(!(method %in% c("pearson", "kendall", "spearman"))){
stop('Function argument "method" has to be either "pearson", "kendall" or "spearman"', call.=FALSE)
}
-
- # check if the input objects are defined in all the studies
- isDefined(datasources, x)
- isDefined(datasources, y)
-
- # call the internal function that checks the input objects are of the same class in all studies.
- typ <- checkClass(datasources, x)
- typ <- checkClass(datasources, y)
# call the server side function
cally <- call("corTestDS", x, y, method, exact, conf.level)
out <- DSI::datashield.aggregate(datasources, cally)
+ if(classConsistencyCheck){
+ .checkClassConsistency(out)
+ }
+
+ # strip class field from results before returning
+ out <- lapply(out, function(r) { r$class <- NULL; r })
+
if(type=="split"){
return(out)
}else{
diff --git a/R/ds.cov.R b/R/ds.cov.R
index c67d2e134..0aa75a3d5 100644
--- a/R/ds.cov.R
+++ b/R/ds.cov.R
@@ -35,6 +35,7 @@
#' \code{'pairwise.complete'}. Default \code{'pairwise.complete'}. For more information see details.
#' @param type a character string that represents the type of analysis to carry out.
#' This must be set to \code{'split'} or \code{'combine'}. Default \code{'split'}. For more information see details.
+#' @template classConsistencyCheckTrue
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
@@ -47,6 +48,7 @@
#' the disclosure controls then all the output values are replaced with NAs. If all the variables are valid and pass
#' the controls, then the output matrices are returned and also an error message is returned but it is replaced by NA.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -96,56 +98,25 @@
#' }
#' @export
#'
-ds.cov <- function(x=NULL, y=NULL, naAction='pairwise.complete', type="split", datasources=NULL){
+ds.cov <- function(x=NULL, y=NULL, naAction='pairwise.complete', type="split", datasources=NULL, classConsistencyCheck=TRUE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("x=NULL. Please provide the name of a matrix or dataframe or the names of two numeric vectors!", call.=FALSE)
- }else{
- isDefined(datasources, x)
- }
-
- # check the type of the input objects
- typ <- checkClass(datasources, x)
-
- if(('numeric' %in% typ) | ('integer' %in% typ) | ('factor' %in% typ)){
- if(is.null(y)){
- stop("If x is a numeric vector, y must be a numeric vector!", call.=FALSE)
- }else{
- isDefined(datasources, y)
- typ2 <- checkClass(datasources, y)
- }
- }
-
- if(('matrix' %in% typ) | ('data.frame' %in% typ) & !(is.null(y))){
- y <- NULL
- warning("x is a matrix or a dataframe; y will be ignored and a covariance matrix computed for x!")
}
# name of the studies to be used in the output
stdnames <- names(datasources)
# call the server side function
- if(('matrix' %in% typ) | ('data.frame' %in% typ)){
- calltext <- call("covDS", x, NULL, naAction)
- }else{
- if(!(is.null(y))){
- calltext <- call("covDS", x, y, naAction)
- }else{
- calltext <- call("covDS", x, NULL, naAction)
- }
- }
+ calltext <- call("covDS", x, y, naAction)
output <- DSI::datashield.aggregate(datasources, calltext)
-
+
+ if(classConsistencyCheck){
+ .checkClassConsistency(output)
+ }
+
if (type=="split"){
covariance <- list()
results <- list()
diff --git a/R/ds.dataFrame.R b/R/ds.dataFrame.R
index eeddcdd90..ccd671c4d 100644
--- a/R/ds.dataFrame.R
+++ b/R/ds.dataFrame.R
@@ -30,17 +30,16 @@
#' 3. if there are any duplicated column names in the input objects in each study\cr
#' 4. the number of rows of the data frames or matrices and the length of all component variables
#' are the same
-#' @param newobj a character string that provides the name for the output data frame
-#' that is stored on the data servers. Default \code{dataframe.newobj}.
-#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
+#' @param classConsistencyCheck logical. If TRUE, verifies that each input object has the same class across all studies. Default TRUE.
+#' @param newobj a character string that provides the name for the output data frame
+#' that is stored on the data servers. Default \code{dataframe.newobj}.
+#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @param notify.of.progress specifies if console output should be produced to indicate
#' progress. Default is FALSE.
#' @return \code{ds.dataFrame} returns the object specified by the \code{newobj} argument
-#' which is written to the serverside. Also, two validity messages are returned to the
-#' client-side indicating the name of the \code{newobj} that has been created in each data source
-#' and if it is in a valid form.
+#' which is written to the server-side.
#' @examples
#'
#' \dontrun{
@@ -89,18 +88,11 @@
#' datashield.logout(connections)
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
-ds.dataFrame <- function(x=NULL, row.names=NULL, check.rows=FALSE, check.names=TRUE, stringsAsFactors=TRUE, completeCases=FALSE, DataSHIELD.checks=FALSE, newobj=NULL, datasources=NULL, notify.of.progress=FALSE){
+ds.dataFrame <- function(x=NULL, row.names=NULL, check.rows=FALSE, check.names=TRUE, stringsAsFactors=TRUE, completeCases=FALSE, DataSHIELD.checks=FALSE, newobj=NULL, datasources=NULL, notify.of.progress=FALSE, classConsistencyCheck=TRUE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the list that holds the input vectors!", call.=FALSE)
@@ -112,17 +104,16 @@ ds.dataFrame <- function(x=NULL, row.names=NULL, check.rows=FALSE, check.names=T
}
if(DataSHIELD.checks){
-
- # check if the input object(s) is(are) defined in all the studies
- lapply(x, function(k){isDefined(datasources, obj=k)})
-
+
# call the internal function that checks the input object(s) is(are) of the same legal class in all studies.
+ if(classConsistencyCheck){
for(i in 1:length(x)){
typ <- checkClass(datasources, x[i])
if(!('data.frame' %in% typ) & !('matrix' %in% typ) & !('factor' %in% typ) & !('character' %in% typ) & !('numeric' %in% typ) & !('integer' %in% typ) & !('logical' %in% typ)){
stop("Only objects of type 'data.frame', 'matrix', 'numeric', 'integer', 'character', 'factor' and 'logical' are allowed.", call.=FALSE)
}
}
+ }
# check that there are no duplicated column names in the input components
for(j in 1:length(datasources)){
@@ -229,85 +220,5 @@ ds.dataFrame <- function(x=NULL, row.names=NULL, check.rows=FALSE, check.names=T
DSI::datashield.assign(datasources[std], newobj, cally)
}
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.dataFrame
diff --git a/R/ds.dataFrameFill.R b/R/ds.dataFrameFill.R
index 3de389b7d..f4bb080c4 100644
--- a/R/ds.dataFrameFill.R
+++ b/R/ds.dataFrameFill.R
@@ -13,15 +13,15 @@
#' filled with extra columns of missing values.
#' @param newobj a character string that provides the name for the output data frame
#' that is stored on the data servers. Default value is "dataframefill.newobj".
-#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
+#' @param classConsistencyCheck logical. If TRUE, verifies that each input object has the same class across all studies. Default TRUE.
+#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.dataFrameFill} returns the object specified by the \code{newobj} argument which
-#' is written to the server-side. Also, two validity messages are returned to the
-#' client-side indicating the name of the \code{newobj} that has been created in each data source
-#' and if it is in a valid form.
+#' @return \code{ds.dataFrameFill} returns the object specified by the \code{newobj} argument which
+#' is written to the server-side.
#' @author Demetris Avraam for DataSHIELD Development Team
-#'
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
+#'
#' @examples
#' \dontrun{
#'
@@ -74,17 +74,9 @@
#' }
#' @export
#'
-ds.dataFrameFill <- function(df.name=NULL, newobj=NULL, datasources=NULL){
+ds.dataFrameFill <- function(df.name=NULL, newobj=NULL, datasources=NULL, classConsistencyCheck=TRUE){
- # if no connections details are provided look for 'connection' objects in the environment
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if user has provided the name of the data.frame to be subsetted
if(is.null(df.name)){
@@ -96,15 +88,14 @@ ds.dataFrameFill <- function(df.name=NULL, newobj=NULL, datasources=NULL){
newobj <- "dataframefill.newobj"
}
- # check if the input dataframe is defined in all the studies
- defined <- isDefined(datasources, df.name)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, df.name)
+ if(classConsistencyCheck){
+ # call the internal function that checks the input object is of the same class in all studies.
+ typ <- checkClass(datasources, df.name)
- # if the input object is not a matrix or a dataframe stop
- if(!('data.frame' %in% typ) && !('matrix' %in% typ)){
- stop("The input vector must be of type 'data.frame' or a 'matrix'!", call.=FALSE)
+ # if the input object is not a matrix or a dataframe stop
+ if(!('data.frame' %in% typ) && !('matrix' %in% typ)){
+ stop("The input vector must be of type 'data.frame' or a 'matrix'!", call.=FALSE)
+ }
}
column.names <- lapply(datasources, function(dts){DSI::datashield.aggregate(dts, call("colnamesDS", df.name))})
@@ -134,9 +125,17 @@ ds.dataFrameFill <- function(df.name=NULL, newobj=NULL, datasources=NULL){
defined.vect1 <- lapply(defined.list, function(x){unlist(x)})
defined.vect2 <- lapply(defined.vect1, function(x){which(x == FALSE)})
- # get the class of each variable in the dataframes
- class.list <- lapply(allNames, function(x){lapply(datasources, function(dts){DSI::datashield.aggregate(dts, call('classDS', paste0(df.name, '$', x)))})})
- class.vect1 <- lapply(class.list, function(x){unlist(x)})
+ # get the class of each variable in the dataframes, skipping servers where the column doesn't exist
+ class.list <- lapply(seq_along(allNames), function(idx){
+ sapply(seq_along(datasources), function(ds_idx){
+ if(ds_idx %in% defined.vect2[[idx]]){
+ "NULL"
+ } else {
+ DSI::datashield.aggregate(datasources[ds_idx], call('classDS', paste0(df.name, '$', allNames[idx])))[[1]]
+ }
+ })
+ })
+ class.vect1 <- class.list
# the loop below is to avoid autocompletion of variable name
for (i in 1:length(allNames.transmit)){
if(length(defined.vect2[[i]])>0){class.vect1[[i]][defined.vect2[[i]]]<-'NULL'}
@@ -172,63 +171,6 @@ ds.dataFrameFill <- function(df.name=NULL, newobj=NULL, datasources=NULL){
calltext <- call("dataFrameFillDS", df.name, allNames.transmit, class.vect.transmit, levels.vec.transmit)
DSI::datashield.assign(datasources, newobj, calltext)
- #############################################################################################################
- # DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED
-
- # SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION
- test.obj.name <- newobj
-
- # CALL SEVERSIDE FUNCTION
- calltext <- call("testObjExistsDS", test.obj.name)
- object.info <- DSI::datashield.aggregate(datasources, calltext)
-
- # CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS
- # AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS
- num.datasources <- length(object.info)
-
- obj.name.exists.in.all.sources <- TRUE
- obj.non.null.in.all.sources <- TRUE
-
- for(j in 1:num.datasources){
- if(!object.info[[j]]$test.obj.exists){
- obj.name.exists.in.all.sources <- FALSE
- }
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){
- obj.non.null.in.all.sources <- FALSE
- }
- }
-
- if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){
- return.message <- paste0("A data object <", test.obj.name, "> has been created in all specified data sources")
- }else{
- return.message.1 <- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources")
- return.message.2 <- paste0("It is either ABSENT and/or has no valid content/class, see return.info above")
- return.message.3 <- paste0("Please use ds.ls() to identify where missing")
- return.message <- list(return.message.1, return.message.2, return.message.3)
- }
-
- calltext <- call("messageDS", test.obj.name)
- studyside.message <- DSI::datashield.aggregate(datasources, calltext)
-
- no.errors <- TRUE
- for(nd in 1:num.datasources){
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){
- no.errors <- FALSE
- }
- }
-
- if(no.errors){
- validity.check <- paste0("<",test.obj.name, "> appears valid in all sources")
- return(list(is.object.created=return.message, validity.check=validity.check))
- }
-
- if(!no.errors){
- validity.check <- paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:")
- return(list(is.object.created=return.message, validity.check=validity.check, studyside.messages=studyside.message))
- }
-
- # END OF CHECK OBJECT CREATED CORRECTLY MODULE
- #############################################################################################################
}
# ds.dataFrameFill
diff --git a/R/ds.dataFrameSort.R b/R/ds.dataFrameSort.R
index de59d61e8..f8fc52f77 100644
--- a/R/ds.dataFrameSort.R
+++ b/R/ds.dataFrameSort.R
@@ -36,11 +36,7 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.dataFrameSort} returns the sorted data frame is written to the server-side.
-#' Also, two validity messages are returned to the client-side
-#' indicating the name of the \code{newobj} which
-#' has been created in each data source and if
-#' it is in a valid form.
+#' @return \code{ds.dataFrameSort} returns the sorted data frame which is written to the server-side.
#' @examples
#' \dontrun{
#' ## Version 6, for version 5 see the Wiki
@@ -81,20 +77,13 @@
#'
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
-#'
+#'
ds.dataFrameSort<-function(df.name=NULL, sort.key.name=NULL, sort.descending=FALSE,
sort.method="default", newobj=NULL, datasources=NULL){
-
- # if no opal login details are provided look for 'opal' objects in the environment
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(sort.method)){
sort.method <- "default"
@@ -116,91 +105,11 @@ ds.dataFrameSort<-function(df.name=NULL, sort.key.name=NULL, sort.descending=FAL
sort.descending <- FALSE
}
- if(is.null(newobj)){
- newobj <- "dataframesort.newobj"
- }
+ newobj <- .set_newobj_name(newobj, "dataframesort.newobj")
# Call to assign function
calltext <- call("dataFrameSortDS", df.name, sort.key.name, sort.descending, sort.method)
datashield.assign(datasources, newobj, calltext)
-
- ###########################################################################################################
- #DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- # #
- #SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
- test.obj.name<-newobj #
- # #
- # #
- # CALL SEVERSIDE FUNCTION #
- calltext <- call("testObjExistsDS", test.obj.name) #
- # #
- # object.info<-opal::datashield.aggregate(datasources, calltext) #
- object.info<-datashield.aggregate(datasources, calltext) #
- # #
- # CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
- # AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
- num.datasources<-length(object.info) #
- # #
- # #
- obj.name.exists.in.all.sources<-TRUE #
- obj.non.null.in.all.sources<-TRUE #
- # #
- for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ # #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- # #
- if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- # #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- # #
- # #
- }else{ #
- # #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- # #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- # #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- # #
- # #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- # #
- } #
- # #
- calltext <- call("messageDS", test.obj.name) #
- # studyside.message<-opal::datashield.aggregate(datasources, calltext) #
- studyside.message<-datashield.aggregate(datasources, calltext) #
- # #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- # #
- # #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
- if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
- #END OF CHECK OBJECT CREATED CORRECTLY MODULE #
- ###########################################################################################################
+
}
#ds.dataFrameSort
diff --git a/R/ds.dataFrameSubset.R b/R/ds.dataFrameSubset.R
index 1ae6278db..9792afa48 100644
--- a/R/ds.dataFrameSubset.R
+++ b/R/ds.dataFrameSubset.R
@@ -35,10 +35,7 @@
#' progress. Default FALSE.
#' @return \code{ds.dataFrameSubset} returns
#' the object specified by the \code{newobj} argument
-#' which is written to the server-side.
-#' Also, two validity messages are returned to the client-side indicating
-#' the name of the \code{newobj} which has been created in each data source
-#' and if it is in a valid form.
+#' which is written to the server-side.
#' @examples
#' \dontrun{
#'
@@ -105,19 +102,12 @@
#'
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
ds.dataFrameSubset<-function(df.name=NULL, V1.name=NULL, V2.name=NULL, Boolean.operator=NULL, keep.cols=NULL, rm.cols=NULL, keep.NAs=NULL, newobj=NULL, datasources=NULL, notify.of.progress=FALSE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if user has provided the name of the data.frame to be subsetted
if(is.null(df.name)){
@@ -242,81 +232,5 @@ if(!is.null(rm.cols)){
}
}
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.dataFrameSubset
diff --git a/R/ds.densityGrid.R b/R/ds.densityGrid.R
index b0766418a..d617dd731 100644
--- a/R/ds.densityGrid.R
+++ b/R/ds.densityGrid.R
@@ -26,8 +26,10 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
+#' @template classConsistencyCheckFalse
#' @return \code{ds.densityGrid} returns a grid density matrix.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -82,17 +84,9 @@
#'
#' }
#'
-ds.densityGrid <- function(x=NULL, y=NULL, numints=20, type='combine', datasources=NULL){
+ds.densityGrid <- function(x=NULL, y=NULL, numints=20, type='combine', datasources=NULL, classConsistencyCheck=FALSE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the numeric vector 'x'!", call.=FALSE)
@@ -101,14 +95,6 @@ ds.densityGrid <- function(x=NULL, y=NULL, numints=20, type='combine', datasourc
if(is.null(y)){
stop("Please provide the name of the numeric vector 'y'!", call.=FALSE)
}
-
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
- isDefined(datasources, y)
-
- # call the internal function that checks the input objects are of the same class in all studies.
- typ <- checkClass(datasources, x)
- typ <- checkClass(datasources, y)
# name of the studies to be used in the plots' titles
stdnames <- names(datasources)
@@ -118,11 +104,9 @@ ds.densityGrid <- function(x=NULL, y=NULL, numints=20, type='combine', datasourc
if(type=="combine"){
# get the range from each study and produce the 'global' range
- cally <- paste0('rangeDS(', x, ')')
- x.ranges <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ x.ranges <- datashield.aggregate(datasources, call("rangeDS", x))
- cally <- paste0('rangeDS(', y, ')')
- y.ranges <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ y.ranges <- datashield.aggregate(datasources, call("rangeDS", y))
x.minrs <- c()
x.maxrs <- c()
@@ -143,9 +127,12 @@ ds.densityGrid <- function(x=NULL, y=NULL, numints=20, type='combine', datasourc
y.global.max <- y.range.arg[2]
# generate the grid density object to plot
- cally <- paste0("densityGridDS(", x, ",", y, ",", limits=T, ",", x.global.min, ",",
- x.global.max, ",", y.global.min, ",", y.global.max, ",", numints, ")")
- grid.density.obj <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ grid.density.obj <- datashield.aggregate(datasources, call("densityGridDS", x=x, y=y, limits=TRUE, x.min=x.global.min, x.max=x.global.max, y.min=y.global.min, y.max=y.global.max, numints=numints))
+ if(classConsistencyCheck){
+ .checkClassConsistency(grid.density.obj, field = "class.x", object_name = x)
+ .checkClassConsistency(grid.density.obj, field = "class.y", object_name = y)
+ }
+ grid.density.obj <- lapply(grid.density.obj, function(r) r$grid)
numcol <- dim(grid.density.obj[[1]])[2]
# print the number of invalid cells in each participating study
@@ -164,10 +151,12 @@ ds.densityGrid <- function(x=NULL, y=NULL, numints=20, type='combine', datasourc
}else{
if(type=="split"){
# generate the grid density object
- num_intervals <- numints
- cally <- paste0("densityGridDS(", x, ",", y, ",", 'limits=FALSE', ",", 'x.min=NULL', ",",
- 'x.max=NULL', ",", 'y.min=NULL', ",", 'y.max=NULL', ",", numints=num_intervals, ")")
- grid.density.obj <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ grid.density.obj <- datashield.aggregate(datasources, call("densityGridDS", x=x, y=y, limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=numints))
+ if(classConsistencyCheck){
+ .checkClassConsistency(grid.density.obj, field = "class.x", object_name = x)
+ .checkClassConsistency(grid.density.obj, field = "class.y", object_name = y)
+ }
+ grid.density.obj <- lapply(grid.density.obj, function(r) r$grid)
numcol <- dim(grid.density.obj[[1]])[2]
# print the number of invalid cells in each participating study
diff --git a/R/ds.dim.R b/R/ds.dim.R
index 4a6cd3a76..17c5fb75e 100644
--- a/R/ds.dim.R
+++ b/R/ds.dim.R
@@ -7,21 +7,17 @@
#' from every single study and the pooled dimension of the object by summing up the individual
#' dimensions returned from each study.
#'
-#' In \code{checks} parameter is suggested that checks should only be undertaken once the
-#' function call has failed.
-#'
#' Server function called: \code{dimDS}
-#'
-#' @param x a character string providing the name of the input object.
-#' @param type a character string that represents the type of analysis to carry out.
+#'
+#' @param x a character string providing the name of the input object.
+#' @param type a character string that represents the type of analysis to carry out.
#' If \code{type} is set to \code{'combine'}, \code{'combined'}, \code{'combines'} or \code{'c'},
-#' the global dimension is returned.
-#' If \code{type} is set to \code{'split'}, \code{'splits'} or \code{'s'},
+#' the global dimension is returned.
+#' If \code{type} is set to \code{'split'}, \code{'splits'} or \code{'s'},
#' the dimension is returned separately for each study.
#' If \code{type} is set to \code{'both'} or \code{'b'}, both sets of outputs are produced.
-#' Default \code{'both'}.
-#' @param checks logical. If TRUE undertakes all DataSHIELD checks (time-consuming).
-#' Default FALSE.
+#' Default \code{'both'}.
+#' @template classConsistencyCheckTrue
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
@@ -29,6 +25,7 @@
#' in the form of a vector where the first
#' element indicates the number of rows and the second element indicates the number of columns.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @seealso \code{\link{ds.dataFrame}} to generate a table of the type data frame.
#' @seealso \code{\link{ds.changeRefGroup}} to change the reference level of a factor.
#' @seealso \code{\link{ds.colnames}} to obtain the column names of a matrix or a data frame
@@ -67,68 +64,44 @@
#' # Calculate the dimension
#' ds.dim(x="D",
#' type="combine", #global dimension
-#' checks = FALSE,
-#' datasources = connections)#all opal servers are used
+#'#' datasources = connections)#all opal servers are used
#' ds.dim(x="D",
#' type = "both",#separate dimension for each study
#' #and the pooled dimension (default)
-#' checks = FALSE,
-#' datasources = connections)#all opal servers are used
+#'#' datasources = connections)#all opal servers are used
#' ds.dim(x="D",
#' type="split", #separate dimension for each study
-#' checks = FALSE,
-#' datasources = connections[1])#only the first opal server is used ("study1")
+#'#' datasources = connections[1])#only the first opal server is used ("study1")
#'
#' # clear the Datashield R sessions and logout
#' datashield.logout(connections)
#'
#' }
#'
-ds.dim <- function(x=NULL, type='both', checks=FALSE, datasources=NULL) {
+ds.dim <- function(x=NULL, type='both', datasources=NULL, classConsistencyCheck=TRUE) {
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of a data.frame or matrix!", call.=FALSE)
}
- ########################################################################################################
- # MODULE: GENERIC OPTIONAL CHECKS TO ENSURE CONSISTENT STRUCTURE OF KEY VARIABLES IN DIFFERENT SOURCES #
- # beginning of optional checks - the process stops and reports as soon as one check fails #
- # #
- if(checks){ #
- message(" -- Verifying the variables in the model") #
- # check if the input object(s) is(are) defined in all the studies #
- defined <- isDefined(datasources, x) # #
- # call the internal function that checks the input object is suitable in all studies #
- typ <- checkClass(datasources, x) #
- # throw a message and stop if input is not table structure #
- if(!('data.frame' %in% typ) & !('matrix' %in% typ)){ #
- stop("The input object must be a table structure!", call.=FALSE) #
- } #
- } #
- ########################################################################################################
-
-
###################################################################################################
#MODULE: EXTEND "type" argument to include "both" and enable valid aliases #
if(type == 'combine' | type == 'combined' | type == 'combines' | type == 'c') type <- 'combine' #
if(type == 'split' | type == 'splits' | type == 's') type <- 'split' #
if(type == 'both' | type == 'b' ) type <- 'both' #
- #
- #MODIFY FUNCTION CODE TO DEAL WITH ALL THREE TYPES #
###################################################################################################
cally <- call("dimDS", x)
- dimensions <- DSI::datashield.aggregate(datasources, cally)
+ results <- DSI::datashield.aggregate(datasources, cally)
+
+ if(classConsistencyCheck){
+ .checkClassConsistency(results)
+ }
+
+ # extract dimensions from results
+ dimensions <- lapply(results, function(r) r$dim)
# names of the studies to be used in the output
stdnames <- names(datasources)
diff --git a/R/ds.dmtC2S.R b/R/ds.dmtC2S.R
index 085d198fb..3c032b711 100644
--- a/R/ds.dmtC2S.R
+++ b/R/ds.dmtC2S.R
@@ -41,20 +41,13 @@
#' @return the object specified by the argument (or default name "dmt.copied.C2S")
#' which is written as a data.frame/matrix/tibble to the serverside.
#' @author Paul Burton for DataSHIELD Development Team - 3rd June, 2021
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.dmtC2S <- function(dfdata=NA, newobj=NULL, datasources=NULL){
- # if no opal login details are provided look for 'opal' objects in the environment
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
-
+ datasources <- .set_datasources(datasources)
+
# check if a value has been provided for dfdata
if(is.null(dfdata)){
return("Error: dfdata must be a character string, a numeric vector or a scalar")
diff --git a/R/ds.elspline.R b/R/ds.elspline.R
index 01ddca05b..40a77db4d 100644
--- a/R/ds.elspline.R
+++ b/R/ds.elspline.R
@@ -23,27 +23,17 @@
#' @return an object of class "lspline" and "matrix", which its name is specified by the
#' \code{newobj} argument (or its default name "elspline.newobj"), is assigned on the serverside.
#' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.elspline <- function(x, n, marginal = FALSE, names = NULL, newobj = NULL, datasources = NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input variable x!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- defined <- isDefined(datasources, x)
-
if(is.null(n)){
stop("Argument 'n' is missing, with no default!", call.=FALSE)
}
diff --git a/R/ds.exp.R b/R/ds.exp.R
index 5bf325bd8..65102600a 100644
--- a/R/ds.exp.R
+++ b/R/ds.exp.R
@@ -4,7 +4,7 @@
#' This function is similar to R function \code{exp}.
#' @details
#'
-#' Server function called: \code{exp}.
+#' Server function called: \code{expDS}.
#'
#' @param x a character string providing the name of a numerical vector.
#' @param newobj a character string that provides the name for the output variable
@@ -15,6 +15,7 @@
#' @return \code{ds.exp} returns a vector for each study of the exponential values for the numeric vector
#' specified in the argument \code{x}. The created vectors are stored in the server-side.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -57,42 +58,17 @@
#'
ds.exp <- function(x=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input object!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
-
- # call the internal function that checks the input object(s) is(are) of the same class in all studies.
- if(!('numeric' %in% typ) && !('integer' %in% typ)){
- stop(" Only objects of type 'numeric' and 'integer' are allowed.", call.=FALSE)
- }
-
- # create a name by default if user did not provide a name for the new variable
if(is.null(newobj)){
newobj <- "exp.newobj"
}
- # call the server side function that does the job
- cally <- paste0('exp(', x, ')')
- DSI::datashield.assign(datasources, newobj, as.symbol(cally))
-
-
- # check that the new object has been created and display a message accordingly
- finalcheck <- isAssigned(datasources, newobj)
+ cally <- call("expDS", x)
+ DSI::datashield.assign(datasources, newobj, cally)
}
diff --git a/R/ds.gamlss.R b/R/ds.gamlss.R
index 6a7622c76..4a0d040ed 100644
--- a/R/ds.gamlss.R
+++ b/R/ds.gamlss.R
@@ -72,6 +72,7 @@
#' residuals (the normalised quantile residuals of the model) are not disclosed to
#' the client-side.
#' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.gamlss <- function(formula = NULL, sigma.formula = '~1', nu.formula = '~1',
@@ -81,16 +82,8 @@ ds.gamlss <- function(formula = NULL, sigma.formula = '~1', nu.formula = '~1',
i.control = c(0.001, 50, 30, 0.001), centiles = FALSE,
xvar = NULL, newobj = NULL, datasources = NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- DSI::datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
-
+ datasources <- .set_datasources(datasources)
+
# verify that 'formula' was set
if(is.null(formula)){
stop(" Please provide a valid formula!", call.=FALSE)
diff --git a/R/ds.getWGSR.R b/R/ds.getWGSR.R
index ff4c60f51..803068116 100644
--- a/R/ds.getWGSR.R
+++ b/R/ds.getWGSR.R
@@ -58,6 +58,7 @@
#' @return \code{ds.getWGSR} assigns a vector for each study that includes the z-scores for the
#' specified index. The created vectors are stored in the servers.
#' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -102,15 +103,7 @@
#'
ds.getWGSR <- function(sex=NULL, firstPart=NULL, secondPart=NULL, index=NULL, standing=NA, thirdPart=NA, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(sex)){
stop("Please provide the column name of the 'sex' variable!", call.=FALSE)
@@ -124,21 +117,6 @@ ds.getWGSR <- function(sex=NULL, firstPart=NULL, secondPart=NULL, index=NULL, st
stop("Please provide the column name of the 'secondPart' variable!", call.=FALSE)
}
- # check if the input objects are defined in all the studies
- isDefined(datasources, sex)
- isDefined(datasources, firstPart)
- isDefined(datasources, secondPart)
-
- # if 'firstPart' or 'secondPart' are not numeric return an error message
- typ.firstPart <- checkClass(datasources, firstPart)
- typ.secondPart <- checkClass(datasources, secondPart)
- if(!('numeric' %in% typ.firstPart)){
- stop("The 'firstPart' variable must be a 'numeric' variable!", call.=FALSE)
- }
- if(!('numeric' %in% typ.secondPart)){
- stop("The 'secondPart' variable must be a 'numeric' variable!", call.=FALSE)
- }
-
if(!any(index %in% c("bfa", "hca", "hfa", "lfa", "mfa", "ssa", "tsa", "wfa", "wfh", "wfl"))){
stop("Please provide a correct abbreviation for the index!", call.=FALSE)
}
@@ -148,14 +126,6 @@ ds.getWGSR <- function(sex=NULL, firstPart=NULL, secondPart=NULL, index=NULL, st
stop("'thirdPart' variable should not be missing for index 'bfa'", call.=FALSE)
}
- # If 'thirdPart' (age) is not numeric for BMI-for-age return an error message
- if(index == "bfa"){
- typ.thirdPart <- checkClass(datasources, thirdPart)
- if(!('numeric' %in% typ.firstPart)){
- stop("The 'thirdPart' variable must be a 'numeric' variable!", call.=FALSE)
- }
- }
-
# If 'standing' is not a value either 1, 2, 3, or NA return an error message
if(!any(standing %in% c(NA, 1, 2, 3))) {
stop("The 'standing' variable must be a numeric value either 1, 2, or 3!", call.=FALSE)
@@ -168,63 +138,5 @@ ds.getWGSR <- function(sex=NULL, firstPart=NULL, secondPart=NULL, index=NULL, st
cally <- call("getWGSRDS", sex, firstPart, secondPart, index, standing, thirdPart)
DSI::datashield.assign(datasources, newobj, cally)
-
- #############################################################################################################
- # DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED
-
- # SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION
- test.obj.name <- newobj
-
- # CALL SEVERSIDE FUNCTION
- calltext <- call("testObjExistsDS", test.obj.name)
- object.info <- DSI::datashield.aggregate(datasources, calltext)
-
- # CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS
- # AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS
- num.datasources <- length(object.info)
-
- obj.name.exists.in.all.sources <- TRUE
- obj.non.null.in.all.sources <- TRUE
-
- for(j in 1:num.datasources){
- if(!object.info[[j]]$test.obj.exists){
- obj.name.exists.in.all.sources <- FALSE
- }
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){
- obj.non.null.in.all.sources <- FALSE
- }
- }
-
- if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){
- return.message <- paste0("A data object <", test.obj.name, "> has been created in all specified data sources")
- }else{
- return.message.1 <- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources")
- return.message.2 <- paste0("It is either ABSENT and/or has no valid content/class,see return.info above")
- return.message.3 <- paste0("Please use ds.ls() to identify where missing")
- return.message <- list(return.message.1,return.message.2,return.message.3)
- }
-
- calltext <- call("messageDS", test.obj.name)
- studyside.message <- DSI::datashield.aggregate(datasources, calltext)
- no.errors <- TRUE
- for(nd in 1:num.datasources){
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){
- no.errors <- FALSE
- }
- }
-
- if(no.errors){
- validity.check <- paste0("<",test.obj.name, "> appears valid in all sources")
- return(list(is.object.created=return.message,validity.check=validity.check))
- }
-
- if(!no.errors){
- validity.check <- paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:")
- return(list(is.object.created=return.message,validity.check=validity.check,
- studyside.messages=studyside.message))
- }
-
- # END OF CHECK OBJECT CREATED CORECTLY MODULE
- #######################################################################################################
-}
+}
diff --git a/R/ds.glm.R b/R/ds.glm.R
index 8b1dbceb7..24488e226 100644
--- a/R/ds.glm.R
+++ b/R/ds.glm.R
@@ -211,6 +211,7 @@
#' and the natural scale after exponentiation (rates and rate ratios).
#'
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -324,15 +325,7 @@
ds.glm <- function(formula=NULL, data=NULL, family=NULL, offset=NULL, weights=NULL, checks=FALSE, maxit=20, CI=0.95,
viewIter=FALSE, viewVarCov=FALSE, viewCor=FALSE, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# verify that 'formula' was set
if(is.null(formula)){
@@ -356,11 +349,6 @@ ds.glm <- function(formula=NULL, data=NULL, family=NULL, offset=NULL, weights=NU
stop(" Please provide a valid 'family' argument!", call.=FALSE)
}
- # if the argument 'data' is set, check that the data frame is defined (i.e. exists) on the server site
- if(!(is.null(data))){
- defined <- isDefined(datasources, data)
- }
-
# beginning of optional checks - the process stops if any of these checks fails #
if(checks){
message(" -- Verifying the variables in the model")
diff --git a/R/ds.glmPredict.R b/R/ds.glmPredict.R
index 96dfc792c..e881bb541 100644
--- a/R/ds.glmPredict.R
+++ b/R/ds.glmPredict.R
@@ -121,29 +121,19 @@
#' summary statistics for each column in fit and se.fit matrices which each have k columns
#' if k terms are being summarised.
#' @author Paul Burton, for DataSHIELD Development Team 13/08/20
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.glmPredict <- function(glmname = NULL, newdataname = NULL, output.type = "response",
se.fit = FALSE, dispersion = NULL, terms = NULL,
na.action = "na.pass", newobj = NULL, datasources = NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check that is set
if(is.null(glmname)){
stop(" is not set, please specify it as a character string containing the name of a valid glm class object on the serverside", call.=FALSE)
}
-
- # check if the glm object is defined in all the studies
- isDefined(datasources, glmname)
# check that is correctly set
if((output.type!="link") && (output.type!="response") && (output.type!="terms")){
@@ -163,85 +153,6 @@ ds.glmPredict <- function(glmname = NULL, newdataname = NULL, output.type = "res
calltext <- call("glmPredictDS.as", glmname, newdataname, output.type, se.fit, dispersion, terms, na.action)
DSI::datashield.assign(datasources, newobj, calltext)
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(object.info[[j]]$test.obj.class=="ABSENT"){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
-# print(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
-# print(list(is.object.created=return.message,validity.check=validity.check, #
-# studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
calltext<-call("glmPredictDS.ag", glmname, newdataname, output.type,
se.fit, dispersion, terms, na.action)
diff --git a/R/ds.glmSLMA.R b/R/ds.glmSLMA.R
index 3c9d0edb5..ef366e21f 100644
--- a/R/ds.glmSLMA.R
+++ b/R/ds.glmSLMA.R
@@ -261,12 +261,8 @@
#' argument combine.with.metafor is set to TRUE. Otherwise, users can take
#' the \code{betamatrix.valid} and \code{sematrix.valid} matrices and enter
#' them into their meta-analysis package of choice.
-#' @return \code{is.object.created} and \code{validity.check} are standard
-#' items returned by an assign function when the designated newobj appears to have
-#' been successfully created on the serverside at each study. This output is
-#' produced specifically by the assign function \code{glmSLMADS.assign} that writes
-#' out the glm object on the serverside
#' @author Paul Burton, for DataSHIELD Development Team 07/07/20
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -377,16 +373,7 @@
ds.glmSLMA<-function(formula=NULL, family=NULL, offset=NULL, weights=NULL, combine.with.metafor=TRUE,
newobj=NULL,dataName=NULL,checks=FALSE, maxit=30, notify.of.progress=FALSE, datasources=NULL) {
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
-
+ datasources <- .set_datasources(datasources)
# verify that 'formula' was set
if(is.null(formula)){
@@ -454,11 +441,6 @@ ds.glmSLMA<-function(formula=NULL, family=NULL, offset=NULL, weights=NULL, combi
if(paste(strsplit(family,split=" ")[[1]],collapse="")=="gamma(link=log)")
{family<-"Gamma.link.log"}
- # if the argument 'dataName' is set, check that the data frame is defined (i.e. exists) on the server site
- if(!(is.null(dataName))){
- defined <- isDefined(datasources, dataName)
- }
-
# beginning of optional checks - the process stops if any of these checks fails #
if(checks){
message(" -- Verifying the variables in the model")
@@ -842,94 +824,10 @@ return(list(output.summary=output.summary))
}
-#final.outlist<-(list(output.summary=output.summary, num.valid.studies=num.valid.studies,betamatrix.all=betamatrix.all,sematrix.all=sematrix.all, betamatrix.valid=betamatrix.valid,sematrix.valid=sematrix.valid,
-# SLMA.pooled.ests.matrix=SLMA.pooled.ests.matrix))
-
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-datashield.aggregate(datasources, calltext)
- #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if("ABSENT" %in% object.info[[j]]$test.obj.class){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(output.summary=output.summary, num.valid.studies=num.valid.studies, #
- betamatrix.all=betamatrix.all, #
- sematrix.all=sematrix.all, betamatrix.valid=betamatrix.valid,sematrix.valid=sematrix.valid, #
- SLMA.pooled.ests.matrix=SLMA.pooled.ests.matrix, #
- is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORRECTLY MODULE #
-#############################################################################################################
+ return(list(output.summary=output.summary, num.valid.studies=num.valid.studies,
+ betamatrix.all=betamatrix.all,
+ sematrix.all=sematrix.all, betamatrix.valid=betamatrix.valid, sematrix.valid=sematrix.valid,
+ SLMA.pooled.ests.matrix=SLMA.pooled.ests.matrix))
}
diff --git a/R/ds.glmSummary.R b/R/ds.glmSummary.R
index 9fc259c5b..5a80b7fce 100644
--- a/R/ds.glmSummary.R
+++ b/R/ds.glmSummary.R
@@ -74,27 +74,17 @@
#' For further information see help for glm and summary(glm) in native R
#' and for ds.glmSLMA in DataSHIELD.
#' @author Paul Burton, for DataSHIELD Development Team 17/07/20
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.glmSummary <- function(x.name, newobj=NULL, datasources=NULL) {
- # if no connections are specified look for connection objects in the environment
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if a value has been provided for x
if(is.null(x.name)||!is.character(x.name)){
stop("Error: x.name must denote a character string naming the glm object on the serverside to be summarised", call.=FALSE)
}
-
- # check if the input object is defined in all the studies
- isDefined(datasources, x.name)
# create a name by default if the user did not provide a name for the new object
if (is.null(newobj)) {
@@ -109,83 +99,6 @@ ds.glmSummary <- function(x.name, newobj=NULL, datasources=NULL) {
# PREPARE AND CALL THE SECOND ASSIGN FUNCTION TO PREPARE AN ABBREVIATED
# summary_glm OBJECT ON THE SERVERSIDE THAT CAN SAFELY BE RETURNED TO CLIENT
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
-# if(no.errors){ #
-# message("\n\nCREATE ASSIGN OBJECT\n") #
-# #
-# validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
-# print(list(is.object.created=return.message,validity.check=validity.check)) #
-# } #
- #
- if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- message(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
# PREPARE AND CALL THE SECOND SERVERSIDE (AGGREGATE) FUNCTION TO PREPARE AN ABBREVIATED
diff --git a/R/ds.glmerSLMA.R b/R/ds.glmerSLMA.R
index b996707ef..0665b24e5 100644
--- a/R/ds.glmerSLMA.R
+++ b/R/ds.glmerSLMA.R
@@ -241,6 +241,7 @@
#'
#'
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.glmerSLMA <- function(formula=NULL, offset=NULL, weights=NULL, combine.with.metafor=TRUE, dataName=NULL,
@@ -249,15 +250,7 @@ ds.glmerSLMA <- function(formula=NULL, offset=NULL, weights=NULL, combine.with.m
start_theta = NULL, start_fixef = NULL, notify.of.progress=FALSE,
assign=FALSE, newobj=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# verify that 'formula' was set
if(is.null(formula)){
@@ -282,11 +275,6 @@ ds.glmerSLMA <- function(formula=NULL, offset=NULL, weights=NULL, combine.with.m
stop(" Please provide a valid 'family' argument!", call.=FALSE)
}
- # if the argument 'dataName' is set, check that the data frame is defined (i.e. exists) on the server site
- if(!(is.null(dataName))){
- defined <- isDefined(datasources, dataName)
- }
-
# beginning of optional checks - the process stops if any of these checks fails #
if(checks){
message(" -- Verifying the variables in the model")
diff --git a/R/ds.heatmapPlot.R b/R/ds.heatmapPlot.R
index 024224aa5..483124607 100644
--- a/R/ds.heatmapPlot.R
+++ b/R/ds.heatmapPlot.R
@@ -85,9 +85,11 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
+#' @template classConsistencyCheckFalse
#' @return \code{ds.heatmapPlot} returns to the client-side a heat map plot and a message specifying
#' the number of invalid cells in each study.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -149,17 +151,9 @@
#' }
#'
ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=20,
- method="smallCellsRule", k=3, noise=0.25, datasources=NULL){
+ method="smallCellsRule", k=3, noise=0.25, datasources=NULL, classConsistencyCheck=FALSE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("x=NULL. Please provide the names of the 1st numeric vector!", call.=FALSE)
@@ -172,24 +166,6 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2
# Save par and setup reseting of par values
old_par <- graphics::par(no.readonly = TRUE)
on.exit(graphics::par(old_par), add = TRUE)
-
- # check if the input objects are defined in all the studies
- isDefined(datasources, x)
- isDefined(datasources, y)
-
- # call the internal function that checks the input object(s) is(are) of the same class in all studies.
- typ.x <- checkClass(datasources, x)
- typ.y <- checkClass(datasources, y)
-
- # the input objects must be numeric or integer vectors
- if(!('integer' %in% typ.x) & !('numeric' %in% typ.x)){
- message(paste0(x, " is of type ", typ.x, "!"))
- stop("The input objects must be integer or numeric vectors.", call.=FALSE)
- }
- if(!('integer' %in% typ.y) & !('numeric' %in% typ.y)){
- message(paste0(y, " is of type ", typ.y, "!"))
- stop("The input objects must be integer or numeric vectors.", call.=FALSE)
- }
# the argument method must be either "smallCellsRule" or "deterministic" or "probabilistic"
if(method != 'smallCellsRule' & method != 'deterministic' & method != 'probabilistic'){
@@ -215,8 +191,11 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2
method.indicator <- 1
# call the server-side function that generates the x and y coordinates of the centroids
- cally <- paste0("heatmapPlotDS(", x, ",", y, ",", k, ",", noise, ",", method.indicator, ")")
- anonymous.data <- DSI::datashield.aggregate(datasources, cally)
+ anonymous.data <- datashield.aggregate(datasources, call("heatmapPlotDS", x.name=x, y.name=y, k=k, noise=noise, method.indicator=method.indicator))
+ if(classConsistencyCheck){
+ .checkClassConsistency(anonymous.data, field = "class.x", object_name = x)
+ .checkClassConsistency(anonymous.data, field = "class.y", object_name = y)
+ }
pooled.points.x <- c()
pooled.points.y <- c()
@@ -231,8 +210,11 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2
method.indicator <- 2
# call the server-side function that generates the x and y coordinates of the anonymous.data
- cally <- paste0("heatmapPlotDS(", x, ",", y, ",", k, ",", noise, ",", method.indicator, ")")
- anonymous.data <- DSI::datashield.aggregate(datasources, cally)
+ anonymous.data <- datashield.aggregate(datasources, call("heatmapPlotDS", x.name=x, y.name=y, k=k, noise=noise, method.indicator=method.indicator))
+ if(classConsistencyCheck){
+ .checkClassConsistency(anonymous.data, field = "class.x", object_name = x)
+ .checkClassConsistency(anonymous.data, field = "class.y", object_name = y)
+ }
pooled.points.x <- c()
pooled.points.y <- c()
@@ -247,11 +229,9 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2
if (method=="smallCellsRule"){
# get the range from each study and produce the 'global' range
- cally <- paste("rangeDS(", x, ")")
- x.ranges <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ x.ranges <- datashield.aggregate(datasources, call("rangeDS", x))
- cally <- paste("rangeDS(", y, ")")
- y.ranges <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ y.ranges <- datashield.aggregate(datasources, call("rangeDS", y))
x.minrs <- c()
x.maxrs <- c()
@@ -272,9 +252,12 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2
y.global.max <- y.range.arg[2]
# generate the grid density object to plot
- cally <- paste0("densityGridDS(",x,",",y,",",limits=T,",",x.global.min,",",
- x.global.max,",",y.global.min,",",y.global.max,",",numints,")")
- grid.density.obj <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ grid.density.obj <- datashield.aggregate(datasources, call("densityGridDS", x=x, y=y, limits=TRUE, x.min=x.global.min, x.max=x.global.max, y.min=y.global.min, y.max=y.global.max, numints=numints))
+ if(classConsistencyCheck){
+ .checkClassConsistency(grid.density.obj, field = "class.x", object_name = x)
+ .checkClassConsistency(grid.density.obj, field = "class.y", object_name = y)
+ }
+ grid.density.obj <- lapply(grid.density.obj, function(r) r$grid)
numcol <- dim(grid.density.obj[[1]])[2]
@@ -428,10 +411,12 @@ ds.heatmapPlot <- function(x=NULL, y=NULL, type="combine", show="all", numints=2
if (method=="smallCellsRule"){
# generate the grid density object to plot
- num_intervals <- numints
- cally <- paste0("densityGridDS(",x, ",", y, ",", 'limits=FALSE', ",", 'x.min=NULL', ",",
- 'x.max=NULL', ",", 'y.min=NULL', ",", 'y.max=NULL', ",", numints=num_intervals, ")")
- grid.density.obj <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ grid.density.obj <- datashield.aggregate(datasources, call("densityGridDS", x=x, y=y, limits=FALSE, x.min=NULL, x.max=NULL, y.min=NULL, y.max=NULL, numints=numints))
+ if(classConsistencyCheck){
+ .checkClassConsistency(grid.density.obj, field = "class.x", object_name = x)
+ .checkClassConsistency(grid.density.obj, field = "class.y", object_name = y)
+ }
+ grid.density.obj <- lapply(grid.density.obj, function(r) r$grid)
numcol <- dim(grid.density.obj[[1]])[2]
}
diff --git a/R/ds.hetcor.R b/R/ds.hetcor.R
index 2b29be240..0a47676a3 100644
--- a/R/ds.hetcor.R
+++ b/R/ds.hetcor.R
@@ -27,27 +27,17 @@
#' the method by which any missing data were handled: "complete.obs" or "pairwise.complete.obs"; TRUE
#' for ML estimates, FALSE for two-step estimates.
#' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.hetcor <- function(data=NULL, ML=TRUE, std.err=TRUE, bins=4, pd=TRUE, use="complete.obs", datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(data)){
stop("Please provide the name of the input object!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- defined <- isDefined(datasources, data)
-
calltext <- call('hetcorDS', data, ML, std.err, bins, pd, use)
output <- DSI::datashield.aggregate(datasources, calltext)
diff --git a/R/ds.histogram.R b/R/ds.histogram.R
index 0fbe2e209..f9b375dda 100644
--- a/R/ds.histogram.R
+++ b/R/ds.histogram.R
@@ -82,8 +82,10 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
+#' @template classConsistencyCheckFalse
#' @return one or more histogram objects and plots depending on the argument \code{type}
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -151,17 +153,9 @@
#' }
#'
#'
-ds.histogram <- function(x=NULL, type="split", num.breaks=10, method="smallCellsRule", k=3, noise=0.25, vertical.axis="Frequency", datasources=NULL){
+ds.histogram <- function(x=NULL, type="split", num.breaks=10, method="smallCellsRule", k=3, noise=0.25, vertical.axis="Frequency", datasources=NULL, classConsistencyCheck=FALSE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input vector!", call.=FALSE)
@@ -171,18 +165,6 @@ ds.histogram <- function(x=NULL, type="split", num.breaks=10, method="smallCells
old_par <- graphics::par(no.readonly = TRUE)
on.exit(graphics::par(old_par), add = TRUE)
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
-
- # the input object must be a numeric or an integer vector
- if(!('integer' %in% typ) & !('numeric' %in% typ)){
- message(paste0(x, " is of type ", typ, "!"))
- stop("The input object must be an integer or numeric vector.", call.=FALSE)
- }
-
# the argument vertical.axis must be "Frequency" or "Density"
if(vertical.axis != 'Frequency' & vertical.axis != 'Density'){
stop('Function argument "vertical.axis" has to be either "Frequency" or "Density"', call.=FALSE)
@@ -204,8 +186,11 @@ ds.histogram <- function(x=NULL, type="split", num.breaks=10, method="smallCells
if(method=='probabilistic'){ method.indicator <- 3 }
# call the server-side function that returns the range of the vector from each study
- cally1 <- paste0("histogramDS1(", x, ",", method.indicator, ",", k, ",", noise, ")")
- ranges <- unique(unlist(DSI::datashield.aggregate(datasources, as.symbol(cally1))))
+ histogram.ranges <- datashield.aggregate(datasources, call("histogramDS1", x=x, method.indicator=method.indicator, k=k, noise=noise))
+ if(classConsistencyCheck){
+ .checkClassConsistency(histogram.ranges, object_name = x)
+ }
+ ranges <- unique(unlist(lapply(histogram.ranges, function(r) r$range)))
# produce the 'global' range
range.arg <- c(min(ranges, na.rm=TRUE), max(ranges, na.rm=TRUE))
@@ -217,8 +202,7 @@ ds.histogram <- function(x=NULL, type="split", num.breaks=10, method="smallCells
varname <- xnames$elements
# call the server-side function that generates the histogram object to plot
- call <- paste0("histogramDS2(", x, ",", num.breaks, ",", min, ",", max, ",", method.indicator, ",", k, ",", noise, ")")
- outputs <- DSI::datashield.aggregate(datasources, call)
+ outputs <- datashield.aggregate(datasources, call("histogramDS2", x=x, num.breaks=num.breaks, min=min, max=max, method.indicator=method.indicator, k=k, noise=noise))
hist.objs <- vector("list", length(datasources))
invalidcells <- vector("list", length(datasources))
diff --git a/R/ds.isNA.R b/R/ds.isNA.R
index 1d84577f7..80ffcc08a 100644
--- a/R/ds.isNA.R
+++ b/R/ds.isNA.R
@@ -5,98 +5,81 @@
#' @details In certain analyses such as GLM none of the variables should be missing at complete
#' (i.e. missing value for each observation). Since in DataSHIELD it is not possible to see the data
#' it is important to know whether or not a vector is empty to proceed accordingly.
-#'
+#'
#' Server function called: \code{isNaDS}
#' @param x a character string specifying the name of the vector to check.
-#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
+#' @template classConsistencyCheckTrue
+#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.isNA} returns a boolean. If it is TRUE the vector is empty
+#' @return \code{ds.isNA} returns a boolean. If it is TRUE the vector is empty
#' (all values are NA), FALSE otherwise.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
#'
#' ## Version 6, for version 5 see the Wiki
-#'
+#'
#' # connecting to the Opal servers
-#'
+#'
#' require('DSI')
#' require('DSOpal')
#' require('dsBaseClient')
#'
#' builder <- DSI::newDSLoginBuilder()
-#' builder$append(server = "study1",
-#' url = "http://192.168.56.100:8080/",
-#' user = "administrator", password = "datashield_test&",
+#' builder$append(server = "study1",
+#' url = "http://192.168.56.100:8080/",
+#' user = "administrator", password = "datashield_test&",
#' table = "CNSIM.CNSIM1", driver = "OpalDriver")
-#' builder$append(server = "study2",
-#' url = "http://192.168.56.100:8080/",
-#' user = "administrator", password = "datashield_test&",
+#' builder$append(server = "study2",
+#' url = "http://192.168.56.100:8080/",
+#' user = "administrator", password = "datashield_test&",
#' table = "CNSIM.CNSIM2", driver = "OpalDriver")
#' builder$append(server = "study3",
-#' url = "http://192.168.56.100:8080/",
-#' user = "administrator", password = "datashield_test&",
+#' url = "http://192.168.56.100:8080/",
+#' user = "administrator", password = "datashield_test&",
#' table = "CNSIM.CNSIM3", driver = "OpalDriver")
#' logindata <- builder$build()
-#'
-#' connections <- DSI::datashield.login(logins = logindata, assign = TRUE, symbol = "D")
-#'
+#'
+#' connections <- DSI::datashield.login(logins = logindata, assign = TRUE, symbol = "D")
+#'
#' # check if all the observation of the variable 'LAB_HDL' are missing (NA)
#' ds.isNA(x = 'D$LAB_HDL',
#' datasources = connections) #all servers are used
#' ds.isNA(x = 'D$LAB_HDL',
-#' datasources = connections[1]) #only the first server is used (study1)
-#'
+#' datasources = connections[1]) #only the first server is used (study1)
+#'
#'
#' # clear the Datashield R sessions and logout
#' datashield.logout(connections)
#'
#' }
-#'
-ds.isNA <- function(x=NULL, datasources=NULL){
-
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
+#'
+ds.isNA <- function(x=NULL, datasources=NULL, classConsistencyCheck=TRUE){
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input vector!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
-
- # the input object must be a vector
- if(!('character' %in% typ) & !('factor' %in% typ) & !('integer' %in% typ) & !('logical' %in% typ) & !('numeric' %in% typ) & !('data.frame' %in% typ) & !('matrix' %in% typ)){
- stop("The input object must be a character, factor, integer, logical or numeric vector.", call.=FALSE)
- }
-
- # name of the studies to be used in the plots' titles
stdnames <- names(datasources)
-
- # name of the variable
xnames <- extract(x)
varname <- xnames$elements
- # keep of the results of the checks for each study
- track <- list()
+ cally <- call("isNaDS", x)
+ results <- DSI::datashield.aggregate(datasources, cally)
+
+ if(classConsistencyCheck){
+ .checkClassConsistency(results)
+ }
- # call server side function 'isNaDS' to check, in each study, if the vector is empty
- for(i in 1: length(datasources)){
- cally <- call("isNaDS", x)
- out <- DSI::datashield.aggregate(datasources[i], cally)
- if(out[[1]]){
+ # report per-study if all NA
+ track <- list()
+ for(i in 1:length(results)){
+ if(results[[i]]$is.na){
track[[i]] <- TRUE
message("The variable ", varname, " in ", stdnames[i], " is missing at complete (all values are 'NA').")
}else{
diff --git a/R/ds.isValid.R b/R/ds.isValid.R
index e43b61b1f..266dbca2d 100644
--- a/R/ds.isValid.R
+++ b/R/ds.isValid.R
@@ -13,8 +13,10 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
+#' @template classConsistencyCheckTrue
#' @return \code{ds.isValid} returns a boolean. If it is TRUE input object is valid, FALSE otherwise.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -55,36 +57,21 @@
#'
#' }
#'
-ds.isValid <- function(x=NULL, datasources=NULL){
+ds.isValid <- function(x=NULL, datasources=NULL, classConsistencyCheck=TRUE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input vector!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
+ # call the server side function that does the job and return its output
+ cally <- call("isValidDS", x)
+ results <- DSI::datashield.aggregate(datasources, cally)
- # the input object must be a vector
- if(!('character' %in% typ) & !('factor' %in% typ) & !('integer' %in% typ) & !('logical' %in% typ) & !('numeric' %in% typ) & !('data.frame' %in% typ) & !('matrix' %in% typ)){
- stop("The input object must be a character, factor, integer, logical or numeric vector or a dataframe or a matrix", call.=FALSE)
+ if(classConsistencyCheck){
+ .checkClassConsistency(results)
}
- # call the server side function that does the job and return its output
- cally <- paste0('isValidDS(', x, ')')
- output <- DSI::datashield.aggregate(datasources, as.symbol(cally))
-
- return(output)
+ return(lapply(results, function(r) r$valid))
}
diff --git a/R/ds.kurtosis.R b/R/ds.kurtosis.R
index 974682bba..775f14d81 100644
--- a/R/ds.kurtosis.R
+++ b/R/ds.kurtosis.R
@@ -17,25 +17,19 @@
#' if \code{type} is set to 'split', 'splits' or 's', the kurtosis is returned separately for each study.
#' if \code{type} is set to 'both' or 'b', both sets of outputs are produced.
#' The default value is set to 'both'.
+#' @template classConsistencyCheckFalse
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return a matrix showing the kurtosis of the input numeric variable, the number of valid observations and
-#' the validity message.
+#' @return a matrix showing the kurtosis of the input numeric variable and
+#' the number of valid observations.
#' @author Demetris Avraam, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
-ds.kurtosis <- function(x=NULL, method=1, type='both', datasources=NULL){
-
- # if no opal login details are provided look for 'opal' objects in the environment
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
+ds.kurtosis <- function(x=NULL, method=1, type='both', datasources=NULL, classConsistencyCheck=FALSE){
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input vector!", call.=FALSE)
@@ -53,26 +47,17 @@ ds.kurtosis <- function(x=NULL, method=1, type='both', datasources=NULL){
stop('Function argument "type" has to be either "both", "combine" or "split"', call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
-
- # the input object must be a numeric or an integer vector
- if(typ != 'integer' & typ != 'numeric'){
- message(paste0(x, " is of type ", typ, "!"))
- stop("The input object must be an integer or numeric vector.", call.=FALSE)
- }
-
if (type=='split' | type=='both'){
calltext.split <- call("kurtosisDS1", x, method)
output.split <- DSI::datashield.aggregate(datasources, calltext.split)
- mat.split <- matrix(as.numeric(matrix(unlist(output.split), nrow=length(datasources), byrow=TRUE)[,1:2]),nrow=length(datasources))
- validity <- matrix(unlist(output.split), nrow=length(datasources), byrow=TRUE)[,3]
- mat.split <- data.frame(cbind(mat.split, validity))
+ if(classConsistencyCheck){
+ .checkClassConsistency(output.split)
+ }
+ mat.split <- data.frame(
+ Kurtosis = sapply(output.split, function(r) r$Kurtosis),
+ Nvalid = sapply(output.split, function(r) r$Nvalid)
+ )
rownames(mat.split) <- names(output.split)
- colnames(mat.split) <- c('Kurtosis', 'Nvalid', 'ValidityMessage')
}
if (type=='combine' | type=='both'){
@@ -84,6 +69,9 @@ ds.kurtosis <- function(x=NULL, method=1, type='both', datasources=NULL){
}else{
calltext.combined <- call("kurtosisDS2", x, global.mean)
output.combined <- DSI::datashield.aggregate(datasources, calltext.combined)
+ if(classConsistencyCheck){
+ .checkClassConsistency(output.combined)
+ }
Global.sum.quartics <- 0
Global.sum.squares <- 0
@@ -98,19 +86,15 @@ ds.kurtosis <- function(x=NULL, method=1, type='both', datasources=NULL){
if(method==1){
Global.kurtosis <- g2.global
- combinedMessage <- "VALID ANALYSIS"
}
if(method==2){
Global.kurtosis <- ((Global.Nvalid + 1) * g2.global + 6) * (Global.Nvalid - 1)/((Global.Nvalid - 2) * (Global.Nvalid - 3))
- combinedMessage <- "VALID ANALYSIS"
}
if(method==3){
Global.kurtosis <- (g2.global + 3) * (1 - 1/Global.Nvalid)^2 - 3
- combinedMessage <- "VALID ANALYSIS"
}
- mat.combined <- data.frame(cbind(Global.kurtosis, Global.Nvalid, combinedMessage))
+ mat.combined <- data.frame(Kurtosis = Global.kurtosis, Nvalid = Global.Nvalid)
rownames(mat.combined) <- 'studiesCombined'
- colnames(mat.combined) <- c('Kurtosis', 'Nvalid', 'ValidityMessage')
}
}
diff --git a/R/ds.length.R b/R/ds.length.R
index 83cb5cae6..d2acd0e79 100644
--- a/R/ds.length.R
+++ b/R/ds.length.R
@@ -14,15 +14,14 @@
#' if \code{type} is set to \code{'both'} or \code{'b'},
#' both sets of outputs are produced.
#' Default \code{'both'}.
-#' @param checks logical. If TRUE the model components are checked.
-#' Default FALSE to save time. It is suggested that checks
-#' should only be undertaken once the function call has failed.
+#' @template classConsistencyCheckTrue
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.length} returns to the client-side the pooled length of a vector or a list,
#' or the length of a vector or a list for each study separately.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -74,50 +73,33 @@
#' datashield.logout(connections)
#' }
#'
-ds.length <- function(x=NULL, type='both', checks='FALSE', datasources=NULL){
+ds.length <- function(x=NULL, type='both', datasources=NULL, classConsistencyCheck=TRUE){
+
+ datasources <- .set_datasources(datasources)
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
-
if(is.null(x)){
stop("Please provide the name of the input object!", call.=FALSE)
- }
-
- # beginning of optional checks - the process stops and reports as soon as one check fails
- if(checks){
-
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is suitable in all studies
- typ <- checkClass(datasources, x)
-
- # the input object must be a vector or a list
- if(!('character' %in% typ) & !('factor' %in% typ) & !('integer' %in% typ) & !('logical' %in% typ) & !('numeric' %in% typ) & !('list' %in% typ)){
- stop("The input object must be a character, factor, integer, logical or numeric vector or a list.", call.=FALSE)
- }
-
- }
+ }
###################################################################################################
- # MODULE: EXTEND "type" argument to include "both" and enable valid alisases #
+ # MODULE: EXTEND "type" argument to include "both" and enable valid aliases #
if(type == 'combine' | type == 'combined' | type == 'combines' | type == 'c') type <- 'combine' #
if(type == 'split' | type == 'splits' | type == 's') type <- 'split' #
if(type == 'both' | type == 'b' ) type <- 'both' #
if(type != 'combine' & type != 'split' & type != 'both'){ #
stop('Function argument "type" has to be either "both", "combine" or "split"', call.=FALSE) #
}
-
+
# call the server-side function
cally <- call("lengthDS", x)
- lengths <- DSI::datashield.aggregate(datasources, cally)
+ results <- DSI::datashield.aggregate(datasources, cally)
+
+ if(classConsistencyCheck){
+ .checkClassConsistency(results)
+ }
+
+ # extract lengths from results
+ lengths <- lapply(results, function(r) r$length)
# names of the studies to be used in the output
stdnames <- names(datasources)
diff --git a/R/ds.levels.R b/R/ds.levels.R
index b32a5d1c6..5dc650b40 100644
--- a/R/ds.levels.R
+++ b/R/ds.levels.R
@@ -12,6 +12,7 @@
#' @return \code{ds.levels} returns to the client-side the levels of a factor
#' class variable stored in the server-side.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -58,35 +59,16 @@
#'
ds.levels <- function(x=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input vector!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
-
- # the input object must be a factor
- if(!('factor' %in% typ)){
- stop("The input object must be a factor.", call.=FALSE)
- }
-
- # call the server-side function
- cally <- paste0("levelsDS(", x, ")")
- output <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ cally <- call("levelsDS", x)
+ results <- DSI::datashield.aggregate(datasources, cally)
+ output <- lapply(results, function(r) list(Levels = r$Levels))
return(output)
-
+
}
diff --git a/R/ds.lexis.R b/R/ds.lexis.R
index 665a29ed4..abc019a73 100644
--- a/R/ds.lexis.R
+++ b/R/ds.lexis.R
@@ -134,6 +134,7 @@
#' the expanded version of the input table.
#'
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @seealso \code{\link{ds.glm}} for generalized linear models.
#' @export
#' @examples
@@ -202,15 +203,7 @@
#'
ds.lexis<-function(data=NULL, intervalWidth=NULL, idCol=NULL, entryCol=NULL, exitCol=NULL, statusCol=NULL, variables=NULL, expandDF=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if user have provided the name of the column that holds the subject ids
if(is.null(idCol)){
diff --git a/R/ds.list.R b/R/ds.list.R
index b08477031..ebbf57492 100644
--- a/R/ds.list.R
+++ b/R/ds.list.R
@@ -8,11 +8,14 @@
#' @param x a character string specifying the names of the objects to coerce into a list.
#' @param newobj a character string that provides the name for the output variable
#' that is stored on the data servers. Default \code{list.newobj}.
+#' @param classConsistencyCheck logical. If TRUE, verifies that each input object has
+#' the same class across all studies before coercion. Default TRUE.
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.list} returns a list of objects for each study that is stored on the server-side.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -51,49 +54,31 @@
#' datashield.logout(connections)
#' }
#'
-ds.list <- function(x=NULL, newobj=NULL, datasources=NULL){
+ds.list <- function(x=NULL, newobj=NULL, datasources=NULL, classConsistencyCheck=TRUE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("x=NULL. Please provide the names of the objects to coerce into a list!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object(s) is(are) of the same class in all studies.
- for(i in 1:length(x)){
- typ <- checkClass(datasources, x[i])
- }
-
# create a name by default if user did not provide a name for the new variable
if(is.null(newobj)){
newobj <- "list.newobj"
}
-
+
# get the variable names
xnames <- extract(x)
varnames <- xnames$elements
- # get the names of the list elements if the user has not specified any
- if(is.null(names)){
- names <- varnames
+ if(classConsistencyCheck){
+ for(i in seq_along(x)){
+ checkClass(datasources, x[i])
+ }
}
# call the server side function that does the job
- cally <- paste0("listDS(list(",paste(x,collapse=","),"), list('",paste(varnames,collapse="','"),"'))")
- DSI::datashield.assign(datasources, newobj, as.symbol(cally))
-
- # check that the new object has been created and display a message accordingly
- finalcheck <- isAssigned(datasources, newobj)
+ cally <- call("listDS", x, as.list(varnames))
+ DSI::datashield.assign(datasources, newobj, cally)
}
diff --git a/R/ds.lmerSLMA.R b/R/ds.lmerSLMA.R
index 8b7c69b2c..23192f7a8 100644
--- a/R/ds.lmerSLMA.R
+++ b/R/ds.lmerSLMA.R
@@ -159,6 +159,7 @@
#' @return \code{convergence.error.message}: reports for each study whether the model converged.
#' If it did not some information about the reason for this is reported.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -205,15 +206,7 @@ ds.lmerSLMA <- function(formula=NULL, offset=NULL, weights=NULL, combine.with.me
control_value = NULL, optimizer = NULL, verbose = 0, notify.of.progress=FALSE,
assign=FALSE, newobj=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# verify that 'formula' was set
if(is.null(formula)){
@@ -236,11 +229,6 @@ ds.lmerSLMA <- function(formula=NULL, offset=NULL, weights=NULL, combine.with.me
# set family to gaussian
family <- 'gaussian'
- # if the argument 'dataName' is set, check that the data frame is defined (i.e. exists) on the server site
- if(!(is.null(dataName))){
- defined <- isDefined(datasources, dataName)
- }
-
# beginning of optional checks - the process stops if any of these checks fails #
if(checks){
message(" -- Verifying the variables in the model")
diff --git a/R/ds.log.R b/R/ds.log.R
index 8c0b2e5d2..cfa2155f2 100644
--- a/R/ds.log.R
+++ b/R/ds.log.R
@@ -2,7 +2,7 @@
#' @title Computes logarithms in the server-side
#' @description Computes the logarithms for a specified numeric vector.
#' This function is similar to the R \code{log} function. by default natural logarithms.
-#' @details Server function called: \code{log}
+#' @details Server function called: \code{logDS}
#' @param x a character string providing the name of a numerical vector.
#' @param base a positive number, the base for which logarithms are computed.
#' Default \code{exp(1)}.
@@ -14,6 +14,7 @@
#' @return \code{ds.log} returns a vector for each study of the transformed values for the numeric vector
#' specified in the argument \code{x}. The created vectors are stored in the server-side.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -57,42 +58,17 @@
#'
ds.log <- function(x=NULL, base=exp(1), newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input vector!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
-
- # the input object must be a vector
- if(!('integer' %in% typ) & !('numeric' %in% typ)){
- message(paste0(x, " is of type ", typ, "!"))
- stop("The input object must be an integer or numeric vector.", call.=FALSE)
- }
-
- # create a name by default if user did not provide a name for the new variable
if(is.null(newobj)){
newobj <- "log.newobj"
}
- # call the server side function that does the job
- cally <- paste0("log(", x, ",", base, ")")
- DSI::datashield.assign(datasources, newobj, as.symbol(cally))
-
- # check that the new object has been created and display a message accordingly
- finalcheck <- isAssigned(datasources, newobj)
+ cally <- call("logDS", x, base)
+ DSI::datashield.assign(datasources, newobj, cally)
}
diff --git a/R/ds.ls.R b/R/ds.ls.R
index 2f65a3c8f..ce96c9015 100644
--- a/R/ds.ls.R
+++ b/R/ds.ls.R
@@ -61,6 +61,7 @@
#' specified R server-side environment;\cr
#' (3) the nature of the search filter string as it was applied.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -117,15 +118,8 @@
#'
#' @export
ds.ls <- function(search.filter=NULL, env.to.search=1L, search.GlobalEnv=TRUE, datasources=NULL){
-
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# make default to .GlobalEnv unambiguous
if(search.GlobalEnv||is.null(env.to.search)){
@@ -191,7 +185,7 @@ if(!is.null(transmit.object))
# call the server side function
calltext <- call("lsDS", search.filter=transmit.object.final, env.to.search)
- output <- datashield.aggregate(datasources, calltext)
+ output <- DSI::datashield.aggregate(datasources, calltext)
return(output)
diff --git a/R/ds.lspline.R b/R/ds.lspline.R
index e044005cb..2fe8471ba 100644
--- a/R/ds.lspline.R
+++ b/R/ds.lspline.R
@@ -20,27 +20,17 @@
#' @return an object of class "lspline" and "matrix", which its name is specified by the
#' \code{newobj} argument (or its default name "lspline.newobj"), is assigned on the serverside.
#' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.lspline <- function(x, knots = NULL, marginal = FALSE, names = NULL, newobj = NULL, datasources = NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input variable x!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- defined <- isDefined(datasources, x)
-
if(is.null(knots)){
stop("Please provide a vector of knots!", call.=FALSE)
}
diff --git a/R/ds.make.R b/R/ds.make.R
index 07d14a830..044c727a6 100644
--- a/R/ds.make.R
+++ b/R/ds.make.R
@@ -67,10 +67,10 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.make} returns the new object which is written to the
-#' server-side. Also a validity message is returned to the client-side indicating whether the new object has been correctly
-#' created at each source.
+#' @return \code{ds.make} writes the new object to the server-side; nothing is
+#' returned to the client-side.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -134,15 +134,7 @@
#'
ds.make<-function(toAssign=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(toAssign)){
stop("Please give the name of object to assign or an expression to evaluate and assign.!\n", call.=FALSE)
@@ -156,86 +148,6 @@ ds.make<-function(toAssign=NULL, newobj=NULL, datasources=NULL){
# now do the business
DSI::datashield.assign(datasources, newobj, as.symbol(toAssign))
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
# ds.make
diff --git a/R/ds.matrix.R b/R/ds.matrix.R
index 69ad3a728..5a0ed3150 100644
--- a/R/ds.matrix.R
+++ b/R/ds.matrix.R
@@ -48,11 +48,9 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.matrix} returns the created matrix which is written on the server-side.
-#' In addition, two validity messages are returned
-#' indicating whether the new matrix has been created in each data source and if so whether
-#' it is in a valid form.
+#' @return \code{ds.matrix} returns the created matrix which is written on the server-side.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -147,15 +145,7 @@
ds.matrix <- function(mdata = NA, from="clientside.scalar", nrows.scalar=NULL, ncols.scalar=NULL, byrow = FALSE,
dimnames = NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if a value has been provided for mdata
if(is.null(mdata)){
@@ -208,85 +198,5 @@ ds.matrix <- function(mdata = NA, from="clientside.scalar", nrows.scalar=NULL, n
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.matrix
diff --git a/R/ds.matrixDet.R b/R/ds.matrixDet.R
index 5fcd81a53..2f4d49606 100644
--- a/R/ds.matrixDet.R
+++ b/R/ds.matrixDet.R
@@ -16,12 +16,10 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.matrixDet} returns the determinant of an existing matrix on the server-side.
-#' The created new object is stored on the server-side.
-#' Also, two validity messages are returned
-#' indicating whether the matrix has been created in each data source and if so whether
-#' it is in a valid form.
+#' @return \code{ds.matrixDet} returns the determinant of an existing matrix on the server-side.
+#' The created new object is stored on the server-side.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -83,23 +81,12 @@
#'
ds.matrixDet<-function(M1=NULL, newobj=NULL, logarithm=FALSE, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if user has provided the name of matrix representing M1
if(is.null(M1)){
return("Error: Please provide the name of the matrix representing M1")
}
-
- # check if the input object is defined in all the studies
- isDefined(datasources, M1)
# if no value or invalid value specified for logarithm, then specify a default
if(is.null(logarithm)){
@@ -119,85 +106,5 @@ ds.matrixDet<-function(M1=NULL, newobj=NULL, logarithm=FALSE, datasources=NULL){
calltext <- call("matrixDetDS2", M1, logarithm)
DSI::datashield.assign(datasources, newobj, calltext)
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORRECTLY MODULE #
-#############################################################################################################
-
}
#ds.matrixDet
diff --git a/R/ds.matrixDet.report.R b/R/ds.matrixDet.report.R
index be21aaa72..4d914d5c3 100644
--- a/R/ds.matrixDet.report.R
+++ b/R/ds.matrixDet.report.R
@@ -18,6 +18,7 @@
#' @return \code{ds.matrixDet.report} returns to the client-side
#' the determinant of a matrix that is stored on the server-side.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -76,15 +77,7 @@
#'
ds.matrixDet.report<-function(M1=NULL, logarithm=FALSE, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if user has provided the name of matrix representing M1
if(is.null(M1)){
diff --git a/R/ds.matrixDiag.R b/R/ds.matrixDiag.R
index 1ea1341a4..7b78d9bac 100644
--- a/R/ds.matrixDiag.R
+++ b/R/ds.matrixDiag.R
@@ -56,11 +56,9 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.matrixDiag} returns to the server-side the square matrix diagonal.
-#' Also, two validity messages are returned
-#' indicating whether the new object has been created in each data source and if so whether
-#' it is in a valid form.
+#' @return \code{ds.matrixDiag} returns to the server-side the square matrix diagonal.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -177,15 +175,7 @@
#'
ds.matrixDiag<-function(x1=NULL, aim=NULL, nrows.scalar=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if a value has been provided for x1
if(is.null(x1)){
@@ -235,85 +225,5 @@ ds.matrixDiag<-function(x1=NULL, aim=NULL, nrows.scalar=NULL, newobj=NULL, datas
DSI::datashield.assign(datasources, newobj, calltext)
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.matrixDiag
diff --git a/R/ds.matrixDimnames.R b/R/ds.matrixDimnames.R
index 6f4a37ead..be7cb1694 100644
--- a/R/ds.matrixDimnames.R
+++ b/R/ds.matrixDimnames.R
@@ -15,11 +15,9 @@
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.matrixDimnames} returns to the server-side
-#' the matrix with specified row and column names.
-#' Also, two validity messages are returned to the client-side
-#' indicating the new object that has been created in each data source and if so whether
-#' it is in a valid form.
+#' the matrix with specified row and column names.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -84,15 +82,8 @@
#' @export
ds.matrixDimnames<-function(M1=NULL, dimnames=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if user has provided the name of matrix representing M1
if(is.null(M1)){
@@ -110,85 +101,5 @@ ds.matrixDimnames<-function(M1=NULL, dimnames=NULL, newobj=NULL, datasources=NUL
calltext <- call("matrixDimnamesDS", M1, dimnames)
DSI::datashield.assign(datasources, newobj, calltext)
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.matrixDimnames
diff --git a/R/ds.matrixInvert.R b/R/ds.matrixInvert.R
index 8cc3c447a..d92591c41 100644
--- a/R/ds.matrixInvert.R
+++ b/R/ds.matrixInvert.R
@@ -12,11 +12,9 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.matrixInvert} returns to the server-side the inverts square matrix.
-#' Also, two validity messages are returned to the client-side
-#' indicating whether the new object has been created in each data source and if so whether
-#' it is in a valid form.
+#' @return \code{ds.matrixInvert} returns to the server-side the inverts square matrix.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -81,15 +79,7 @@
#'
ds.matrixInvert<-function(M1=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if user has provided the name of matrix representing M1
if(is.null(M1)){
@@ -105,85 +95,5 @@ ds.matrixInvert<-function(M1=NULL, newobj=NULL, datasources=NULL){
calltext <- call("matrixInvertDS", M1)
DSI::datashield.assign(datasources, newobj, calltext)
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.matrixInvert
diff --git a/R/ds.matrixMult.R b/R/ds.matrixMult.R
index cf5349fe0..35e9d7111 100644
--- a/R/ds.matrixMult.R
+++ b/R/ds.matrixMult.R
@@ -15,12 +15,10 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.matrixMult} returns to the server-side
+#' @return \code{ds.matrixMult} returns to the server-side
#' the result of the two matrix multiplication.
-#' Also, two validity messages are returned to the client-side
-#' indicating whether the new object has been created in each data source and if so whether
-#' it is in a valid form.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#'
#' @examples
#' \dontrun{
@@ -96,15 +94,7 @@
#'
ds.matrixMult<-function(M1=NULL, M2=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if user has provided the name of matrix representing M1
if(is.null(M1)){
@@ -129,85 +119,5 @@ ds.matrixMult<-function(M1=NULL, M2=NULL, newobj=NULL, datasources=NULL){
calltext <- call("matrixMultDS", M1, M2)
DSI::datashield.assign(datasources, newobj, calltext)
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.matrixMult
diff --git a/R/ds.matrixTranspose.R b/R/ds.matrixTranspose.R
index bbd73a1a8..4de06471a 100644
--- a/R/ds.matrixTranspose.R
+++ b/R/ds.matrixTranspose.R
@@ -15,11 +15,9 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.matrixTranspose} returns to the server-side the transpose matrix.
-#' Also, two validity messages are returned to the client-side
-#' indicating whether the new object has been created in each data source and if so whether
-#' it is in a valid form.
+#' @return \code{ds.matrixTranspose} returns to the server-side the transpose matrix.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -84,15 +82,7 @@
#'
ds.matrixTranspose<-function(M1=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if user has provided the name of matrix representing M1
if(is.null(M1)){
@@ -108,85 +98,5 @@ ds.matrixTranspose<-function(M1=NULL, newobj=NULL, datasources=NULL){
calltext <- call("matrixTransposeDS", M1)
DSI::datashield.assign(datasources, newobj, calltext)
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.matrixTranspose
diff --git a/R/ds.mean.R b/R/ds.mean.R
index f23356d56..ca91ca1dc 100644
--- a/R/ds.mean.R
+++ b/R/ds.mean.R
@@ -30,14 +30,11 @@
#' \code{'split'}, \code{'splits'}, \code{'s'},
#' \code{'both'} or \code{'b'}.
#' For more information see \strong{Details}.
-#' @param checks logical. If TRUE optional checks of model
-#' components will be undertaken. Default is FALSE to save time.
-#' It is suggested that checks
-#' should only be undertaken once the function call has failed.
#' @param save.mean.Nvalid logical. If TRUE generated values of the mean and
#' the number of valid (non-missing) observations will be saved on the data servers.
#' Default FALSE.
#' For more information see \strong{Details}.
+#' @template classConsistencyCheckFalse
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
@@ -50,13 +47,13 @@
#' \code{Global.Mean}: estimated mean, \code{Nmissing}, \code{Nvalid} and \code{Ntotal}
#' across all studies combined (if \code{type = combine} or \code{type = both}). \cr
#' \code{Nstudies}: number of studies being analysed. \cr
-#' \code{ValidityMessage}: indicates if the analysis was possible. \cr
#'
#' If \code{save.mean.Nvalid} is set as TRUE, the objects
#' \code{Nvalid.all.studies}, \code{Nvalid.study.specific},
#' \code{mean.all.studies} and \code{mean.study.specific} are written to the server-side.
#'
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @seealso \code{ds.quantileMean} to compute quantiles.
#' @seealso \code{ds.summary} to generate the summary of a variable.
#' @export
@@ -92,7 +89,6 @@
#'
#' ds.mean(x = "D$LAB_TSC",
#' type = "split",
-#' checks = FALSE,
#' save.mean.Nvalid = FALSE,
#' datasources = connections)
#'
@@ -100,37 +96,14 @@
#' datashield.logout(connections)
#' }
#'
-ds.mean <- function(x=NULL, type='split', checks=FALSE, save.mean.Nvalid=FALSE, datasources=NULL){
+ds.mean <- function(x=NULL, type='split', save.mean.Nvalid=FALSE, datasources=NULL, classConsistencyCheck=FALSE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input object!", call.=FALSE)
}
- # beginning of optional checks - the process stops and reports as soon as one check fails #
- if(checks){
-
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
-
- # the input object must be a numeric or an integer vector
- if(!('integer' %in% typ) & !('numeric' %in% typ)){
- stop("The input object must be an integer or a numeric vector.", call.=FALSE)
- }
-}
-
###################################################################################################
#MODULE: EXTEND "type" argument to include "both" and enable valid alisases #
if(type == 'combine' | type == 'combined' | type == 'combines' | type == 'c') type <- 'combine' #
@@ -140,15 +113,21 @@ if(type != 'combine' & type != 'split' & type != 'both'){
stop('Function argument "type" has to be either "both", "combine" or "split"', call.=FALSE) #
}
- cally <- paste0("meanDS(", x, ")")
- ss.obj <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ cally <- call("meanDS", x)
+ ss.obj <- DSI::datashield.aggregate(datasources, cally)
- Nstudies <- length(datasources)
- ss.mat <- matrix(as.numeric(matrix(unlist(ss.obj),nrow=Nstudies,byrow=TRUE)[,1:4]),nrow=Nstudies)
- dimnames(ss.mat) <- c(list(names(ss.obj),names(ss.obj[[1]])[1:4]))
+ if(classConsistencyCheck){
+ .checkClassConsistency(ss.obj)
+ }
- ValidityMessage.mat <- matrix(matrix(unlist(ss.obj),nrow=Nstudies,byrow=TRUE)[,5],nrow=Nstudies)
- dimnames(ValidityMessage.mat) <- c(list(names(ss.obj),names(ss.obj[[1]])[5]))
+ Nstudies <- length(datasources)
+ ss.mat <- matrix(c(
+ sapply(ss.obj, function(r) r$EstimatedMean),
+ sapply(ss.obj, function(r) r$Nmissing),
+ sapply(ss.obj, function(r) r$Nvalid),
+ sapply(ss.obj, function(r) r$Ntotal)
+ ), nrow=Nstudies)
+ dimnames(ss.mat) <- list(names(ss.obj), c("EstimatedMean", "Nmissing", "Nvalid", "Ntotal"))
ss.mat.combined <- t(matrix(ss.mat[1,]))
@@ -176,37 +155,20 @@ if(type != 'combine' & type != 'split' & type != 'both'){
Nvalid.all.studies <- ss.mat.combined[1,3]
DSI::datashield.assign(datasources, "mean.all.studies", as.symbol(mean.all.studies))
DSI::datashield.assign(datasources, "Nvalid.all.studies", as.symbol(Nvalid.all.studies))
-
-#############################################################################
-# MODULE 5: CHECK DATA OBJECTS SUCCESSFULLY CREATED #
- key.names <- extract("mean.all.studies") #
- key.varname <- key.names$elements #
- key.obj2lookfor <- key.names$holders #
- #
- if(is.na(key.obj2lookfor)){ #
- key.defined <- isDefined(datasources, key.varname) #
- }else{ #
- key.defined <- isDefined(datasources, key.obj2lookfor) #
- } #
- #
-#if(key.defined==TRUE){ #
-#print("Data object created successfully in all sources") #
-#} #
-#############################################################################
}
#PRIMARY FUNCTION OUTPUT SUMMARISE RESULTS FROM
#AGGREGATE FUNCTION AND RETURN TO CLIENT-SIDE
if (type=='split'){
- return(list(Mean.by.Study=ss.mat,Nstudies=Nstudies,ValidityMessage=ValidityMessage.mat))
+ return(list(Mean.by.Study=ss.mat,Nstudies=Nstudies))
}
if (type=="combine") {
- return(list(Global.Mean=ss.mat.combined,Nstudies=Nstudies,ValidityMessage=ValidityMessage.mat))
+ return(list(Global.Mean=ss.mat.combined,Nstudies=Nstudies))
}
if (type=="both") {
- return(list(Mean.by.Study=ss.mat,Global.Mean=ss.mat.combined,Nstudies=Nstudies,ValidityMessage=ValidityMessage.mat))
+ return(list(Mean.by.Study=ss.mat,Global.Mean=ss.mat.combined,Nstudies=Nstudies))
}
}
diff --git a/R/ds.meanSdGp.R b/R/ds.meanSdGp.R
index 1bd60936b..f95cdbb91 100644
--- a/R/ds.meanSdGp.R
+++ b/R/ds.meanSdGp.R
@@ -57,10 +57,7 @@
#' This can be set as: \code{"combine"}, \code{"split"} or \code{"both"}.
#' Default \code{"both"}.
#' For more information see \strong{Details}.
-#' @param do.checks logical. If TRUE the administrative checks
-#' are undertaken to ensure that the input objects are defined in all studies and that the
-#' variables are of equivalent class in each study.
-#' Default is FALSE to save time.
+#' @template classConsistencyCheckTrue
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
@@ -68,6 +65,7 @@
#' across studies and/or separately for each study, depending on the argument \code{type}.
#'
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @seealso \code{\link{ds.subsetByClass}} to subset by the classes of factor vector(s).
#' @seealso \code{\link{ds.subset}} to subset by complete cases (i.e. removing missing values), threshold,
#' columns and rows.
@@ -108,7 +106,6 @@
#' ds.meanSdGp(x = "D$age.60",
#' y = "D$time.id",
#' type = "combine",
-#' do.checks = FALSE,
#' datasources = connections)
#'
#' #Example 2: Calculate the mean, SD, Nvalid and SEM of the continuous variable age.60 (age in
@@ -119,24 +116,15 @@
#' ds.meanSdGp(x = "D$age.60",
#' y = "D$time.id",
#' type = "both",
-#' do.checks = FALSE,
#' datasources = connections)
#'
#' # clear the Datashield R sessions and logout
#' datashield.logout(connections)
#' }
#'
-ds.meanSdGp <- function(x=NULL, y=NULL, type='both', do.checks=FALSE, datasources=NULL){
+ds.meanSdGp <- function(x=NULL, y=NULL, type='both', datasources=NULL, classConsistencyCheck=TRUE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input vector!", call.=FALSE)
@@ -146,17 +134,6 @@ ds.meanSdGp <- function(x=NULL, y=NULL, type='both', do.checks=FALSE, datasource
stop("Please provide the name of the input vector!", call.=FALSE)
}
- if(do.checks){
-
- # check if the input objects are defined in all the studies
- isDefined(datasources, x)
- isDefined(datasources, y)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ1 <- checkClass(datasources, x)
- typ2 <- checkClass(datasources, y)
- }
-
# names of the studies
stdnames <- names(datasources)
@@ -168,8 +145,15 @@ ds.meanSdGp <- function(x=NULL, y=NULL, type='both', do.checks=FALSE, datasource
# call the server side function that calculates mean and standard deviation
# by group in each study
- calltext <- paste0("meanSdGpDS(", x, ",", y, ")")
- output <- DSI::datashield.aggregate(datasources, as.symbol(calltext))
+ cally <- call("meanSdGpDS", x, y)
+ output <- DSI::datashield.aggregate(datasources, cally)
+
+ if(classConsistencyCheck){
+ # check the summarised variable (x) and grouping factor (y) each have the
+ # same class in all studies
+ .checkClassConsistency(output, field = "class.x", object_name = x)
+ .checkClassConsistency(output, field = "class.index", object_name = y)
+ }
numsources <- length(output)
diff --git a/R/ds.merge.R b/R/ds.merge.R
index 4ac436fb5..c2d11678f 100644
--- a/R/ds.merge.R
+++ b/R/ds.merge.R
@@ -48,11 +48,9 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.merge} returns the merged data frame that is written on the server-side.
-#' Also, two validity messages are returned to the client-side
-#' indicating whether the new object has been created in each data source and if so whether
-#' it is in a valid form.
+#' @return \code{ds.merge} returns the merged data frame that is written on the server-side.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -116,15 +114,7 @@
ds.merge <- function(x.name=NULL,y.name=NULL, by.x.names=NULL, by.y.names=NULL,all.x=FALSE,all.y=FALSE,
sort=TRUE, suffixes = c(".x",".y"), no.dups=TRUE, incomparables=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# dataframe names
if(is.null(x.name)){
@@ -134,10 +124,6 @@ ds.merge <- function(x.name=NULL,y.name=NULL, by.x.names=NULL, by.y.names=NULL,a
if(is.null(y.name)){
stop("Please provide the name (eg 'name2') of second dataframe to be merged (called y) ", call.=FALSE)
}
-
- # check if the input objects are defined in all the studies
- isDefined(datasources, x.name)
- isDefined(datasources, y.name)
# names of columns to merge on (may be more than one)
if(is.null(by.x.names)){
@@ -171,82 +157,5 @@ ds.merge <- function(x.name=NULL,y.name=NULL, by.x.names=NULL, by.y.names=NULL,a
DSI::datashield.assign(datasources, newobj, calltext)
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
-
}
# ds.merge
diff --git a/R/ds.metadata.R b/R/ds.metadata.R
index 58f615b16..78ceb43c3 100644
--- a/R/ds.metadata.R
+++ b/R/ds.metadata.R
@@ -12,6 +12,7 @@
#' @return \code{ds.metadata} returns to the client-side the metadata of associated to an object
#' held at the server.
#' @author Stuart Wheater, DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -49,21 +50,7 @@
ds.metadata = function(x=NULL, datasources=NULL)
{
- #####################################################################################
- #MODULE 1: IDENTIFY DEFAULT CONNECTIONS #
- # look for DS connections #
- if (is.null(datasources)){ #
- datasources <- datashield.connections_find() #
- } #
- #####################################################################################
-
- ###############################################################################################################
- #MODULE 2: ENSURE CORRECT DATASOURCES #
- # ensure datasources is a list of DSConnection-class #
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){ #
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE) #
- } #
- ###############################################################################################################
+ datasources <- .set_datasources(datasources)
#####################################################################################
#MODULE 3: SET UP KEY VARIABLES ALLOWING FOR DIFFERENT INPUT FORMATS #
@@ -79,14 +66,6 @@ ds.metadata = function(x=NULL, datasources=NULL)
} #
#####################################################################################
- #####################################################################################
- #MODULE 5: CHECK ALL SERVICES HAVE SPECIFIED VARIABLES DEFINED #
- defined = all(unlist(isDefined(datasources, x))) #
- if (! defined){ #
- stop("Variable not defined in all servers", call.=FALSE) #
- } #
- #####################################################################################
-
cally <- call("metadataDS", x)
metadatas <- DSI::datashield.aggregate(datasources, cally)
diff --git a/R/ds.mice.R b/R/ds.mice.R
index bcb473a4a..38e271572 100644
--- a/R/ds.mice.R
+++ b/R/ds.mice.R
@@ -43,29 +43,19 @@
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return a list with three elements: the method, the predictorMatrix and the post.
#' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.mice <- function(data=NULL, m=5, maxit=5, method=NULL, predictorMatrix=NULL, post=NULL,
seed=NA, newobj_mids=NULL, newobj_df=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- DSI::datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
-
+ datasources <- .set_datasources(datasources)
+
# verify that 'data' was set
if(is.null(data)){
stop("Please provide the name of the dataframe or matrix that contains the incomplete data!", call.=FALSE)
}
-
- # check if the 'data' are defined in all the studies
- defined.data <- isDefined(datasources, data)
-
+
if(!is.null(method)){
method <- paste0(as.character(method), collapse=",")
}
diff --git a/R/ds.names.R b/R/ds.names.R
index 97ebbdfd7..e348f0021 100644
--- a/R/ds.names.R
+++ b/R/ds.names.R
@@ -20,6 +20,7 @@
#' of a list object stored on the server-side.
#' @author Amadou Gaye, updated by Paul Burton for DataSHIELD development
#' team 25/06/2020
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -68,25 +69,14 @@
#'
ds.names <- function(xname=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(xname)){
stop("Please provide the name of the input list!", call.=FALSE)
}
-
- # check if the input object is defined in all the studies
- isDefined(datasources, xname)
calltext <- call("namesDS", xname)
- output <- datashield.aggregate(datasources, calltext)
+ output <- DSI::datashield.aggregate(datasources, calltext)
return(output)
}
#ds.names
diff --git a/R/ds.ns.R b/R/ds.ns.R
index e98643d4d..e1e101ef0 100644
--- a/R/ds.ns.R
+++ b/R/ds.ns.R
@@ -30,20 +30,13 @@
#' arguments to ns, and explicitly give the knots, Boundary.knots etc for use by predict.ns().
#' The object is assigned at each serverside.
#' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.ns <- function(x, df = NULL, knots = NULL, intercept = FALSE, Boundary.knots = NULL,
newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# create a name by default if user did not provide a name for the new variable
if(is.null(newobj)){
diff --git a/R/ds.numNA.R b/R/ds.numNA.R
index 0bd75185a..444034f71 100644
--- a/R/ds.numNA.R
+++ b/R/ds.numNA.R
@@ -6,13 +6,15 @@
#' @details The number of missing entries are counted and the total for each study is returned.
#'
#' Server function called: \code{numNaDS}
-#' @param x a character string specifying the name of the vector.
+#' @param x a character string specifying the name of the vector.
+#' @template classConsistencyCheckTrue
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.numNA} returns to the client-side the number of missing values
#' on a server-side vector.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -52,31 +54,21 @@
#'
#' }
#'
-ds.numNA <- function(x=NULL, datasources=NULL){
+ds.numNA <- function(x=NULL, datasources=NULL, classConsistencyCheck=TRUE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of a vector!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
+ cally <- call("numNaDS", x)
+ results <- DSI::datashield.aggregate(datasources, cally)
- # call the server side function
- cally <- paste0("numNaDS(", x, ")")
- numNAs <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ if(classConsistencyCheck){
+ .checkClassConsistency(results)
+ }
+ numNAs <- lapply(results, function(r) r$numNA)
return(numNAs)
}
diff --git a/R/ds.qlspline.R b/R/ds.qlspline.R
index 9839d9843..ca808fb03 100644
--- a/R/ds.qlspline.R
+++ b/R/ds.qlspline.R
@@ -28,27 +28,17 @@
#' @return an object of class "lspline" and "matrix", which its name is specified by the
#' \code{newobj} argument (or its default name "qlspline.newobj"), is assigned on the serverside.
#' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.qlspline <- function(x, q, na.rm = TRUE, marginal = FALSE, names = NULL, newobj = NULL, datasources = NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input variable x!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- defined <- isDefined(datasources, x)
-
if(is.null(q)){
stop("Argument 'q' is missing, with no default!", call.=FALSE)
}
diff --git a/R/ds.quantileMean.R b/R/ds.quantileMean.R
index 48aa705b4..fd8145a66 100644
--- a/R/ds.quantileMean.R
+++ b/R/ds.quantileMean.R
@@ -15,12 +15,14 @@
#' @param type a character that represents the type of graph to display.
#' This can be set as \code{'combine'} or \code{'split'}.
#' For more information see \strong{Details}.
+#' @template classConsistencyCheckFalse
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.quantileMean} returns to the client-side the quantiles and statistical mean
#' of a server-side numeric vector.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @seealso \code{\link{ds.mean}} to compute the statistical mean.
#' @seealso \code{\link{ds.summary}} to generate the summary of a variable.
#' @export
@@ -65,17 +67,9 @@
#'
#' }
#'
-ds.quantileMean <- function(x=NULL, type='combine', datasources=NULL){
+ds.quantileMean <- function(x=NULL, type='combine', datasources=NULL, classConsistencyCheck=FALSE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input vector!", call.=FALSE)
@@ -85,27 +79,23 @@ ds.quantileMean <- function(x=NULL, type='combine', datasources=NULL){
stop('Function argument "type" has to be either "combine" or "split"', call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
+ # get the server function that produces the quantiles
+ cally1 <- call("quantileMeanDS", x)
+ results <- DSI::datashield.aggregate(datasources, cally1)
- # the input object must be a numeric or an integer vector
- if(!('integer' %in% typ) & !('numeric' %in% typ)){
- message(paste0(x, " is of type ", typ, "!"))
- stop("The input object must be an integer or numeric vector.", call.=FALSE)
+ if(classConsistencyCheck){
+ .checkClassConsistency(results)
}
- # get the server function that produces the quantiles
- cally1 <- paste0('quantileMeanDS(', x, ')')
- quants <- DSI::datashield.aggregate(datasources, as.symbol(cally1))
+ quants <- lapply(results, function(r) r$quantiles)
# combine the vector of quantiles - using weighted sum
cally2 <- call('lengthDS', x)
- lengths <- DSI::datashield.aggregate(datasources, cally2)
- cally3 <- paste0("numNaDS(", x, ")")
- numNAs <- DSI::datashield.aggregate(datasources, as.symbol(cally3))
+ length.results <- DSI::datashield.aggregate(datasources, cally2)
+ lengths <- lapply(length.results, function(r) r$length)
+ cally3 <- call("numNaDS", x)
+ numNA.results <- DSI::datashield.aggregate(datasources, cally3)
+ numNAs <- lapply(numNA.results, function(r) r$numNA)
global.quantiles <- rep(0, length(quants[[1]])-1)
global.mean <- 0
for(i in 1: length(datasources)){
diff --git a/R/ds.rBinom.R b/R/ds.rBinom.R
index ec8b4f880..1759db7d4 100644
--- a/R/ds.rBinom.R
+++ b/R/ds.rBinom.R
@@ -31,9 +31,9 @@
#' Server functions called: \code{rBinomDS} and \code{setSeedDS}.
#' @param samp.size an integer value or an integer vector that defines the length of
#' the random numeric vector to be created in each source.
-#' @param size a positive integer that specifies the number of Bernoulli trials.
+#' @param size a positive integer that specifies the number of Bernoulli trials. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.
#' @param prob a numeric scalar value or vector in range 0 > prob > 1 which specifies the
-#' probability of a positive response (i.e. 1 rather than 0).
+#' probability of a positive response (i.e. 1 rather than 0). A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.
#' @param newobj a character string that provides the name for the output variable
#' that is stored on the data servers. Default \code{rbinom.newobj}.
#' @param seed.as.integer an integer or a NULL value which provides the
@@ -44,13 +44,12 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.rBinom} returns random number vectors
-#' with a Binomial distribution for each study,
-#' taking into account the values specified in each parameter of the function.
-#' The output vector is written to the server-side.
-#' If requested, it also returned to the client-side the full 626 lengths
-#' random seed vector generated in each source
-#' (see info for the argument \code{return.full.seed.as.set}).
+#' @return \code{ds.rBinom} writes a random number vector with a Binomial distribution
+#' to the server-side in each study and returns a list to the client-side containing
+#' \code{integer.seed.as.set.by.source} (the trigger seed set in each source),
+#' \code{random.vector.length.by.source} (the length of the vector created in each source)
+#' and, if \code{return.full.seed.as.set} is TRUE, \code{full.seed.as.set}
+#' (the full 626 length random seed vector generated in each source).
#'
#' @examples
#' \dontrun{
@@ -83,7 +82,7 @@
#'
#' #Generating the vectors in the Opal servers
#' ds.rBinom(samp.size=c(13,20,25), #the length of the vector created in each source is different
-#' size=as.character(c(10,23,5)), #Bernoulli trials change in each source
+#' size=c(10,23,5), #Bernoulli trials change in each source
#' prob=c(0.6,0.1,0.5), #Probability changes in each source
#' newobj="Binom.dist",
#' seed.as.integer=45,
@@ -103,19 +102,11 @@
#' datashield.logout(connections)
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
ds.rBinom<-function(samp.size=1,size=0,prob=1, newobj=NULL, seed.as.integer=NULL, return.full.seed.as.set=FALSE, datasources=NULL){
-##################################################################################
-# look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# create a name by default if user did not provide a name for the new variable
if(is.null(newobj)){
@@ -162,9 +153,13 @@ mess2<-("ERROR: appropriate values must be set for samp.size, size, prob, and ne
return(mess2)
}
+numsources<-length(datasources)
+size<-.expand_to_studies(size, "size", numsources)
+prob<-.expand_to_studies(prob, "prob", numsources)
+
size.valid<-1
if(is.numeric(size)){
- if(size<=0){
+ if(any(size<=0)){
size.valid<-0
}
}
@@ -176,7 +171,7 @@ return(mess3)
prob.valid<-1
if(is.numeric(prob)){
- if(prob<=0||prob>=1.0){
+ if(any(prob<=0|prob>=1.0)){
prob.valid<-0
}
}
@@ -217,8 +212,7 @@ if(seed.as.text=="NULL"){
message("NO SEED SET IN STUDY",study.id,"\n\n")
} else {
- calltext <- paste0("setSeedDS(", seed.as.text, ")")
- ssDS.obj[[study.id]] <- DSI::datashield.aggregate(datasources[study.id], as.symbol(calltext))
+ ssDS.obj[[study.id]] <- datashield.aggregate(datasources[study.id], call("setSeedDS", seedtext=seed.as.text))
}
}
message("\n\n")
@@ -235,104 +229,15 @@ samp.size<-rep(samp.size,numsources)
}
for(k in 1:numsources){
+ datashield.assign(datasources[k], newobj, call("rBinomDS", samp.size[k], size=size[k], prob=prob[k]))
+}
-toAssign<-paste0("rBinomDS(",samp.size[k],",",size, ",", prob, ")")
-
-
- if(is.null(toAssign)){
- stop("Please give the name of object to assign or an expression to evaluate and assign.!\n", call.=FALSE)
- }
-
- # now do the business
-
- DSI::datashield.assign(datasources[k], newobj, as.symbol(toAssign))
- }
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors && !return.full.seed.as.set){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, #
- is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
- if(no.errors && return.full.seed.as.set){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(full.seed.as.set=ssDS.obj, #
- integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, #
- is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
+if(return.full.seed.as.set){
+return(list(full.seed.as.set=ssDS.obj,
+ integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size))
+}
+return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size))
}
diff --git a/R/ds.rNorm.R b/R/ds.rNorm.R
index 76d885f11..05bb15d20 100644
--- a/R/ds.rNorm.R
+++ b/R/ds.rNorm.R
@@ -40,8 +40,8 @@
#'
#' @param samp.size an integer value or an integer vector that defines the length
#' of the random numeric vector to be created in each source.
-#' @param mean the mean value or vector of the Normal distribution to be created.
-#' @param sd the standard deviation of the Normal distribution to be created.
+#' @param mean the mean value or vector of the Normal distribution to be created. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.
+#' @param sd the standard deviation of the Normal distribution to be created. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.
#' @param newobj a character string that provides the name for the output variable
#' that is stored on the data servers. Default \code{newObject}.
#' @param seed.as.integer an integer
@@ -51,15 +51,16 @@
#' If FALSE it will only return the trigger seed value you have provided.
#' Default is FALSE.
#' @param force.output.to.k.decimal.places an integer vector that
-#' forces the output random numbers vector to have k decimals.
+#' forces the output random numbers vector to have k decimals. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.rNorm} returns random number vectors with a normal distribution for each
-#' study, taking into account the values specified in each parameter of the function.
-#' The output vector is written to the server-side.
-#' If requested, it also returned to the client-side the full 626 lengths random seed vector
-#' generated in each source (see info for the argument \code{return.full.seed.as.set}).
+#' @return \code{ds.rNorm} writes a random number vector with a normal distribution
+#' to the server-side in each study and returns a list to the client-side containing
+#' \code{integer.seed.as.set.by.source} (the trigger seed set in each source),
+#' \code{random.vector.length.by.source} (the length of the vector created in each source)
+#' and, if \code{return.full.seed.as.set} is TRUE, \code{full.seed.as.set}
+#' (the full 626 length random seed vector generated in each source).
#' @examples
#' \dontrun{
#'
@@ -92,7 +93,7 @@
#'
#' ds.rNorm(samp.size=c(10,20,45), #the length of the vector created in each source is different
#' mean=c(1,6,4), #the mean of the Normal distribution changes in each server
-#' sd=as.character(c(1,4,3)), #the sd of the Normal distribution changes in each server
+#' sd=c(1,4,3), #the sd of the Normal distribution changes in each server
#' newobj="Norm.dist",
#' seed.as.integer=2345,
#' return.full.seed.as.set=FALSE,
@@ -114,20 +115,12 @@
#' datashield.logout(connections)
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
ds.rNorm<-function(samp.size=1,mean=0,sd=1, newobj="newObject", seed.as.integer=NULL, return.full.seed.as.set=FALSE,
force.output.to.k.decimal.places=9,datasources=NULL){
-##################################################################################
-# look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
########################
#TEST SEED PRIMING VALUE
@@ -169,9 +162,14 @@ mess2<-("ERROR: appropriate values must be set for samp.size, mean, sd, and newo
return(mess2)
}
+numsources<-length(datasources)
+mean<-.expand_to_studies(mean, "mean", numsources)
+sd<-.expand_to_studies(sd, "sd", numsources)
+force.output.to.k.decimal.places<-.expand_to_studies(force.output.to.k.decimal.places, "force.output.to.k.decimal.places", numsources)
+
sd.valid<-1
if(is.numeric(sd)){
- if(sd<=0){
+ if(any(sd<=0)){
sd.valid<-0
}
}
@@ -182,7 +180,7 @@ return(mess3)
}
decimal.places.valid<-1
-if(force.output.to.k.decimal.places<0||force.output.to.k.decimal.places>9){
+if(any(force.output.to.k.decimal.places<0|force.output.to.k.decimal.places>9)){
decimal.places.valid<-0
}
@@ -220,8 +218,7 @@ if(seed.as.text=="NULL"){
message("NO SEED SET IN STUDY",study.id,"\n\n")
}
- calltext <- paste0("setSeedDS(", seed.as.text, ")")
- ssDS.obj[[study.id]] <- DSI::datashield.aggregate(datasources[study.id], as.symbol(calltext))
+ ssDS.obj[[study.id]] <- datashield.aggregate(datasources[study.id], call("setSeedDS", seedtext=seed.as.text))
}
message("\n\n")
@@ -237,104 +234,15 @@ samp.size<-rep(samp.size,numsources)
}
for(k in 1:numsources){
+ datashield.assign(datasources[k], newobj, call("rNormDS", samp.size[k], mean=mean[k], sd=sd[k], force.output.to.k.decimal.places=force.output.to.k.decimal.places[k]))
+}
-toAssign<-paste0("rNormDS(",samp.size[k],",",mean, ",", sd, ",", force.output.to.k.decimal.places,")")
-
-
- if(is.null(toAssign)){
- stop("Please give the name of object to assign or an expression to evaluate and assign.!\n", call.=FALSE)
- }
-
- # now do the business
-
- DSI::datashield.assign(datasources[k], newobj, as.symbol(toAssign))
- }
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors && !return.full.seed.as.set){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, #
- is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
- if(no.errors && return.full.seed.as.set){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(full.seed.as.set=ssDS.obj, #
- integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, #
- is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
+if(return.full.seed.as.set){
+return(list(full.seed.as.set=ssDS.obj,
+ integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size))
+}
+return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size))
}
diff --git a/R/ds.rPois.R b/R/ds.rPois.R
index 74be7fdf7..e6ae42d46 100644
--- a/R/ds.rPois.R
+++ b/R/ds.rPois.R
@@ -29,7 +29,7 @@
#'
#' @param samp.size an integer value or an integer vector that defines the length of the
#' random numeric vector to be created in each source.
-#' @param lambda the number of events mean per interval.
+#' @param lambda the number of events mean per interval. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.
#' @param newobj a character string that provides the name for the output variable
#' that is stored on the data servers. Default \code{newObject}.
#' @param seed.as.integer an integer or a NULL value which provides the random seed
@@ -41,12 +41,12 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.rPois} returns random number vectors with a Poisson distribution for each study,
-#' taking into account the values specified in each parameter of the function.
-#' The created vectors are stored in the server-side.
-#' If requested, it also returned to the client-side the full
-#' 626 lengths random seed vector generated in each source
-#' (see info for the argument \code{return.full.seed.as.set}).
+#' @return \code{ds.rPois} writes a random number vector with a Poisson distribution
+#' to the server-side in each study and returns a list to the client-side containing
+#' \code{integer.seed.as.set.by.source} (the trigger seed set in each source),
+#' \code{random.vector.length.by.source} (the length of the vector created in each source)
+#' and, if \code{return.full.seed.as.set} is TRUE, \code{full.seed.as.set}
+#' (the full 626 length random seed vector generated in each source).
#'
#' @examples
#'
@@ -81,7 +81,7 @@
#'
#' # Generating the vectors in the Opal servers
#' ds.rPois(samp.size=c(13,20,25), #the length of the vector created in each source is different
-#' lambda=as.character(c(2,3,4)), #different mean per interval (2,3,4) in each source
+#' lambda=c(2,3,4), #different mean per interval (2,3,4) in each source
#' newobj="Pois.dist",
#' seed.as.integer=1234,
#' return.full.seed.as.set=FALSE,
@@ -98,19 +98,11 @@
#' datashield.logout(connections)
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
ds.rPois<-function(samp.size=1,lambda=1, newobj="newObject", seed.as.integer=NULL, return.full.seed.as.set=FALSE, datasources=NULL){
-##################################################################################
-# look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
########################
#TEST SEED PRIMING VALUE
@@ -152,9 +144,12 @@ mess2<-("ERROR: appropriate values must be set for samp.size, lambda, and newobj
return(mess2)
}
+numsources<-length(datasources)
+lambda<-.expand_to_studies(lambda, "lambda", numsources)
+
lambda.valid<-1
if(is.numeric(lambda)){
- if(lambda<=0){
+ if(any(lambda<=0)){
lambda.valid<-0
}
}
@@ -193,8 +188,7 @@ if(seed.as.text=="NULL"){
message("NO SEED SET IN STUDY",study.id,"\n\n")
}
- calltext <- paste0("setSeedDS(", seed.as.text, ")")
- ssDS.obj[[study.id]] <- DSI::datashield.aggregate(datasources[study.id], as.symbol(calltext))
+ ssDS.obj[[study.id]] <- datashield.aggregate(datasources[study.id], call("setSeedDS", seedtext=seed.as.text))
}
message("\n\n")
@@ -210,104 +204,15 @@ samp.size<-rep(samp.size,numsources)
}
for(k in 1:numsources){
+ datashield.assign(datasources[k], newobj, call("rPoisDS", samp.size[k], lambda=lambda[k]))
+}
-toAssign<-paste0("rPoisDS(",samp.size[k],",",lambda, ")")
-
-
- if(is.null(toAssign)){
- stop("Please give the name of object to assign or an expression to evaluate and assign.!\n", call.=FALSE)
- }
-
- # now do the business
-
- DSI::datashield.assign(datasources[k], newobj, as.symbol(toAssign))
- }
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors && !return.full.seed.as.set){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, #
- is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
- if(no.errors && return.full.seed.as.set){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(full.seed.as.set=ssDS.obj, #
- integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, #
- is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
+if(return.full.seed.as.set){
+return(list(full.seed.as.set=ssDS.obj,
+ integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size))
+}
+return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size))
}
diff --git a/R/ds.rUnif.R b/R/ds.rUnif.R
index ea74766b5..bac2db04b 100644
--- a/R/ds.rUnif.R
+++ b/R/ds.rUnif.R
@@ -43,10 +43,10 @@
#'
#' @param samp.size an integer value or an integer vector that defines the
#' length of the random numeric vector to be created in each source.
-#' @param min a numeric scalar that specifies the minimum value of the
-#' random numbers in the distribution.
-#' @param max a numeric scalar that specifies the maximum value of the
-#' random numbers in the distribution.
+#' @param min a numeric value that specifies the minimum value of the
+#' random numbers in the distribution. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.
+#' @param max a numeric value that specifies the maximum value of the
+#' random numbers in the distribution. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.
#' @param newobj a character string that provides the name for the output variable
#' that is stored on the data servers. Default \code{newObject}.
#' @param seed.as.integer an integer or a NULL value which provides the random
@@ -56,16 +56,17 @@
#' return the trigger seed value you have provided. Default is FALSE.
#' @param force.output.to.k.decimal.places an integer or
#' an integer vector that forces the output random
-#' numbers vector to have k decimals.
+#' numbers vector to have k decimals. A single value is used in every study; a vector must have one value per study, with its k-th value used in study k.
#'
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.Unif} returns random number vectors with a uniform distribution for each study,
-#' taking into account the values specified in each parameter of the function.
-#' The created vectors are stored in the server-side. If requested, it also returned to the
-#' client-side the full 626 lengths random seed vector generated in each source
-#' (see info for the argument \code{return.full.seed.as.set}).
+#' @return \code{ds.rUnif} writes a random number vector with a uniform distribution
+#' to the server-side in each study and returns a list to the client-side containing
+#' \code{integer.seed.as.set.by.source} (the trigger seed set in each source),
+#' \code{random.vector.length.by.source} (the length of the vector created in each source)
+#' and, if \code{return.full.seed.as.set} is TRUE, \code{full.seed.as.set}
+#' (the full 626 length random seed vector generated in each source).
#' @examples
#'
#' \dontrun{
@@ -99,8 +100,8 @@
#' # Generating the vectors in the Opal servers
#'
#' ds.rUnif(samp.size = c(12,20,4), #the length of the vector created in each source is different
-#' min = as.character(c(0,2,5)), #different minumum value of the function in each source
-#' max = as.character(c(2,5,9)), #different maximum value of the function in each source
+#' min = c(0,2,5), #different minumum value of the function in each source
+#' max = c(2,5,9), #different maximum value of the function in each source
#' newobj = "Unif.dist",
#' seed.as.integer = 234,
#' return.full.seed.as.set = FALSE,
@@ -122,20 +123,12 @@
#' }
#'
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
ds.rUnif<-function(samp.size=1,min=0,max=1, newobj="newObject", seed.as.integer=NULL, return.full.seed.as.set=FALSE,
force.output.to.k.decimal.places=9,datasources=NULL){
-##################################################################################
-# look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
########################
#TEST SEED PRIMING VALUE
@@ -178,11 +171,16 @@ mess2<-("ERROR: appropriate values must be set for samp.size, min, max, and newo
return(mess2)
}
+numsources<-length(datasources)
+min<-.expand_to_studies(min, "min", numsources)
+max<-.expand_to_studies(max, "max", numsources)
+force.output.to.k.decimal.places<-.expand_to_studies(force.output.to.k.decimal.places, "force.output.to.k.decimal.places", numsources)
+
minmax.valid<-1
if(is.numeric(min) && is.numeric(max)){
- if(min>=max){
+ if(any(min>=max)){
minmax.valid<-0
}
@@ -194,7 +192,7 @@ return(mess3)
}
decimal.places.valid<-1
-if(force.output.to.k.decimal.places<0||force.output.to.k.decimal.places>9){
+if(any(force.output.to.k.decimal.places<0|force.output.to.k.decimal.places>9)){
decimal.places.valid<-0
}
@@ -235,10 +233,9 @@ if(seed.as.text=="NULL"){
message("NO SEED SET IN STUDY",study.id,"\n")
} else {
- calltext <- paste0("setSeedDS(", seed.as.text, ")")
- ssDS.obj[[study.id]] <- DSI::datashield.aggregate(datasources[study.id], as.symbol(calltext))
+ ssDS.obj[[study.id]] <- datashield.aggregate(datasources[study.id], call("setSeedDS", seedtext=seed.as.text))
+}
}
-}
##############################
@@ -249,104 +246,15 @@ samp.size<-rep(samp.size,numsources)
}
for(k in 1:numsources){
+ datashield.assign(datasources[k], newobj, call("rUnifDS", samp.size[k], min=min[k], max=max[k], force.output.to.k.decimal.places=force.output.to.k.decimal.places[k]))
+}
-toAssign<-paste0("rUnifDS(",samp.size[k],",",min, ",", max, ",", force.output.to.k.decimal.places,")")
-
-
- if(is.null(toAssign)){
- stop("Please give the name of object to assign or an expression to evaluate and assign.!\n", call.=FALSE)
- }
-
- # now do the business
-
- DSI::datashield.assign(datasources[k], newobj, as.symbol(toAssign))
- }
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors && !return.full.seed.as.set){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, #
- is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
- if(no.errors && return.full.seed.as.set){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(full.seed.as.set=ssDS.obj, #
- integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size, #
- is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
+if(return.full.seed.as.set){
+return(list(full.seed.as.set=ssDS.obj,
+ integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size))
+}
+return(list(integer.seed.as.set.by.source=single.integer.seed,random.vector.length.by.source=samp.size))
}
diff --git a/R/ds.ranksSecure.R b/R/ds.ranksSecure.R
deleted file mode 100644
index 8ffa6a971..000000000
--- a/R/ds.ranksSecure.R
+++ /dev/null
@@ -1,585 +0,0 @@
-# ds.ranksSecure
-#' @title Secure ranking of a vector across all sources
-#' @description Securely generate the ranks of a numeric vector and estimate
-#' true global quantiles across all data sources simultaneously
-#' @details ds.ranksSecure is a clientside function which calls a series of
-#' other clientside and serverside functions to securely generate the global
-#' ranks of a numeric vector "V2BR" (vector to be ranked)
-#' in order to set up analyses on V2BR based on
-#' non-parametric methods, some types of survival analysis and to derive true
-#' global quantiles (such as the median, lower (25%) and upper (75%) quartiles,
-#' and the 95% and 97.5% quantiles) across all sources simultaneously. These
-#' global quantiles are, in general, different to the mean or median of the
-#' equivalent quantiles calculated independently in each data source separately.
-#' For more details about the cluster of functions that collectively
-#' enable secure global ranking and estimation of global quantiles see the
-#' associated document entitled "secure.global.ranking.docx".
-#' @param input.var.name a character string in a format that can pass through
-#' the DataSHIELD R parser which specifies the name of the vector to be ranked.
-#' Needs to have same name in each data source.
-#' @param quantiles.for.estimation one of a restricted set of character strings.
-#' To mitigate disclosure risk only the following set of quantiles can be
-#' generated: c(0.025,0.05,0.10,0.20,0.25,0.30,0.3333,0.40,0.50,0.60,0.6667,
-#' 0.70,0.75,0.80,0.90,0.95,0.975). The allowable formats for the argument
-#' are of the general form: "0.025-0.975" where the first number is the lowest
-#' quantile to be estimated and the second number is the equivalent highest
-#' quantile to estimate. These two quantiles are then estimated along with
-#' all allowable quantiles in between. The allowable argument values are then:
-#' "0.025-0.975", "0.05-0.95", "0.10-0.90", "0.20-0.80". Two alternative values
-#' are "quartiles" i.e. c(0.25,0.50,0.75), and "median" i.e. c(0.50). The
-#' default value is "0.05-0.95". If the sample size is so small that an extreme
-#' quartile could be disclosive the function will be terminated and an error
-#' message returned telling you that you might try using an argument with a
-#' narrower set of quantiles. This disclosure trap will be triggered if the
-#' total number of subjects across all studies divided by the total number
-#' of quantile values being estimated is less than or equal to nfilter.tab
-#' (the minimum cell size in a contingency table).
-#' @param generate.quantiles a logical value indicating whether the
-#' ds.ranksSecure function should carry on to estimate the key quantile
-#' values specified by argument or should stop
-#' once the global ranks have been created and written to the serverside.
-#' Default is TRUE and as the key quantiles are generally non-disclosive this
-#' is usually the setting to use. But, if there is some abnormal configuration
-#' of the clusters of values that are being ranked such that some values are
-#' treated as being missing and the processing stops, then setting
-#' generate.quantiles to FALSE allows the generation of ranks to complete so
-#' they can then be used for non-parametric analysis, even if the key values
-#' cannot be estimated. A real example of an unusual configuration was in a
-#' reasonably large dataset of survival times, where a substantial proportion
-#' of survival profiles were censored at precisely 10 years. This meant that
-#' the 97.5% percentile could not be separated from the 95% percentile and so
-#' the former was allocated the value NA. This stopped processing of the ranks
-#' which could then be enabled by setting generate.quantiles to FALSE. However,
-#' if this problem is detected an error message is returned which indicates that
-#' in some cases (as in this case in fact) the problem can be circumvented
-#' by selecting a narrow range of key quantiles to estimate. In this case, in
-#' fact, this simply required changing the argument
-#' from "0.025-0.975" to "0.05-0.95".
-#' @param output.ranks.df a character string in a format that can pass through
-#' the DataSHIELD R parser which specifies an optional name for the
-#' data.frame written to the serverside on each data source that contains
-#' 11 of the key output variables from the ranking procedure pertaining to that
-#' particular data source. This includes the global ranks and quantiles of each
-#' value of the V2BR (i.e. the values are ranked across all studies
-#' simultaneously). If no name is specified, the default name
-#' is allocated as "full.ranks.df". This data.frame contains disclosive
-#' information and cannot therefore be passed to the clientside.
-#' @param summary.output.ranks.df a character string in a format that can pass through
-#' the DataSHIELD R parser which specifies an optional name for the summary
-#' data.frame written to the serverside on each data source that contains
-#' 5 of the key output variables from the ranking procedure pertaining to that
-#' particular data source. This again includes the global ranks and quantiles of each
-#' value of the V2BR (i.e. the values are ranked across all studies
-#' simultaneously). If no name is specified, the default name
-#' is allocated as "summary.ranks.df" This data.frame contains disclosive
-#' information and cannot therefore be passed to the clientside.
-#' @param ranks.sort.by a character string taking two possible values. These
-#' are "ID.orig" and "vals.orig". These define the order in which the
-#' output.ranks.df and summary.output.ranks.df data frames are presented. If
-#' the argument is set as "ID.orig" the order of rows in the output data frames
-#' are precisely the same as the order of original input vector that is being
-#' ranked (i.e. V2BR). This means the ranks can simply be cbinded to the
-#' matrix, data frame or tibble that originally included V2BR so it also
-#' includes the corresponding ranks. If it is set as "vals.orig" the output
-#' data frames are in order of increasing magnitude of the original values of
-#' V2BR. Default value is "ID.orig".
-#' @param shared.seed.value an integer value which is used to set the
-#' random seed generator in each study. Initially, the seed is set to be the
-#' same in all studies, so the order and parameters of the repeated
-#' encryption procedures are precisely the same in each study. Then a
-#' study-specific modification of the seed in each study ensures that the
-#' procedures initially generating the masking pseudodata (which are then
-#' subject to the same encryption procedures as the real data) are different
-#' in each study. For further information about the shared seed and how we
-#' intend to transmit it in the future, please see the detailed associated
-#' header document.
-#' @param synth.real.ratio an integer value specifying the ratio between the
-#' number of masking pseudodata values generated in each study compared to
-#' the number of real data values in V2BR.
-#' @param NA.manage character string taking three possible values: "NA.delete",
-#' "NA.low","NA.hi". This argument determines how missing values are managed
-#' before ranking. "NA.delete" results in all missing values being removed
-#' prior to ranking. This means that the vector of ranks in each study is
-#' shorter than the original vector of V2BR values by an amount corresponding
-#' to the number of missing values in V2BR in that study. Any rows containing
-#' missing values in V2BR are simply removed before the ranking procedure is
-#' initiated so the order of rows without missing data is unaltered. "NA.low"
-#' indicates that all missing values should be converted to a new value that
-#' has a meaningful magnitude that is lower (more negative or less positive)
-#' than the lowest non-missing value of V2BR in any of the studies. This means,
-#' for example, that if there are a total of M values of V2BR that are missing
-#' across all studies, there will be a total of M observations that are ranked
-#' lowest each with a rank of (M+1)/2. So if 7 are missing the lowest 7 ranks
-#' will be 4,4,4,4,4,4,4 and if 4 are missing the first 4 ranks will be
-#' 2.5,2.5,2.5,2.5. "NA.hi" indicates that all missing values should be
-#' converted to a new value that has a meaningful magnitude that is higher(less
-#' negative or more positive)than the highest non-missing value of V2BR in any
-#' of the studies. This means, for example, that if there are a total of M
-#' values of V2BR that are missing across all studies and N non-missing
-#' values, there will be a total of M observations that are ranked
-#' highest each with a rank of (2N-M+1)/2. So if there are a total of 1000
-#' V2BR values and 9 are missing the highest 9 ranks will be 996, 996 ... 996.
-#' If NA.manage is either "NA.low" or "NA.hi" the final rank vector in each
-#' study will have the same length as the V2BR vector in that same study.
-#' 2.5,2.5,2.5,2.5. The default value of the "NA.manage" argument is "NA.delete"
-#' @param rm.residual.objects logical value. Default = TRUE: at the beginning
-#' and end of each run of ds.ranksSecure delete all extraneous objects that are
-#' otherwise left behind. These are not usually needed, but could be of value
-#' if one were investigating a problem with the ranking. FALSE: do not delete
-#' the residual objects
-#' @param monitor.progress logical value. Default = FALSE. If TRUE, function
-#' outputs information about its progress.
-#' @param datasources specifies the particular opal object(s) to use. If the
-#' argument is not specified (NULL) the default set of opals
-#' will be used. If is specified, it should be set without
-#' inverted commas: e.g. datasources=opals.em. If you wish to
-#' apply the function solely to e.g. the second opal server in a set of three,
-#' the argument can be specified as: e.g. datasources=opals.em[2].
-#' If you wish to specify the first and third opal servers in a set you specify:
-#' e.g. datasources=opals.em[c(1,3)].
-#' @return the data frame objects specified by the arguments output.ranks.df
-#' and summary.output.ranks.df. These are written to the serverside in each
-#' study. Provided the sort order is consistent these data frames can be cbinded
-#' to any other data frame, matrix or tibble object containing V2BR or to the
-#' V2BR vector itself, allowing the global ranks and quantiles to be
-#' analysed rather than the actual values of V2BR. The last call within
-#' the ds.ranksSecure function is to another clientside function
-#' ds.extractQuantile (for further details see header for that function).
-#' This returns an additional data frame "final.quantile.df" of which the first
-#' column is the vector of key quantiles to be estimated as specified by the
-#' argument and the second column is the list of
-#' precise values of V2BR which correspond to these key quantiles. Because
-#' the serverside functions associated with ds.ranksSecure and
-#' ds.extractQuantile block potentially disclosive output (see information
-#' for parameter quantiles.for.estimation) the "final.quantile.df" is returned
-#' to the client allowing the direct reporting of V2BR values corresponding to
-#' key quantiles such as the quartiles, the median and 95th percentile etc. In
-#' addition a copy of the same data frame is also written to the serverside in
-#' each study allowing the value of key quantiles such as the median to be
-#' incorporated directly in calculations or transformations on the serverside
-#' regardless in which study (or studies) those key quantile values have
-#' occurred.
-#' @author Paul Burton 4th November, 2021
-#' @export
-ds.ranksSecure <- function(input.var.name=NULL, quantiles.for.estimation="0.05-0.95",
- generate.quantiles=TRUE,
- output.ranks.df=NULL, summary.output.ranks.df = NULL,
- ranks.sort.by="ID.orig", shared.seed.value=10,
- synth.real.ratio=2,NA.manage="NA.delete",
- rm.residual.objects=TRUE, monitor.progress=FALSE,
- datasources=NULL){
-
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- datasources.in.current.function<-datasources
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
-
- # check if user has provided the name of the column that holds the input variable
- if(is.null(input.var.name)){
- stop("Please provide the name of the variable to be ranked across all sources collectively e.g. 'varname'", call.=FALSE)
- }
-
- # check if user has provided the name of the input variable in a correct character format
- if(!is.character(input.var.name)){
- stop("Please provide the name of the variable that is to be converted to a factor in character format e.g. 'varname'", call.=FALSE)
- }
-
- # look for output df names and provide defaults if required
- if(is.null(output.ranks.df)){
- output.ranks.df<-"full.ranks.df"
- }
-
- if(is.null(summary.output.ranks.df)){
- summary.output.ranks.df<-"summary.ranks.df"
- }
-
- if(is.null(synth.real.ratio)){
- synth.real.ratio<-10
- }
-
-#CLEAN UP RESIDUAL OBJECTS FROM PREVIOUS RUNS OF THE FUNCTION
- if(rm.residual.objects)
- {
- #UNLESS THE IS FALSE,
- #CLEAR UP ANY UNWANTED RESIDUAL OBJECTS FROM THE
- #PREVIOUS RUNNING OF THE ds.ranksSecure FUNCTION IN THE
- #CASE THAT PREVIOUS CALL STOPPED PREMATURELY AND SO THE
- #FINAL CLEARING UP STEP WAS NOT INITIATED.
-
- rm.names<-c("blackbox.output.df", "blackbox.ranks.df",
- "global.bounds.df", "global.ranks.quantiles.df",
- "input.mean.sd.df", "input.ranks.sd.df",
- output.ranks.df, "min.max.df", "numstudies.df",
- "sR4.df", "sR5.df")
-
- #make transmittable via parser
- rm.names.transmit <- paste(rm.names,collapse=",")
-
- calltext.rm <- call("rmDS", rm.names.transmit)
-
- rm.output <- DSI::datashield.aggregate(datasources, calltext.rm)
- }
-
- if(monitor.progress){
-message("\n\nStep 1 of 8 complete:
- Cleaned up residual output from
- previous runs of ds.ranksSecure
-
-
- ")
-
-
- }
-
- #CALL AN INITIALISING SERVER SIDE FUNCTION (ASSIGN)
- #TO IDENTIFY QUANTILES OF ORIGINAL VARIABLES IN EACH STUDY
- #TO CREATE A STARTING CONFIGURATION THAT IS ALMOST CERTAINLY >1 WITH A SPAN OF 10
-
- cally0 <- paste0('quantileMeanDS(', input.var.name, ')')
- initialise.input.var <- DSI::datashield.aggregate(datasources, as.symbol(cally0))
-
-
- numstudies<-length(initialise.input.var)
- numvals<-length(initialise.input.var[[1]])
-
- q5.val<-NULL
- q95.val<-NULL
- mean.val<-NULL
-
- for(rr in 1:numstudies){
- q5.val<-c(q5.val,initialise.input.var[[rr]][1])
- q95.val<-c(q95.val,initialise.input.var[[rr]][numvals-1])
- mean.val<-c(mean.val,initialise.input.var[[rr]][numvals])
- }
-
- min.q5<-min(q5.val)
- max.q95<-max(q95.val)
-
- max.sd.input.var<-(max.q95-min.q5)/(2*1.65)
- mean.input.var<-mean(mean.val)
-
- input.mean.sd.df<-data.frame(cbind(mean.input.var,max.sd.input.var))
-
-
- #CALL CLIENTSIDE FUNCTION ds.dmtC2S TO RETURN VALUES TO SERVERSIDE
- dsBaseClient::ds.dmtC2S(dfdata=input.mean.sd.df,newobj="input.mean.sd.df")
-
-if(monitor.progress){
-message("\n\nStep 2 of 8 complete:
- Estimated mean and sd of
- v2br to standardise initial values
-
-
- ")
- }
-
-#CALL minMaxRandDS FUNCTION (AGGREGATE) TO CREATE MIN AND MAX VALUES
-#FOR INPUT VARIABLE WITH RANDOM NOISE ON TOP. ACTUAL VALUE DOESN'T
-#MATTER AS IT IS ONLY TO ALLOCATE LOW AND HIGH VALUES TO NA WHEN
-#THEY ARE TO BE INCLUDED IN THE RANKING
-
- calltext0 <- call("minMaxRandDS",input.var.name)
- rand.min.max<-DSI::datashield.aggregate(datasources, calltext0)
-
-
- numstudies<-length(rand.min.max)
-
- rand.min.min<-NULL
- rand.max.max<-NULL
-
- for(ss in 1:numstudies){
- rand.min.min<-c(rand.min.min,rand.min.max[[ss]][1])
- rand.max.max<-c(rand.max.max,rand.min.max[[ss]][2])
- }
-
- min.min.final<-min(rand.min.min)
- max.max.final<-min(rand.max.max)
-
- min.max.df<-data.frame(cbind(min.min.final,max.max.final))
-
-#CALL CLIENTSIDE FUNCTION ds.dmtC2S TO RETURN VALUES TO SERVERSIDE
-dsBaseClient::ds.dmtC2S(dfdata=min.max.df,newobj="min.max.df")
-
-if(monitor.progress){
-message("\n\nStep 3 of 8 complete:
- Generated ultra max and ultra min values to allocate to
- missing values if is NA.hi or NA.low
-
-
- ")
-}
-
- #CALL THE FIRST SERVER SIDE FUNCTION (ASSIGN)
- #WRITES ENCRYPTED DATA TO SERVERSIDE OBJECT "blackbox.output.df"
- calltext1 <- call("blackBoxDS", input.var.name=input.var.name,
- #max.sd.input.var=input.mean.sd.df$max.sd.input.var,
- #mean.input.var=input.mean.sd.df$mean.input.var,
- shared.seedval=shared.seed.value,synth.real.ratio,NA.manage)
- DSI::datashield.assign(datasources, "blackbox.output.df", calltext1)
-
-if(monitor.progress){
-message("\n\nStep 4 of 8 complete:
- Pseudo data synthesised,first set of rank-consistent
- transformations complete and blackbox.output.df created
-
-
- ")
- }
-
- #CALL THE SECOND SERVER SIDE FUNCTION (AGGREGATE)
- #RETURN ENCRYPTED DATA IN "blackbox.output.df" TO CLIENTSIDE
- calltext2 <- call("ranksSecureDS1")
- blackbox.output<-DSI::datashield.aggregate(datasources, calltext2)
-
- numstudies<-length(blackbox.output)
-
- studyid<-rep(1,nrow(blackbox.output[[1]]))
-
- sR3.df<-data.frame(cbind(blackbox.output[[1]],studyid))
-
-
- if(numstudies>=1)
- {
- for(ss in 2:numstudies)
- {
- studyid<-rep(ss,nrow(blackbox.output[[ss]]))
-
- temp.df<-data.frame(cbind(blackbox.output[[ss]],studyid))
- sR3.df<-rbind(sR3.df,temp.df)
- }
- }
- colnames(sR3.df)<-c(colnames(blackbox.output[[1]]),"studyid")
-
- ord.global.val<-order(sR3.df$encrypted.var)
- sR3.df<-sR3.df[ord.global.val,]
- global.rank<-rank(sR3.df$encrypted.var)
- sR3.sort.global.val.df<-data.frame(cbind(sR3.df,global.rank))
-
-
- #CALL CLIENTSIDE FUNCTION ds.dmtC2S TO RETURN df TO SERVERSIDE
- for(ss in 1:3)
- {
- sR4.df<-sR3.sort.global.val.df[sR3.sort.global.val.df$studyid==ss,]
- dsBaseClient::ds.dmtC2S(dfdata=sR4.df,newobj="sR4.df",
- datasources = datasources.in.current.function[ss])
- }
-
- numstudies.df<-data.frame(numstudies)
-
- #CALL CLIENTSIDE FUNCTION ds.dmtC2S TO RETURN numstudies TO SERVERSIDE
- dsBaseClient::ds.dmtC2S(dfdata=numstudies.df,newobj="numstudies.df",
- datasources = datasources.in.current.function)
-
-
- #CALL THE THIRD SERVER SIDE FUNCTION (ASSIGN)
- #SELECTS ENCRYPTED DATA FOR REAL SUBJECTS IN EACH
- #STUDY SPECIFIC sR4.df AND WRITES AS sR5.df ON SERVERSIDE
- calltext3 <- call("ranksSecureDS2")
- DSI::datashield.assign(datasources,"sR5.df",calltext3)
-
- ds.make("sR5.df$global.rank","testvar.ranks")
-
-if(monitor.progress){
- message("\n\nStep 5 of 8 complete:
- Global ranks generated and pseudodata stripped out. Now ready
- to proceed to transformation of global ranks
-
-
- ")
- }
-
- input.ranks.name<-"testvar.ranks"
-
- cally2 <- paste0('quantileMeanDS(', input.ranks.name, ')')
- initialise.input.ranks <- DSI::datashield.aggregate(datasources, as.symbol(cally2))
-
-
- numstudies<-length(initialise.input.ranks)
- numvals<-length(initialise.input.ranks[[1]])
-
- q5.val<-NULL
- q95.val<-NULL
- mean.ranks<-NULL
-
- for(rr in 1:numstudies){
- q5.val<-c(q5.val,initialise.input.ranks[[rr]][1])
- q95.val<-c(q95.val,initialise.input.ranks[[rr]][numvals-1])
- mean.ranks<-c(mean.ranks,initialise.input.ranks[[rr]][numvals])
- }
-
- min.q5<-min(q5.val)
- max.q95<-max(q95.val)
-
- max.sd.input.ranks<-(max.q95-min.q5)/(2*1.65)
- mean.input.ranks<-mean(mean.ranks)
-
- input.ranks.sd.df<-data.frame(cbind(mean.input.ranks,max.sd.input.ranks))
-
-
- #CALL CLIENTSIDE FUNCTION ds.dmtC2S TO RETURN VALUES TO SERVERSIDE
- dsBaseClient::ds.dmtC2S(dfdata=input.ranks.sd.df,newobj="input.ranks.sd.df")
-
-
-
- #CALLS FOURTH SERVER SIDE FUNCTION (ASSIGN)
- #THAT IS A MODIFIED VERSION OF blackBoxDS THAT
- #ENCRYPTS JUST THE RANKS OF THE REAL DATA AND WRITES
- #TO blackbox.ranks.df ON THE SERVERSIDE
- #THIS VERSION (blackBoxDS2) CREATES NO SYNTHETIC DATA TO
- #CONCEAL VALUES
-
-
- calltext4 <- call("blackBoxRanksDS","testvar.ranks",
- shared.seedval=shared.seed.value)
-
- DSI::datashield.assign(datasources, "blackbox.ranks.df", calltext4)
-
-if(monitor.progress){
- message("\n\nStep 6 of 8 complete:
- Rank-consistent transformations of global ranks complete
- and blackbox.ranks.df created
-
-
- ")
- }
-
-
-
- #CALL THE FIFTH SERVER SIDE FUNCTION (AGGREGATE)
- #SEND NON-DISCLOSIVE ELEMENTS OF (ENCRYPTED) DATA IN "blackbox.ranks.df"
- #TO CLIENTSIDE
-
- calltext5 <- call("ranksSecureDS3")
- blackbox.ranks.output<-DSI::datashield.aggregate(datasources, calltext5)
-
- numstudies<-length(blackbox.ranks.output)
-
- sR6.df<-blackbox.ranks.output[[1]]
-
-
- if(numstudies>=1)
- {
- for(ss in 2:numstudies)
- {
- sR6.df<-rbind(sR6.df,blackbox.ranks.output[[ss]])
- }
- }
- sR6.df<-data.frame(sR6.df)
- colnames(sR6.df)<-c(colnames(blackbox.ranks.output[[1]]))
-
-
- #Rank encrypted ranks across all studies
- real.ranks.global<-rank(sR6.df$encrypted.ranks)
- real.quantiles.global<-real.ranks.global/length(real.ranks.global)
- sR7.df<-cbind(sR6.df,real.ranks.global,real.quantiles.global)
- ord.by.real.ranks.global<-order(sR7.df$real.ranks.global)
- sR7.df.by.real.ranks.global<-sR7.df[ord.by.real.ranks.global,]
-
-
-
- #CALL CLIENTSIDE FUNCTION ds.dmtC2S TO RETURN sR7.df TO SERVERSIDE
- for(ss in 1:3)
- {
- sR7.df.study.specific<-sR7.df.by.real.ranks.global[sR7.df.by.real.ranks.global$studyid==ss,]
- dsBaseClient::ds.dmtC2S(dfdata=sR7.df.study.specific,newobj="global.ranks.quantiles.df",
- datasources = datasources.in.current.function[ss])
- }
-
-
-
-
- #CALL THE SIXTH SERVER SIDE FUNCTION (ASSIGN)
- #TAKE ALLOCATED GLOBAL RANKS FROM sR7.df APPEND TO blackbox.ranks.df
- #TO CREATE sR9.df
-
- calltext6 <- call("ranksSecureDS4",ranks.sort.by)
- DSI::datashield.assign(datasources,output.ranks.df,calltext6)
-
-
- calltext7 <- call("ranksSecureDS5", output.ranks.df)
- DSI::datashield.assign(datasources,summary.output.ranks.df, calltext7)
-
- if(monitor.progress){
- message("\n\nStep 7 of 8 complete:
- Final global ranking of values in v2br complete and
- written to each serverside as appropriate
-
-
- ",summary.output.ranks.df)
- }
-
-
-
- #CLEAN UP UNWANTED RESIDUAL OBJECTS FROM THE RUNNING OF ds.ranksSecure
- #EXCEPT FOR OBJECTS CREATED BY ds.extractQuantiles
-
- if(rm.residual.objects)
- {
- #UNLESS THE IS FALSE,
- #CLEAR UP ANY UNWANTED RESIDUAL OBJECTS
-
- rm.names.rS<-c("blackbox.output.df", "blackbox.ranks.df",
- "global.ranks.quantiles.df","input.mean.sd.df", "input.ranks.sd.df",
- output.ranks.df, "min.max.df", "numstudies.df",
- "sR4.df", "sR5.df")
-
- #make transmittable via parser
- rm.names.rS.transmit <- paste(rm.names.rS,collapse=",")
-
- calltext.rm.rS <- call("rmDS", rm.names.rS.transmit)
-
-# rm.output.rS <-
- DSI::datashield.aggregate(datasources, calltext.rm.rS)
-
- }
-
-if(monitor.progress && rm.residual.objects){
- message("\n\nStep 8 of 8 complete:
- Cleaned up residual output from running ds.ranksSecure
-
-
- ")
- }
-
- if(monitor.progress && !rm.residual.objects){
- message("\n\nStep 8 of 8 complete:
- Residual output from running ds.ranksSecure NOT deleted
-
-
- ")
- }
-
-
-
-if(!generate.quantiles){
- message("\n\n\n"," FINAL RANKING PROCEDURES COMPLETE:
- PRIMARY RANKING OUTPUT IS IN DATA FRAME",summary.output.ranks.df,
- "
- WHICH IS SORTED BY",ranks.sort.by," AND HAS BEEN
- WRITTEN TO THE SERVERSIDE\n\n\n\n")
-
- info.message<-"As the argument was set to FALSE no quantiles have been estimated.Please set argument to TRUE if you want to estimate quantiles such as median, quartiles and 90th percentile"
- message("\n\n",info.message,"\n\n")
- return(info.message)
- }
-
-final.quantile.df<-
- ds.extractQuantiles(
- quantiles.for.estimation,
- summary.output.ranks.df,
- ranks.sort.by,
- rm.residual.objects,
- extract.datasources=NULL)
-
- return(final.quantile.df)
-}
-
-##########################################
-#ds.ranksSecure
diff --git a/R/ds.rbind.R b/R/ds.rbind.R
index d0aca96a8..2943312db 100644
--- a/R/ds.rbind.R
+++ b/R/ds.rbind.R
@@ -20,18 +20,17 @@
#' input objects exist and are of an appropriate class.
#' @param force.colnames can be NULL or a vector of characters that
#' specifies column names of the output object.
-#' @param newobj a character string that provides the name for the output variable
-#' that is stored on the data servers. Defaults \code{rbind.newobj}.
+#' @param classConsistencyCheck logical. If TRUE, verifies that each input object has the same class across all studies. Default TRUE.
+#' @param newobj a character string that provides the name for the output variable
+#' that is stored on the data servers. Defaults \code{rbind.newobj}.
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @param notify.of.progress specifies if console output should be produced to indicate
#' progress. Default FALSE.
-#' @return \code{ds.rbind} returns a matrix combining the rows of the
+#' @return \code{ds.rbind} returns a matrix combining the rows of the
#' R objects specified in the function
-#' which is written to the server-side.
-#' It also returns two messages to the client-side with the name of \code{newobj}
-#' that has been created in each data source and \code{DataSHIELD.checks} result.
+#' which is written to the server-side.
#' @examples
#'
#' \dontrun{
@@ -78,20 +77,13 @@
#' }
#'
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
-#'
-ds.rbind<-function(x=NULL, DataSHIELD.checks=FALSE, force.colnames=NULL, newobj=NULL,
- datasources=NULL, notify.of.progress=FALSE){
-
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
+#'
+ds.rbind<-function(x=NULL, DataSHIELD.checks=FALSE, force.colnames=NULL, newobj=NULL,
+ datasources=NULL, notify.of.progress=FALSE, classConsistencyCheck=TRUE){
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide a vector of character strings holding the name of the input elements!", call.=FALSE)
@@ -99,17 +91,16 @@ ds.rbind<-function(x=NULL, DataSHIELD.checks=FALSE, force.colnames=NULL, newobj=
if(DataSHIELD.checks){
-
- # check if the input object(s) is(are) defined in all the studies
- lapply(x, function(k){isDefined(datasources, obj=k)})
# call the internal function that checks the input object(s) is(are) of the same legal class in all studies.
+ if(classConsistencyCheck){
for(i in 1:length(x)){
typ <- checkClass(datasources, x[i])
if(!('data.frame' %in% typ) & !('matrix' %in% typ) & !('factor' %in% typ) & !('character' %in% typ) & !('numeric' %in% typ) & !('integer' %in% typ) & !('logical' %in% typ)){
stop(" Only objects of type 'data.frame', 'matrix', 'numeric', 'integer', 'character', 'factor' and 'logical' are allowed.", call.=FALSE)
}
}
+ }
}
# check newobj not actively declared as null
@@ -195,84 +186,5 @@ for(j in length(colname.vector):2)
calltext <- call("rbindDS", x.names.transmit, colnames.transmit)
DSI::datashield.assign(datasources, newobj, calltext)
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
- #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.rbind
diff --git a/R/ds.reShape.R b/R/ds.reShape.R
index f2214f559..38fa36b5f 100644
--- a/R/ds.reShape.R
+++ b/R/ds.reShape.R
@@ -32,12 +32,10 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.reShape} returns to the server-side a reshaped data frame
-#' converted from 'long' to 'wide' format or from 'wide' to long' format.
-#' Also, two validity messages are returned to the client-side
-#' indicating whether the new object has been created in each data source and if so whether
-#' it is in a valid form.
+#' @return \code{ds.reShape} returns to the server-side a reshaped data frame
+#' converted from 'long' to 'wide' format or from 'wide' to long' format.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -84,15 +82,7 @@
ds.reShape <- function(data.name=NULL, varying=NULL, v.names=NULL, timevar.name="time", idvar.name="id",
drop=NULL, direction=NULL, sep=".", newobj="newObject", datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(data.name)){
stop("Please provide the name of the list that holds the input vectors!", call.=FALSE)
@@ -125,81 +115,5 @@ ds.reShape <- function(data.name=NULL, varying=NULL, v.names=NULL, timevar.name=
calltext <- call("reShapeDS", data.name, varying.transmit, v.names.transmit, timevar.name, idvar.name, drop.transmit, direction, sep)
DSI::datashield.assign(datasources, newobj, calltext)
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.reShape
diff --git a/R/ds.recodeLevels.R b/R/ds.recodeLevels.R
index a22d25b31..32bf30e62 100644
--- a/R/ds.recodeLevels.R
+++ b/R/ds.recodeLevels.R
@@ -19,6 +19,7 @@
#' @return \code{ds.recodeLevels} returns to the server-side a variable of type factor
#' with the replaces levels.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -97,8 +98,8 @@ ds.recodeLevels <- function(x=NULL, newCategories=NULL, newobj=NULL, datasources
}
# get the current number of levels
- cally <- paste0("levelsDS(", x, ")")
- xx <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ cally <- call("levelsDS", x)
+ xx <- DSI::datashield.aggregate(datasources, cally)
all.study.levels <- c()
for (study.levels in xx) {
if (any(is.na(study.levels$Levels)))
diff --git a/R/ds.recodeValues.R b/R/ds.recodeValues.R
index 184ccea2b..c0a52c3d5 100644
--- a/R/ds.recodeValues.R
+++ b/R/ds.recodeValues.R
@@ -24,11 +24,9 @@
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @param notify.of.progress logical. If TRUE console output should be produced to indicate
#' progress. Default FALSE.
-#' @return Assigns to each server a new variable with the recoded values.
-#' Also, two validity messages are returned to the client-side
-#' indicating whether the new object has been created in each data source and if so whether
-#' it is in a valid form.
+#' @return Assigns to each server a new variable with the recoded values.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -81,24 +79,13 @@
ds.recodeValues <- function(var.name=NULL, values2replace.vector=NULL, new.values.vector=NULL,
missing=NULL, newobj=NULL, datasources=NULL, notify.of.progress=FALSE){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check user has provided the name of the variable to be recoded
if(is.null(var.name)){
stop("Please provide the name of the variable to be recoded: eg 'xxx'", call.=FALSE)
}
-
- # check if the input object is defined in all the studies
- isDefined(datasources, var.name)
-
+
# check user has provided the vector specifying the set of values to be replaced
if(is.null(values2replace.vector)){
stop("Please provide a vector in the 'values2replace.vector' argument specifying
@@ -140,81 +127,5 @@ ds.recodeValues <- function(var.name=NULL, values2replace.vector=NULL, new.value
calltext <- call("recodeValuesDS", var.name, values2replace.transmit, new.values.transmit, missing)
DSI::datashield.assign(datasources, newobj, calltext)
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.recodeValues
diff --git a/R/ds.rep.R b/R/ds.rep.R
index 2f3e03010..7874045f4 100644
--- a/R/ds.rep.R
+++ b/R/ds.rep.R
@@ -26,10 +26,7 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.rep} returns in the server-side a vector with the specified repetitive sequence.
-#' Also, two validity messages are returned to the client-side
-#' the name of \code{newobj} that has been created
-#' in each data source and if it is in a valid form.
+#' @return \code{ds.rep} returns in the server-side a vector with the specified repetitive sequence.
#' @examples
#' \dontrun{
#'
@@ -91,22 +88,15 @@
#' }
#'
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
-ds.rep<-function(x1=NULL, times=NA, length.out=NA, each=1,
+ds.rep<-function(x1=NULL, times=NA, length.out=NA, each=1,
source.x1='clientside', source.times=NULL,
source.length.out=NULL,source.each=NULL,
x1.includes.characters=FALSE,newobj=NULL,datasources=NULL){
-
- # if no connection login details are provided look for 'connection' objects in the environment
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if a value has been provided for x1
if(is.null(x1)){
@@ -282,85 +272,6 @@ if(source.each=='s')source.each<-'serverside'
DSI::datashield.assign(datasources, newobj, calltext)
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
}
#ds.rep
diff --git a/R/ds.replaceNA.R b/R/ds.replaceNA.R
index 28a51adb1..0596f2da3 100644
--- a/R/ds.replaceNA.R
+++ b/R/ds.replaceNA.R
@@ -26,6 +26,7 @@
#' with the missing values replaced by the specified values.
#' The class of the vector is the same as the initial vector.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -91,22 +92,11 @@
#'
ds.replaceNA <- function(x=NULL, forNA=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of a vector!", call.=FALSE)
}
-
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
# check if replacement values have been provided
if(is.null(forNA)){
@@ -123,7 +113,7 @@ ds.replaceNA <- function(x=NULL, forNA=NULL, newobj=NULL, datasources=NULL){
# number of missing values stop the process and tell the analyst
cally <- call("numNaDS", x)
numNAs <- DSI::datashield.aggregate(datasources[i], cally)
- if(length(forNA[[i]]) != 1 & length(forNA[[i]]) != numNAs[[1]]){
+ if(length(forNA[[i]]) != 1 & length(forNA[[i]]) != numNAs[[1]]$numNA){
message("The number of replacement values must be of length 1 or of the same length as the number of missing values.")
stop(paste0("This is not the case in ", names(datasources)[i]), call.=FALSE)
}
@@ -136,11 +126,8 @@ ds.replaceNA <- function(x=NULL, forNA=NULL, newobj=NULL, datasources=NULL){
# call the server side function and doo the replacement for each server
for(i in 1:length(datasources)){
message(paste0("--Processing ", names(datasources)[i], "..."))
- cally <- paste0("replaceNaDS(", x, paste0(", vectorDS(",paste(forNA[[i]],collapse=","),")"), ")")
- DSI::datashield.assign(datasources[i], newobj, as.symbol(cally))
-
- # check that the new object has been created and display a message accordingly
- finalcheck <- isAssigned(datasources[i], newobj)
+ cally <- call("replaceNaDS", x, forNA[[i]])
+ DSI::datashield.assign(datasources[i], newobj, cally)
# if the input vector is within a table structure append the new vector to that table
inputElts <- extract(x)
diff --git a/R/ds.rowColCalc.R b/R/ds.rowColCalc.R
index d531cce47..8d0ec804e 100644
--- a/R/ds.rowColCalc.R
+++ b/R/ds.rowColCalc.R
@@ -19,6 +19,7 @@
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
#' @return \code{ds.rowColCalc} returns to the server-side rows and columns sums and means.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#'
@@ -67,58 +68,12 @@
#'
ds.rowColCalc <- function(x=NULL, operation=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of a data.frame or matrix!", call.=FALSE)
}
- # check if the input object(s) is(are) defined in all the studies
- defined <- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
-
- # if the input object is not a matrix or a dataframe stop
- if(!('data.frame' %in% typ) & !('matrix' %in% typ)){
- stop("The input vector must be of type 'data.frame' or a 'matrix'!", call.=FALSE)
- }
-
- # number of studies and their names
- numsources <- length(datasources)
- stdnames <- names(datasources)
-
- # we want to deal only with two dimensional tables
- dim2 <- c()
- for(i in 1:numsources){
- dims <- DSI::datashield.aggregate(datasources[i], call("dimDS", x))
- if(length(dims[[1]]) != 2){
- stop("The input table in ", stdnames[i]," has more than two dimensions. Only strutures of two dimensions are allowed", call.=FALSE)
- }
- dim2 <- append(dim2, dims[[1]][2])
- }
-
- # check that, for each study, all the columns of the input table are of 'numeric' type
- dtname <- x
- for(i in 1:numsources){
- cols <- DSI::datashield.aggregate(datasources[i], call("colnamesDS", x))
- for(j in 1:dim2[i]){
- cally <- call("classDS", paste0(dtname, "$", cols[[1]][j]))
- res <- DSI::datashield.aggregate(datasources[i], cally)
- if(res[[1]] != 'numeric' & res[[1]] != 'integer'){
- stop("One or more columns of ", dtname, " are not of numeric type, in ", stdnames[i], ".", call.=FALSE)
- }
- }
- }
-
ops <- c("rowSums","colSums","rowMeans","colMeans")
if(is.null(operation)){
message(" ALERT!")
@@ -139,10 +94,6 @@ ds.rowColCalc <- function(x=NULL, operation=NULL, newobj=NULL, datasources=NULL)
}
# call the server side function that does the job
- cally <- paste0("rowColCalcDS(", x, ",", indx, ")")
- DSI::datashield.assign(datasources, newobj, as.symbol(cally))
-
- # check that the new object has been created and display a message accordingly
- finalcheck <- isAssigned(datasources, newobj)
+ DSI::datashield.assign(datasources, newobj, call("rowColCalcDS", dataset.name=x, operation=indx))
}
diff --git a/R/ds.sample.R b/R/ds.sample.R
index 9bd6780fb..e52af826c 100644
--- a/R/ds.sample.R
+++ b/R/ds.sample.R
@@ -123,27 +123,14 @@
#' progress. The default value for notify.of.progress is FALSE.
#' @return the object specified by the argument (or default name
#' 'newobj.sample')
-#' which is written to the serverside. In addition, two validity messages are returned
-#' indicating whether has been created in each data source and if so whether
-#' it is in a valid form. If its form is not valid in at least one study - e.g. because
-#' a disclosure trap was tripped and creation of the full output object was blocked -
-#' ds.dataFrameSort() also returns any studysideMessages that may explain the error in creating
-#' the full output object. We are currently working to extend the information that can
-#' be returned to the clientside when an error occurs.
+#' which is written to the serverside.
#' @author Paul Burton, for DataSHIELD Development Team, 15/4/2020
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
ds.sample<-function(x=NULL, size=NULL, seed.as.integer=NULL, replace=FALSE, prob = NULL, newobj=NULL,datasources=NULL, notify.of.progress=FALSE){
- # if no opal login details are provided look for 'opal' objects in the environment
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if a value has been provided for x
if(is.null(x)){
@@ -210,12 +197,10 @@ if(seed.as.text=="NULL"){
message("NO SEED SET IN STUDY",study.id,"\n\n")
}
- calltext <- paste0("setSeedDS(", seed.as.text, ")")
-
if (notify.of.progress)
- message(calltext)
-
- ssDS.obj[[study.id]] <- DSI::datashield.aggregate(datasources[study.id], as.symbol(calltext))
+ message("setSeedDS(", seed.as.text, ")")
+
+ ssDS.obj[[study.id]] <- datashield.aggregate(datasources[study.id], call("setSeedDS", seedtext=seed.as.text))
}
if (notify.of.progress)
message("\n\n")
@@ -232,87 +217,6 @@ calltext <- call("sampleDS", x.transmit=x, size.transmit=size, replace.transmit=
DSI::datashield.assign(datasources, newobj, calltext)
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- #
-#TRACER #
-#return(test.obj.name) #
-#} #
- #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.sample
diff --git a/R/ds.scatterPlot.R b/R/ds.scatterPlot.R
index 55804b3b0..4d9c872db 100644
--- a/R/ds.scatterPlot.R
+++ b/R/ds.scatterPlot.R
@@ -67,9 +67,11 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
+#' @template classConsistencyCheckFalse
#' @return \code{ds.scatterPlot} returns to the client-side one or more scatter
#' plots depending on the argument \code{type}.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -127,7 +129,7 @@
#'
#' }
#'
-ds.scatterPlot <- function(x=NULL, y=NULL, method='deterministic', k=3, noise=0.25, type="split", return.coords=FALSE, datasources=NULL){
+ds.scatterPlot <- function(x=NULL, y=NULL, method='deterministic', k=3, noise=0.25, type="split", return.coords=FALSE, datasources=NULL, classConsistencyCheck=FALSE){
if(is.null(x)){
stop("Please provide the name of the x-variable", call.=FALSE)
@@ -137,38 +139,12 @@ ds.scatterPlot <- function(x=NULL, y=NULL, method='deterministic', k=3, noise=0.
stop("Please provide the name of the y-variable", call.=FALSE)
}
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# Save par and setup reseting of par values
old_par <- graphics::par(no.readonly = TRUE)
on.exit(graphics::par(old_par), add = TRUE)
- # check if the input objects are defined in all the studies
- isDefined(datasources, x)
- isDefined(datasources, y)
-
- # call the internal function that checks the input object(s) is(are) of the same class in all studies.
- typ.x <- checkClass(datasources, x)
- typ.y <- checkClass(datasources, y)
-
- # the input objects must be numeric or integer vectors
- if(!('integer' %in% typ.x) & !('numeric' %in% typ.x)){
- message(paste0(x, " is of type ", typ.x, "!"))
- stop("The input objects must be integer or numeric vectors.", call.=FALSE)
- }
- if(!('integer' %in% typ.y) & !('numeric' %in% typ.y)){
- message(paste0(y, " is of type ", typ.y, "!"))
- stop("The input objects must be integer or numeric vectors.", call.=FALSE)
- }
-
# get the axes labels
xnames <- extract(x)
x.lab <- xnames[[length(xnames)]]
@@ -185,8 +161,11 @@ ds.scatterPlot <- function(x=NULL, y=NULL, method='deterministic', k=3, noise=0.
if(method=='probabilistic'){ method.indicator <- 2 }
# call the server-side function that generates the x and y coordinates of the centroids
- call <- paste0("scatterPlotDS(", x, ",", y, ",", method.indicator, ",", k, ",", noise, ")")
- output <- DSI::datashield.aggregate(datasources, call)
+ output <- datashield.aggregate(datasources, call("scatterPlotDS", x.name=x, y.name=y, method.indicator=method.indicator, k=k, noise=noise))
+ if(classConsistencyCheck){
+ .checkClassConsistency(output, field = "class.x", object_name = x)
+ .checkClassConsistency(output, field = "class.y", object_name = y)
+ }
pooled.points.x <- c()
pooled.points.y <- c()
diff --git a/R/ds.seq.R b/R/ds.seq.R
index d21522a00..1bb958368 100644
--- a/R/ds.seq.R
+++ b/R/ds.seq.R
@@ -58,12 +58,10 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}} objects obtained after login.
#' If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.seq} returns to the server-side the generated sequence.
-#' Also, two validity messages are returned to the client-side
-#' indicating whether the new object has been created in each data source and if so whether
-#' it is in a valid form.
+#' @return \code{ds.seq} returns to the server-side the generated sequence.
#' @author DataSHIELD Development Team
-#' @examples
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
+#' @examples
#' \dontrun{
#'
#' ## Version 6, for version 5 see the Wiki
@@ -119,15 +117,7 @@
ds.seq<-function(FROM.value.char = "1", BY.value.char = "1", TO.value.char=NULL, LENGTH.OUT.value.char = NULL, ALONG.WITH.name=NULL,
newobj="newObj", datasources=NULL) {
###datasources
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
###FROM.value.char
# check FROM.value.char is valid
@@ -191,82 +181,5 @@ if(is.null(TO.value.char)&&is.null(LENGTH.OUT.value.char)&&is.null(ALONG.WITH.na
calltext <- call("seqDS", FROM.value.char,TO.value.char,BY.value.char,LENGTH.OUT.value.char,ALONG.WITH.name)
DSI::datashield.assign(datasources, newobj, calltext)
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.seq
diff --git a/R/ds.setSeed.R b/R/ds.setSeed.R
index ee84a1740..acd73f810 100644
--- a/R/ds.setSeed.R
+++ b/R/ds.setSeed.R
@@ -41,6 +41,7 @@
#' each source and also the integer vector of 626 elements
#' that is \code{.Random.seed itself}.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#' ## Version 6, for version 5 see the Wiki
@@ -86,16 +87,7 @@
#' @export
ds.setSeed<-function(seed.as.integer=NULL,datasources=NULL){
-##################################################################################
-# look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
seed.valid<-0
@@ -116,8 +108,7 @@ mess1<-("ERROR terminated: seed.as.integer must be set as an integer [numeric] o
return(mess1)
}
- calltext <- paste0("setSeedDS(", seed.as.text, ")")
- ssDS.obj <- DSI::datashield.aggregate(datasources, as.symbol(calltext))
+ ssDS.obj <- datashield.aggregate(datasources, call("setSeedDS", seedtext=seed.as.text))
return.message<-paste0("Trigger integer to prime random seed = ",seed.as.text)
diff --git a/R/ds.skewness.R b/R/ds.skewness.R
index 0ef8d93d3..22214612c 100644
--- a/R/ds.skewness.R
+++ b/R/ds.skewness.R
@@ -31,12 +31,14 @@
#' \code{type} can be set as: \code{'combine'}, \code{'split'} or \code{'both'}. For more information
#' see \strong{Details}.
#' The default value is set to \code{'both'}.
+#' @template classConsistencyCheckFalse
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.skewness} returns a matrix showing the skewness of the input numeric variable,
-#' the number of valid observations and the validity message.
+#' @return \code{ds.skewness} returns a matrix showing the skewness of the input numeric variable
+#' and the number of valid observations.
#' @author Demetris Avraam, for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#' ## Version 6, for version 5 see the Wiki
@@ -77,17 +79,9 @@
#' }
#' @export
#'
-ds.skewness <- function(x=NULL, method=1, type='both', datasources=NULL){
-
- # if no opal login details are provided look for 'opal' objects in the environment
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
+ds.skewness <- function(x=NULL, method=1, type='both', datasources=NULL, classConsistencyCheck=FALSE){
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input vector!", call.=FALSE)
@@ -104,26 +98,17 @@ ds.skewness <- function(x=NULL, method=1, type='both', datasources=NULL){
if(type != 'combine' & type != 'split' & type != 'both')
stop('Function argument "type" has to be either "both", "combine" or "split"', call.=FALSE)
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
-
- # the input object must be a numeric or an integer vector
- if(typ != 'integer' & typ != 'numeric'){
- message(paste0(x, " is of type ", typ, "!"))
- stop("The input object must be an integer or numeric vector.", call.=FALSE)
- }
-
if (type=='split' | type=='both'){
calltext.split <- call("skewnessDS1", x, method)
output.split <- DSI::datashield.aggregate(datasources, calltext.split)
- mat.split <- matrix(as.numeric(matrix(unlist(output.split), nrow=length(datasources), byrow=TRUE)[,1:2]),nrow=length(datasources))
- validity <- matrix(unlist(output.split), nrow=length(datasources), byrow=TRUE)[,3]
- mat.split <- data.frame(cbind(mat.split, validity))
+ if(classConsistencyCheck){
+ .checkClassConsistency(output.split)
+ }
+ mat.split <- data.frame(
+ Skewness = sapply(output.split, function(r) r$Skewness),
+ Nvalid = sapply(output.split, function(r) r$Nvalid)
+ )
rownames(mat.split) <- names(output.split)
- colnames(mat.split) <- c('Skewness', 'Nvalid', 'ValidityMessage')
}
if (type=='combine' | type=='both'){
@@ -135,6 +120,9 @@ ds.skewness <- function(x=NULL, method=1, type='both', datasources=NULL){
}else{
calltext.combined <- call("skewnessDS2", x, global.mean)
output.combined <- DSI::datashield.aggregate(datasources, calltext.combined)
+ if(classConsistencyCheck){
+ .checkClassConsistency(output.combined)
+ }
Global.sum.cubes <- 0
Global.sum.squares <- 0
@@ -149,19 +137,15 @@ ds.skewness <- function(x=NULL, method=1, type='both', datasources=NULL){
if(method==1){
Global.skewness <- g1.global
- combinedMessage <- "VALID ANALYSIS"
}
if(method==2){
Global.skewness <- g1.global * sqrt(Global.Nvalid*(Global.Nvalid-1))/(Global.Nvalid-2)
- combinedMessage <- "VALID ANALYSIS"
}
if(method==3){
Global.skewness <- g1.global * ((Global.Nvalid-1)/(Global.Nvalid))^(3/2)
- combinedMessage <- "VALID ANALYSIS"
}
- mat.combined <- data.frame(cbind(Global.skewness, Global.Nvalid, combinedMessage))
+ mat.combined <- data.frame(Skewness = Global.skewness, Nvalid = Global.Nvalid)
rownames(mat.combined) <- 'studiesCombined'
- colnames(mat.combined) <- c('Skewness', 'Nvalid', 'ValidityMessage')
}
}
diff --git a/R/ds.sqrt.R b/R/ds.sqrt.R
index e78011def..3aef21937 100644
--- a/R/ds.sqrt.R
+++ b/R/ds.sqrt.R
@@ -17,6 +17,7 @@
#' the input numeric or integer vector specified in the argument \code{x}. The created vectors
#' are stored in the servers.
#' @author Demetris Avraam for DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -70,41 +71,17 @@
#'
ds.sqrt <- function(x=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input object!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is of the same class in all studies.
- typ <- checkClass(datasources, x)
-
- # call the internal function that checks the input object(s) is(are) of the same class in all studies.
- if(!('numeric' %in% typ) && !('integer' %in% typ)){
- stop("Only objects of type 'numeric' or 'integer' are allowed.", call.=FALSE)
- }
-
- # create a name by default if the user did not provide a name for the new variable
if(is.null(newobj)){
newobj <- "sqrt.newobj"
}
- # call the server side function that does the operation
cally <- call("sqrtDS", x)
DSI::datashield.assign(datasources, newobj, cally)
- # check that the new object has been created and display a message accordingly
- finalcheck <- isAssigned(datasources, newobj)
-
}
diff --git a/R/ds.subsetByClass.R b/R/ds.subsetByClass.R
index b3b14ec27..5470e6148 100644
--- a/R/ds.subsetByClass.R
+++ b/R/ds.subsetByClass.R
@@ -15,6 +15,7 @@
#' the default set of connections will be used: see \link[DSI]{datashield.connections_default}.
#' @return a no data are return to the user but messages are printed out.
#' @author Gaye, A.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @seealso \link{ds.meanByClass} to compute mean and standard deviation across categories of a factor vectors.
#' @seealso \link{ds.subset} to subset by complete cases (i.e. removing missing values), threshold, columns and rows.
#' @export
@@ -91,7 +92,7 @@ ds.subsetByClass <- function(x=NULL, subsets="subClasses", variables=NULL, datas
cols <- DSI::datashield.aggregate(datasources[i], call("colnamesDS", x))
dims <- DSI::datashield.aggregate(datasources[i], call("dimDS", x))
tracker <-c()
- for(j in 1:dims[[1]][2]){
+ for(j in 1:dims[[1]]$dim[2]){
cally <- call("classDS", paste0(dtname, "$", cols[[1]][j]))
res <- DSI::datashield.aggregate(datasources[i], cally)
if(res[[1]] != 'factor'){
diff --git a/R/ds.summary.R b/R/ds.summary.R
index 2d86287b1..3174023a3 100644
--- a/R/ds.summary.R
+++ b/R/ds.summary.R
@@ -19,6 +19,7 @@
#' such as the minimum and maximum values of numeric vectors are not returned.
#' The summary is given for each study separately.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -66,24 +67,13 @@
#'
ds.summary <- function(x=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input vector!", call.=FALSE)
}
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks if the input object is of the same class in all studies.
+ # check the type of x to drive client-side dispatch
typ <- checkClass(datasources, x)
# the input object must be a numeric or an integer vector
@@ -99,11 +89,11 @@ ds.summary <- function(x=NULL, datasources=NULL){
# now get the summary depending on the type of the input variable
if(("data.frame" %in% typ) | ("matrix" %in% typ)){
for(i in 1:numsources){
- validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]]
+ validity <- DSI::datashield.aggregate(datasources[i], call('isValidDS', x))[[1]]$valid
if(validity){
dims <- DSI::datashield.aggregate(datasources[i], call('dimDS', x))
- r <- dims[[1]][1]
- c <- dims[[1]][2]
+ r <- dims[[1]]$dim[1]
+ c <- dims[[1]]$dim[2]
cols <- (DSI::datashield.aggregate(datasources[i], call('colnamesDS', x)))[[1]]
stdsummary <- list('class'=typ, 'number of rows'=r, 'number of columns'=c, 'variables held'=cols)
finalOutput[[i]] <- stdsummary
@@ -116,9 +106,9 @@ ds.summary <- function(x=NULL, datasources=NULL){
if("character" %in% typ){
for(i in 1:numsources){
- validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]]
+ validity <- DSI::datashield.aggregate(datasources[i], call('isValidDS', x))[[1]]$valid
if(validity){
- l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]
+ l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length
stdsummary <- list('class'=typ, 'length'=l)
finalOutput[[i]] <- stdsummary
}else{
@@ -130,10 +120,10 @@ ds.summary <- function(x=NULL, datasources=NULL){
if("factor" %in% typ){
for(i in 1:numsources){
- validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]]
+ validity <- DSI::datashield.aggregate(datasources[i], call('isValidDS', x))[[1]]$valid
if(validity){
- l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]
- levels.resp <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('levelsDS(', x, ')' )))[[1]]
+ l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length
+ levels.resp <- DSI::datashield.aggregate(datasources[i], call('levelsDS', x))[[1]]
categories <- levels.resp$Levels
freq <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('table1DDS(', x, ')' )))[[1]][1]
stdsummary <- list('class'=typ, 'length'=l, 'categories'=categories)
@@ -151,10 +141,10 @@ ds.summary <- function(x=NULL, datasources=NULL){
if(("integer" %in% typ) | ("numeric" %in% typ)){
for(i in 1:numsources){
- validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]]
+ validity <- DSI::datashield.aggregate(datasources[i], call('isValidDS', x))[[1]]$valid
if(validity){
- l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]
- q <- (DSI::datashield.aggregate(datasources[i], as.symbol(paste0('quantileMeanDS(', x, ')' ))))[[1]]
+ l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length
+ q <- (DSI::datashield.aggregate(datasources[i], call('quantileMeanDS', x)))[[1]]$quantiles
stdsummary <- list('class'=typ, 'length'=l, 'quantiles & mean'=q)
finalOutput[[i]] <- stdsummary
}else{
@@ -167,7 +157,7 @@ ds.summary <- function(x=NULL, datasources=NULL){
if("list" %in% typ){
for(i in 1:numsources){
- l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]
+ l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length
elts <- DSI::datashield.aggregate(datasources[i], call('namesDS', x))
if(length(elts) == 0){
elts <- NULL
@@ -186,9 +176,9 @@ ds.summary <- function(x=NULL, datasources=NULL){
if("logical" %in% typ){
for(i in 1:numsources){
- validity <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('isValidDS(', x, ')')))[[1]]
+ validity <- DSI::datashield.aggregate(datasources[i], call('isValidDS', x))[[1]]$valid
if(validity){
- l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]
+ l <- DSI::datashield.aggregate(datasources[i], call('lengthDS', x))[[1]]$length
freq <- DSI::datashield.aggregate(datasources[i], as.symbol(paste0('table1DDS(', x, ')' )))[[1]][1]
stdsummary <- list('class'=typ, 'length'=l)
for(j in 1:length(2)){
diff --git a/R/ds.table.R b/R/ds.table.R
index e1238e2a5..ba6497d08 100644
--- a/R/ds.table.R
+++ b/R/ds.table.R
@@ -183,6 +183,7 @@
#' about the visible material passed to the clientside, and the optional
#' table object written to the serverside can be seen under 'details' (above).
#' @author Paul Burton and Alex Westerberg for DataSHIELD Development Team, 01/05/2020
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.table <- function(rvar=NULL, cvar=NULL, stvar=NULL, report.chisq.tests=FALSE,
@@ -190,40 +191,21 @@ ds.table <- function(rvar=NULL, cvar=NULL, stvar=NULL, report.chisq.tests=FALSE,
table.assign=FALSE, newobj=NULL, datasources=NULL,
force.nfilter=NULL){
- # if no connection login details are provided look for 'connection' objects in the environment
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
# check if a value has been provided for rvar
if(is.null(rvar)){
return("Error: rvar must have a value which is a character string naming the row variable for the table")
}
- # check if the input object is defined in all the studies
- isDefined(datasources, rvar)
-
if(!is.null(cvar)&&!is.character(cvar)){
return("Error: if cvar is not null, it must have a value which is a character string naming the column variable for the table")
}
- if(!is.null(cvar)){
- isDefined(datasources, cvar)
- }
-
if(!is.null(stvar)&&!is.character(stvar)){
return("Error: if stvar is not null, it must have a value which is a character string naming the variable coding separate tables for the table")
}
- if(!is.null(stvar)){
- isDefined(datasources, stvar)
- }
-
if(useNA!="no" && useNA!="always"){
stop("useNA must be either 'no' or 'always'.")
}
diff --git a/R/ds.tapply.R b/R/ds.tapply.R
index e9805e1d5..3972bf839 100644
--- a/R/ds.tapply.R
+++ b/R/ds.tapply.R
@@ -120,19 +120,12 @@
#'
#' }
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
ds.tapply <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, datasources=NULL){
###datasources
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
###X.name
# check if user has provided the name of the column that holds X.name
@@ -140,9 +133,6 @@ ds.tapply <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, datasources=
return("Error: Please provide the name of the variable to be summarized, as a character string")
}
- # check if the X object is defined in all the studies
- isDefined(datasources, X.name)
-
###INDEX.names
# check if user has provided the name of the column(s) that holds INDEX.names
if(is.null(INDEX.names)){
@@ -157,11 +147,6 @@ ds.tapply <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, datasources=
stop("The 'INDEX.names' can include the names of up to two factors", call.=FALSE)
}
- # check if the INDEX objects are defined in all the studies
- for(i in 1:length(INDEX.names)){
- isDefined(datasources, INDEX.names[i])
- }
-
# make INDEX.names transmitable
if(!is.null(INDEX.names)){
INDEX.names.transmit <- paste(INDEX.names, collapse=",")
diff --git a/R/ds.tapply.assign.R b/R/ds.tapply.assign.R
index be7b74081..5e2ac52fd 100644
--- a/R/ds.tapply.assign.R
+++ b/R/ds.tapply.assign.R
@@ -77,6 +77,7 @@
#' The array is written to the server-side. It has the same number of
#' dimensions as INDEX.
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @examples
#' \dontrun{
#' ## Version 6, for version 5 see the Wiki
@@ -129,15 +130,7 @@
ds.tapply.assign <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, newobj=NULL, datasources=NULL){
###datasources
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
###X.name
# check if user has provided the name of the column that holds X.name
@@ -145,9 +138,6 @@ ds.tapply.assign <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, newob
return("Error: Please provide the name of the variable to be summarized, as a character string")
}
- # check if the X object is defined in all the studies
- isDefined(datasources, X.name)
-
###INDEX.names
# check if user has provided the name of the column(s) that holds INDEX.names
if(is.null(INDEX.names)){
@@ -162,11 +152,6 @@ ds.tapply.assign <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, newob
stop("The 'INDEX.names' can include the names of up to two factors", call.=FALSE)
}
- # check if the INDEX objects are defined in all the studies
- for(i in 1:length(INDEX.names)){
- isDefined(datasources, INDEX.names[i])
- }
-
# make INDEX.names transmitable
if(!is.null(INDEX.names)){
INDEX.names.transmit <- paste(INDEX.names, collapse=",")
@@ -190,83 +175,5 @@ ds.tapply.assign <- function(X.name=NULL, INDEX.names=NULL, FUN.name=NULL, newob
DSI::datashield.assign(datasources, newobj, calltext)
- #############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj #
- # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
-
-
}
#ds.tapply.assign
diff --git a/R/ds.unList.R b/R/ds.unList.R
index fa14a4f24..9af30d6b9 100644
--- a/R/ds.unList.R
+++ b/R/ds.unList.R
@@ -21,12 +21,10 @@
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
-#' @return \code{ds.unList} returns to the server-side the unlist object.
-#' Also, two validity messages are returned to the client-side
-#' indicating whether the new object has been created in each data source and if so whether
-#' it is in a valid form.
+#' @return \code{ds.unList} returns to the server-side the unlist object.
#' @author DataSHIELD Development Team
-#' @examples
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
+#' @examples
#' \dontrun{
#' ## Version 6, for version 5 see the Wiki
#'
@@ -72,15 +70,7 @@
#' @export
ds.unList <- function(x.name=NULL, newobj=NULL, datasources=NULL){
- # look for DS connections
- if(is.null(datasources)){
- datasources <- datashield.connections_find()
- }
-
- # ensure datasources is a list of DSConnection-class
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE)
- }
+ datasources <- .set_datasources(datasources)
if(is.null(x.name)){
stop("Please provide the name of the input vector!", call.=FALSE)
@@ -96,82 +86,6 @@ ds.unList <- function(x.name=NULL, newobj=NULL, datasources=NULL){
calltext <- call("unListDS", x.name)
DSI::datashield.assign(datasources, newobj, calltext)
-
-#############################################################################################################
-#DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED #
- #
-#SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION #
-test.obj.name<-newobj # # #
- #
-# CALL SEVERSIDE FUNCTION #
-calltext <- call("testObjExistsDS", test.obj.name) #
- #
-object.info<-DSI::datashield.aggregate(datasources, calltext) #
- #
-# CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS #
-# AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS #
-num.datasources<-length(object.info) #
- #
- #
-obj.name.exists.in.all.sources<-TRUE #
-obj.non.null.in.all.sources<-TRUE #
- #
-for(j in 1:num.datasources){ #
- if(!object.info[[j]]$test.obj.exists){ #
- obj.name.exists.in.all.sources<-FALSE #
- } #
- if(is.null(object.info[[j]]$test.obj.class) || ("ABSENT" %in% object.info[[j]]$test.obj.class)){ #
- obj.non.null.in.all.sources<-FALSE #
- } #
- } #
- #
-if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){ #
- #
- return.message<- #
- paste0("A data object <", test.obj.name, "> has been created in all specified data sources") #
- #
- #
- }else{ #
- #
- return.message.1<- #
- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources") #
- #
- return.message.2<- #
- paste0("It is either ABSENT and/or has no valid content/class,see return.info above") #
- #
- return.message.3<- #
- paste0("Please use ds.ls() to identify where missing") #
- #
- #
- return.message<-list(return.message.1,return.message.2,return.message.3) #
- #
- } #
- #
- calltext <- call("messageDS", test.obj.name) #
- studyside.message<-DSI::datashield.aggregate(datasources, calltext) #
- #
- no.errors<-TRUE #
- for(nd in 1:num.datasources){ #
- if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){ #
- no.errors<-FALSE #
- } #
- } #
- #
- #
- if(no.errors){ #
- validity.check<-paste0("<",test.obj.name, "> appears valid in all sources") #
- return(list(is.object.created=return.message,validity.check=validity.check)) #
- } #
- #
-if(!no.errors){ #
- validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:") #
- return(list(is.object.created=return.message,validity.check=validity.check, #
- studyside.messages=studyside.message)) #
- } #
- #
-#END OF CHECK OBJECT CREATED CORECTLY MODULE #
-#############################################################################################################
-
}
#ds.unList
diff --git a/R/ds.unique.R b/R/ds.unique.R
index 8f2717054..dd8e5e532 100644
--- a/R/ds.unique.R
+++ b/R/ds.unique.R
@@ -43,32 +43,22 @@
#' datashield.logout(connections)
#' }
#' @author Stuart Wheater, DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#'
ds.unique <- function(x.name = NULL, newobj = NULL, datasources = NULL) {
- # look for DS connections
- if (is.null(datasources)) {
- datasources <- datashield.connections_find()
- }
- # ensure datasources is a list of DSConnection-class
- if (!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))) {
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call. = FALSE)
- }
+ datasources <- .set_datasources(datasources)
if (is.null(x.name)) {
stop("x.name=NULL. Please provide the names of the objects to de-duplicated!", call. = FALSE)
}
- # create a name by default if user did not provide a name for the new variable
if (is.null(newobj)) {
newobj <- "unique.newobj"
}
- # call the server side function that does the job
cally <- call('uniqueDS', x.name)
DSI::datashield.assign(datasources, newobj, cally)
- # check that the new object has been created and display a message accordingly
- finalcheck <- isAssigned(datasources, newobj)
}
diff --git a/R/ds.var.R b/R/ds.var.R
index 178dc4436..fcf204956 100644
--- a/R/ds.var.R
+++ b/R/ds.var.R
@@ -19,10 +19,7 @@
#' \code{'split'}, \code{'splits'}, \code{'s'},
#' \code{'both'} or \code{'b'}.
#' For more information see \strong{Details}.
-#' @param checks logical. If TRUE optional checks of model
-#' components will be undertaken. Default is FALSE to save time.
-#' It is suggested that checks
-#' should only be undertaken once the function call has failed.
+#' @template classConsistencyCheckFalse
#' @param datasources a list of \code{\link[DSI]{DSConnection-class}}
#' objects obtained after login. If the \code{datasources} argument is not specified
#' the default set of connections will be used: see \code{\link[DSI]{datashield.connections_default}}.
@@ -35,8 +32,8 @@
#' \code{Global.Variance}: estimated variance, \code{Nmissing}, \code{Nvalid} and \code{Ntotal}
#' across all studies combined (if \code{type = combine} or \code{type = both}). \cr
#' \code{Nstudies}: number of studies being analysed. \cr
-#' \code{ValidityMessage}: indicates if the analysis was possible. \cr
#' @author DataSHIELD Development Team
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#' @export
#' @examples
#' \dontrun{
@@ -70,49 +67,19 @@
#'
#' ds.var(x = "D$LAB_TSC",
#' type = "split",
-#' checks = FALSE,
#' datasources = connections)
#'
#' # clear the Datashield R sessions and logout
#' datashield.logout(connections)
#' }
#'
-ds.var <- function(x=NULL, type='split', checks=FALSE, datasources=NULL){
-
- #################################################################################################################
- #MODULE 1: IDENTIFY DEFAULT CONNECTIONS #
- # look for DS connections #
- if(is.null(datasources)){ #
- datasources <- datashield.connections_find() #
- } #
- #
- # ensure datasources is a list of DSConnection-class #
- if(!(is.list(datasources) && all(unlist(lapply(datasources, function(d) {methods::is(d,"DSConnection")}))))){ #
- stop("The 'datasources' were expected to be a list of DSConnection-class objects", call.=FALSE) #
- } #
- #################################################################################################################
+ds.var <- function(x=NULL, type='split', datasources=NULL, classConsistencyCheck=FALSE){
+
+ datasources <- .set_datasources(datasources)
if(is.null(x)){
stop("Please provide the name of the input object!", call.=FALSE)
}
-
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # beginning of optional checks - the process stops and reports as soon as one check fails
- if(checks){
-
- # check if the input object is defined in all the studies
- isDefined(datasources, x)
-
- # call the internal function that checks the input object is suitable in all studies #
- varClass <- checkClass(datasources, x) #
- # the input object must be a numeric or an integer vector #
- if(!('integer' %in% varClass) & !('numeric' %in% varClass)){ #
- stop("The input object must be an integer or a numeric vector.", call.=FALSE) #
- } #
- } #
- ###############################################################################################
###################################################################################################
#MODULE: EXTEND "type" argument to include "both" and enable valid alisases #
@@ -123,8 +90,12 @@ ds.var <- function(x=NULL, type='split', checks=FALSE, datasources=NULL){
#MODIFY FUNCTION CODE TO DEAL WITH ALL THREE TYPES #
###################################################################################################
- cally <- paste0("varDS(", x, ")")
- ss.obj <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ cally <- call("varDS", x)
+ ss.obj <- DSI::datashield.aggregate(datasources, cally)
+
+ if(classConsistencyCheck){
+ .checkClassConsistency(ss.obj)
+ }
Nstudies <- length(datasources)
EstimatedVar <- c()
@@ -132,26 +103,23 @@ ds.var <- function(x=NULL, type='split', checks=FALSE, datasources=NULL){
Nmissing <- c()
Ntotal <- c()
for (i in 1:Nstudies){
- EstimatedVar[i] <- ss.obj[[i]][[2]]/(ss.obj[[i]][[4]]-1) - (ss.obj[[i]][[1]])^2/(ss.obj[[i]][[4]]*(ss.obj[[i]][[4]]-1))
- Nvalid[i] <- as.numeric(ss.obj[[i]][[4]])
- Nmissing[i] <- as.numeric(ss.obj[[i]][[3]])
- Ntotal[i] <- as.numeric(ss.obj[[i]][[5]])
+ EstimatedVar[i] <- ss.obj[[i]]$SumOfSquares/(ss.obj[[i]]$Nvalid-1) - (ss.obj[[i]]$Sum)^2/(ss.obj[[i]]$Nvalid*(ss.obj[[i]]$Nvalid-1))
+ Nvalid[i] <- ss.obj[[i]]$Nvalid
+ Nmissing[i] <- ss.obj[[i]]$Nmissing
+ Ntotal[i] <- ss.obj[[i]]$Ntotal
}
ss.mat <- matrix(c(EstimatedVar,Nmissing,Nvalid,Ntotal),nrow=Nstudies)
dimnames(ss.mat) <- c(list(names(ss.obj),c('EstimatedVar','Nmissing','Nvalid','Ntotal')))
- ValidityMessage.mat <- matrix(matrix(unlist(ss.obj),nrow=Nstudies,byrow=TRUE)[,6],nrow=Nstudies)
- dimnames(ValidityMessage.mat) <- c(list(names(ss.obj),names(ss.obj[[1]])[6]))
-
ss.mat.combined <- t(matrix(ss.mat[1,]))
GlobalSum.new <- 0
GlobalSumSquares.new <- 0
GlobalNvalid.new <- 0
for (i in 1:Nstudies){
- GlobalSum <- GlobalSum.new + ss.obj[[i]][[1]]
- GlobalSumSquares <- GlobalSumSquares.new + ss.obj[[i]][[2]]
- GlobalNvalid <- GlobalNvalid.new + ss.obj[[i]][[4]]
+ GlobalSum <- GlobalSum.new + ss.obj[[i]]$Sum
+ GlobalSumSquares <- GlobalSumSquares.new + ss.obj[[i]]$SumOfSquares
+ GlobalNvalid <- GlobalNvalid.new + ss.obj[[i]]$Nvalid
GlobalSum.new <- GlobalSum
GlobalSumSquares.new <- GlobalSumSquares
GlobalNvalid.new <- GlobalNvalid
@@ -171,15 +139,15 @@ ds.var <- function(x=NULL, type='split', checks=FALSE, datasources=NULL){
#PRIMARY FUNCTION OUTPUT SUMMARISE RESULTS FROM
#AGGREGATE FUNCTION AND RETURN TO CLIENT-SIDE
if (type=='split'){
- return(list(Variance.by.Study=ss.mat,Nstudies=Nstudies,ValidityMessage=ValidityMessage.mat))
+ return(list(Variance.by.Study=ss.mat,Nstudies=Nstudies))
}
if (type=="combine"){
- return(list(Global.Variance=ss.mat.combined,Nstudies=Nstudies,ValidityMessage=ValidityMessage.mat))
+ return(list(Global.Variance=ss.mat.combined,Nstudies=Nstudies))
}
if (type=="both"){
- return(list(Variance.by.Study=ss.mat,Global.Variance=ss.mat.combined,Nstudies=Nstudies,ValidityMessage=ValidityMessage.mat))
+ return(list(Variance.by.Study=ss.mat,Global.Variance=ss.mat.combined,Nstudies=Nstudies))
}
}
diff --git a/R/getPooledMean.R b/R/getPooledMean.R
index dba45bf30..703ed3f15 100644
--- a/R/getPooledMean.R
+++ b/R/getPooledMean.R
@@ -14,8 +14,8 @@ getPooledMean <- function(dtsources, x){
num.sources <- length(dtsources)
- cally <- paste0("meanDS(", x, ")")
- out.mean <- DSI::datashield.aggregate(dtsources, as.symbol(cally))
+ cally <- call("meanDS", x)
+ out.mean <- DSI::datashield.aggregate(dtsources, cally)
length.total <- 0
sum.weighted <- 0
diff --git a/R/getPooledVar.R b/R/getPooledVar.R
index 0738d4bf5..9b460de85 100644
--- a/R/getPooledVar.R
+++ b/R/getPooledVar.R
@@ -14,8 +14,8 @@ getPooledVar <- function(dtsources, x){
num.sources <- length(dtsources)
- cally <- paste0("varDS(", x, ")")
- out.var <- DSI::datashield.aggregate(dtsources, as.symbol(cally))
+ cally <- call("varDS", x)
+ out.var <- DSI::datashield.aggregate(dtsources, cally)
length.total <- 0
sum.weighted <- 0
diff --git a/R/glmChecks.R b/R/glmChecks.R
index 6dcfe2ee7..152b80bf9 100644
--- a/R/glmChecks.R
+++ b/R/glmChecks.R
@@ -17,6 +17,7 @@
#' @keywords internal
#' @return an integer 0 if check was passed and 1 if failed
#' @author Gaye, A.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#'
glmChecks <- function(formula, data, offset, weights, datasources){
@@ -71,7 +72,7 @@ glmChecks <- function(formula, data, offset, weights, datasources){
if(!(myterms[2] %in% clnames)){
stop(paste0("'", myterms[2], "' is not defined in ", stdnames[j], "!"), call.=FALSE)
}else{
- call0 <- paste0("isNaDS(", elts[i], ")")
+ call0 <- call("isNaDS", elts[i])
if(varIdentifier[i] == "offset" | varIdentifier[i] == "weights"){ typ <- checkClass(datasources, elts[i]) }
if(varIdentifier[i] == "weights"){ call1 <- paste0("checkNegValueDS(", elts[i], ")") }
}
@@ -82,24 +83,24 @@ glmChecks <- function(formula, data, offset, weights, datasources){
clnames <- unlist(DSI::datashield.aggregate(datasources[j], cally))
if(!(elts[i] %in% clnames)){
dd <- isDefined(datasources, elts[i])
- call0 <- paste0("isNaDS(", elts[i], ")")
+ call0 <- call("isNaDS", elts[i])
if(varIdentifier[i] == "offset" | varIdentifier[i] == "weights"){ typ <- checkClass(datasources, elts[i]) }
if(varIdentifier[i] == "weights"){ call1 <- paste0("checkNegValueDS(", elts[i], ")") }
}else{
- call0 <- paste0("isNaDS(", paste0(data, "$", elts[i]), ")")
+ call0 <- call("isNaDS", paste0(data, "$", elts[i]))
if(varIdentifier[i] == "offset" | varIdentifier[i] == "weights"){ typ <- checkClass(datasources, paste0(data, "$", elts[i])) }
if(varIdentifier[i] == "weights"){ call1 <- paste0("checkNegValueDS(", paste0(data, "$", elts[i]), ")") }
}
}else{
defined <- isDefined(datasources, elts[i])
- call0 <- paste0("isNaDS(", elts[i], ")")
+ call0 <- call("isNaDS", elts[i])
if(varIdentifier[i] == "offset" | varIdentifier[i] == "weights"){ typ <- checkClass(datasources, elts[i]) }
if(varIdentifier[i] == "weights"){ call1 <- paste0("checkNegValueDS(", elts[i], ")") }
}
}
# check if variable is not missing at complete
- out1 <- DSI::datashield.aggregate(datasources[j], as.symbol(call0))
- if(out1[[1]]){
+ out1 <- DSI::datashield.aggregate(datasources[j], call0)
+ if(out1[[1]]$is.na){
stop("The variable ", elts[i], " in ", stdnames[j], " is missing at complete (all values are 'NA').", call.=FALSE)
}
# if offset and or weights are set check they are numeric and for weights that it does not hold negative value
diff --git a/R/meanByClassHelper0b.R b/R/meanByClassHelper0b.R
index 89c1c17d6..0c37b9e43 100644
--- a/R/meanByClassHelper0b.R
+++ b/R/meanByClassHelper0b.R
@@ -15,6 +15,7 @@
#' and standard deviation in each subgroup (subset).
#' @keywords internal
#' @author Gaye, A.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#'
meanByClassHelper0b <- function(x, outvar, covar, type, datasources){
if(is.null(outvar)){
@@ -32,14 +33,14 @@ meanByClassHelper0b <- function(x, outvar, covar, type, datasources){
# categories in each of the categorical variables
classes <- vector("list", length(covar))
for(i in 1:length(covar)){
- cally <- paste0("levelsDS(",paste0(x, '$', covar[i]), ")")
+ cally <- call("levelsDS", paste0(x, '$', covar[i]))
all.study.levels <- list()
- full.levels.resp <- DSI::datashield.aggregate(datasources, as.symbol(cally))
+ full.levels.resp <- DSI::datashield.aggregate(datasources, cally)
for (index in 1:length(full.levels.resp)) {
- if (any(is.na(full.levels.resp[[i]]$Levels)))
- stop(paste0("Failed to get levels from study: ", full.levels.resp[[i]]$ValidityMessage), call.=FALSE)
- all.study.levels[[index]] <- full.levels.resp[[i]]$Levels
+ if (any(is.na(full.levels.resp[[index]]$Levels)))
+ stop(paste0("Failed to get levels from study"), call.=FALSE)
+ all.study.levels[[index]] <- full.levels.resp[[index]]$Levels
}
classes[[i]] <- all.study.levels
}
diff --git a/R/meanByClassHelper2.R b/R/meanByClassHelper2.R
index 55dca1c33..aa7667ba0 100644
--- a/R/meanByClassHelper2.R
+++ b/R/meanByClassHelper2.R
@@ -12,6 +12,7 @@
#' @return a matrix, a table which contains the length, mean and standard deviation of each of the
#' specified 'variables' in each subset table.
#' @author Gaye, A.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#'
meanByClassHelper2 <- function(dtsources, tablenames, variables, invalidrecorder){
numtables <- length(tablenames[[1]])
@@ -43,8 +44,8 @@ meanByClassHelper2 <- function(dtsources, tablenames, variables, invalidrecorder
def <- unlist(DSI::datashield.aggregate(dtsources[qq], cally))
if(def){
cally <- call("dimDS", tnames[[qq]][i])
- temp <- unlist(DSI::datashield.aggregate(dtsources[qq], cally))
- lengths <- append(lengths, temp[1])
+ temp <- DSI::datashield.aggregate(dtsources[qq], cally)
+ lengths <- append(lengths, temp[[1]]$dim[1])
}else{
lengths <- append(lengths, 0)
}
@@ -66,8 +67,8 @@ meanByClassHelper2 <- function(dtsources, tablenames, variables, invalidrecorder
}
}else{
cally <- call("lengthDS", paste0(tablename,'$',variables[z]))
- lengths <- DSI::datashield.aggregate(dtsources, cally)
- ll <- sum(unlist(lengths))
+ lengths.raw <- DSI::datashield.aggregate(dtsources, cally)
+ ll <- sum(sapply(lengths.raw, function(r) r$length))
mm <- round(getPooledMean(dtsources, paste0(tablename,'$',variables[z])),2)
sdv <- round(getPooledVar(dtsources, paste0(tablename,'$',variables[z])),2)
if(is.na(mm)){ sdv <- NA}
diff --git a/R/meanByClassHelper3.R b/R/meanByClassHelper3.R
index 4c834b78a..3c753776c 100644
--- a/R/meanByClassHelper3.R
+++ b/R/meanByClassHelper3.R
@@ -11,6 +11,7 @@
#' @keywords internal
#' @return a list which one results table for each study.
#' @author Gaye, A.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
#'
meanByClassHelper3 <- function(dtsources, tablenames, variables, invalidrecorder){
numtables <- length(tablenames[[1]])
@@ -36,14 +37,14 @@ meanByClassHelper3 <- function(dtsources, tablenames, variables, invalidrecorder
if(length(rc) > 0){
cally <- call("lengthDS", paste0(tablenames[[s]][i],'$',variables[z]))
- ll <- unlist(DSI::datashield.aggregate(dtsources[s], cally))
+ ll <- DSI::datashield.aggregate(dtsources[s], cally)[[1]]$length
mm <- NA
sdv <- NA
mean.sd <- paste0(mm, '(', sdv, ')')
entries <- c(ll, mean.sd)
}else{
cally <- call("lengthDS", paste0(tablenames[[s]][i],'$',variables[z]))
- ll <- unlist(DSI::datashield.aggregate(dtsources[s], cally))
+ ll <- DSI::datashield.aggregate(dtsources[s], cally)[[1]]$length
mm <- round(getPooledMean(dtsources[s], paste0(tablenames[[s]][i],'$',variables[z])),2)
sdv <- round(getPooledVar(dtsources[s], paste0(tablenames[[s]][i],'$',variables[z])),2)
if(is.na(mm)){ sdv <- NA }
diff --git a/R/subsetHelper.R b/R/subsetHelper.R
index 025a06803..62648552c 100644
--- a/R/subsetHelper.R
+++ b/R/subsetHelper.R
@@ -61,13 +61,13 @@ subsetHelper <- function(dts, data, rs=NULL, cs=NULL){
fail <- c(0,0)
if(!(is.null(rs))){
- if(length(rs) > dims[[1]][1] ){
+ if(length(rs) > dims[[1]]$dim[1] ){
fail[1] <- 1
}
}
if(!(is.null(cs))){
- if(length(cs) > dims[[1]][2]){
+ if(length(cs) > dims[[1]]$dim[2]){
fail[2] <- 1
}
}
diff --git a/R/utils.R b/R/utils.R
new file mode 100644
index 000000000..db6ac35d4
--- /dev/null
+++ b/R/utils.R
@@ -0,0 +1,137 @@
+#' Retrieve datasources if not specified
+#'
+#' @param datasources An optional list of data sources. If not provided, the function will attempt
+#' to find available data sources.
+#' @importFrom DSI datashield.connections_find
+#' @return A list of data sources.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
+#' @noRd
+.get_datasources <- function(datasources) {
+ if (is.null(datasources)) {
+ datasources <- datashield.connections_find()
+ }
+ return(datasources)
+}
+
+#' Verify that the provided data sources are of class 'DSConnection'.
+#'
+#' @param datasources A list of data sources.
+#' @importFrom cli cli_abort
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
+#' @noRd
+.verify_datasources <- function(datasources) {
+ is_connection_class <- sapply(datasources, function(x) inherits(unlist(x), "DSConnection"))
+ if (!all(is_connection_class)) {
+ cli_abort("The 'datasources' were expected to be a list of DSConnection-class objects")
+ }
+}
+
+#' Set and verify data sources.
+#'
+#' @param datasources An optional list of data sources. If not provided, the function will attempt
+#' to find available data sources.
+#' @return A list of verified data sources.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
+#' @noRd
+.set_datasources <- function(datasources) {
+ datasources <- .get_datasources(datasources)
+ .verify_datasources(datasources)
+ return(datasources)
+}
+
+#' Check cross-study class consistency from a list of server aggregate results
+#'
+#' Batch-refactored server functions return a list per study that includes one
+#' or more class fields. This helper verifies that the chosen field is identical
+#' across all studies and aborts if not.
+#'
+#' @param results A named list of server-side aggregate results, one per study,
+#' each containing the class field named by `field`.
+#' @param field The name of the element holding the class. Default `"class"`.
+#' @param object_name Optional name of the input object, used to make the error
+#' message specific. If `NULL` a generic message is used.
+#' @importFrom cli cli_abort
+#' @return Invisibly returns `NULL`. Called for its side effect (error checking).
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
+#' @noRd
+.checkClassConsistency <- function(results, field = "class", object_name = NULL) {
+ classes <- lapply(results, function(r) r[[field]])
+ if (length(unique(lapply(classes, sort))) > 1) {
+ subject <- if (is.null(object_name)) "The input object" else paste0("'", object_name, "'")
+ cli_abort("{subject} is not of the same class in all studies!")
+ }
+}
+
+#' Check That a New Object Name Is Valid
+#'
+#' Internal helper that checks whether the name supplied for a server-side
+#' output object is a single character string. If not, it aborts with a
+#' user-friendly error.
+#'
+#' @param newobj A character string naming the object to be created server-side.
+#' @importFrom cli cli_abort
+#' @return Invisibly returns `NULL`. Called for its side effect (error checking).
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
+#' @noRd
+.check_newobj_name <- function(newobj) {
+ if (!is.character(newobj) || length(newobj) != 1) {
+ cli_abort("'newobj' must be a single character string")
+ }
+}
+
+#' Set and verify the name of a server-side output object.
+#'
+#' Applies the function's default name when `newobj` is `NULL`, then checks the
+#' result is a single character string. The default must be applied first, since
+#' `NULL` is a valid input meaning "use the default".
+#'
+#' @param newobj A character string naming the object to be created server-side,
+#' or `NULL` to use `default`.
+#' @param default The name to use when `newobj` is `NULL`.
+#' @return A validated, single character string.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
+#' @noRd
+.set_newobj_name <- function(newobj, default) {
+ if (is.null(newobj)) {
+ newobj <- default
+ }
+ .check_newobj_name(newobj)
+ return(newobj)
+}
+
+#' Check That a Data Frame Name Is Provided
+#'
+#' Internal helper that checks whether a data frame or matrix object
+#' has been provided. If `NULL`, it aborts with a user-friendly error.
+#'
+#' @param df A data.frame or matrix.
+#' @return Invisibly returns `NULL`. Called for its side effect (error checking).
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
+#' @noRd
+.check_df_name_provided <- function(df) {
+ if(is.null(df)){
+ cli_abort("Please provide the name of a data.frame or matrix!")
+ }
+}
+
+#' Expand an Argument to One Value per Study
+#'
+#' Arguments that may differ between studies can be given either as a single
+#' value, used for every study, or as a vector with one value per study.
+#'
+#' @param values A vector of length 1 or `num_studies`.
+#' @param arg_name The name of the argument, used in the error message.
+#' @param num_studies The number of studies being analysed.
+#' @importFrom cli cli_abort
+#' @return A vector of length `num_studies`.
+#' @author Tim Cadman, Genomics Coordination Centre, UMCG, Netherlands
+#' @noRd
+.expand_to_studies <- function(values, arg_name, num_studies) {
+ if (length(values) == 1) {
+ return(rep(values, num_studies))
+ }
+ if (length(values) != num_studies) {
+ cli_abort("'{arg_name}' must be length 1 or one value per study")
+ }
+ return(values)
+}
diff --git a/README.md b/README.md
index 616c30dcd..721593bd1 100644
--- a/README.md
+++ b/README.md
@@ -12,7 +12,7 @@ You can install the released version of dsBaseClient from
[CRAN](https://cran.r-project.org/package=dsBaseClient) with:
``` r
-install.packages("dsBaseClient")
+install.packages("dsBaseClient")
```
And the development version from
@@ -23,8 +23,8 @@ And the development version from
install.packages("remotes")
remotes::install_github("datashield/dsBaseClient", "")
-# Install v6.3.5 with the following
-remotes::install_github("datashield/dsBaseClient", "6.3.5")
+# Install v7.0.0 with the following
+remotes::install_github("datashield/dsBaseClient", "7.0.0")
```
For a full list of development branches, checkout https://github.com/datashield/dsBaseClient/branches
diff --git a/_pkgdown.yml b/_pkgdown.yml
index f46c2ebc7..bcec450b1 100644
--- a/_pkgdown.yml
+++ b/_pkgdown.yml
@@ -1,4 +1,5 @@
template:
+ bootstrap: 5
lang: en-GB
params:
bootswatch: simplex
diff --git a/armadillo_azure-pipelines.yml b/armadillo_azure-pipelines.yml
index 4ff1f497d..edcb04401 100644
--- a/armadillo_azure-pipelines.yml
+++ b/armadillo_azure-pipelines.yml
@@ -34,6 +34,7 @@ variables:
branchName: $(Build.SourceBranchName)
test_filter: '*'
_r_check_system_clock_: 0
+ perf.profile: 'azure-pipeline'
#########################################################################################
@@ -58,10 +59,10 @@ schedules:
- master
always: true
- cron: "0 2 * * *"
- displayName: Nightly build - v6.3.5-dev
+ displayName: Nightly build - v7.0-dev
branches:
include:
- - v6.3.5-dev
+ - v7.0-dev
always: true
#########################################################################################
@@ -132,12 +133,13 @@ jobs:
sudo apt-get upgrade -y
sudo apt-get install -qq libxml2-dev libcurl4-openssl-dev libssl-dev libgsl-dev libgit2-dev r-base -y
- sudo apt-get install -qq libharfbuzz-dev libfribidi-dev libmagick++-dev libudunits2-dev -y
- sudo R -q -e "install.packages(c('devtools','covr'), dependencies=TRUE, repos='https://cloud.r-project.org')"
- sudo R -q -e "install.packages(c('fields','meta','metafor','ggplot2','gridExtra','data.table'), dependencies=TRUE, repos='https://cloud.r-project.org')"
- sudo R -q -e "install.packages(c('DSI','DSOpal','DSLite'), dependencies=TRUE, repos='https://cloud.r-project.org')"
- sudo R -q -e "install.packages(c('MolgenisAuth', 'MolgenisArmadillo', 'DSMolgenisArmadillo'), dependencies=TRUE, repos='https://cloud.r-project.org')"
- sudo R -q -e "install.packages(c('DescTools','e1071'), dependencies=TRUE, repos='https://cloud.r-project.org')"
+ sudo apt-get install -qq libharfbuzz-dev libfribidi-dev libmagick++-dev libudunits2-dev libuv1-dev -y
+
+ # Use Posit Public Package Manager, which serves precompiled binary packages
+ # for this Ubuntu release instead of source - so dependencies are downloaded
+ # rather than compiled (the slow part). The HTTPUserAgent option is what makes
+ # the manager hand back binaries.
+ sudo R -q -e "options(repos=c(CRAN=paste0('https://packagemanager.posit.co/cran/__linux__/', system('lsb_release -cs', intern=TRUE), '/latest')), HTTPUserAgent=sprintf('R/%s R (%s)', getRversion(), paste(getRversion(), R.version\$platform, R.version\$arch, R.version\$os)), Ncpus=4); install.packages(c('devtools','covr','fields','meta','metafor','ggplot2','gridExtra','data.table','DSI','DSOpal','DSLite','MolgenisAuth','MolgenisArmadillo','DSMolgenisArmadillo','DescTools','e1071'), dependencies=TRUE)"
sudo R -q -e "library('devtools'); devtools::install_github(repo='datashield/dsDangerClient', ref='v6.3.4-dev', dependencies = TRUE)"
@@ -235,7 +237,7 @@ jobs:
curl -u admin:admin -X GET http://localhost:8080/packages
- curl -u admin:admin --max-time 300 -v -H 'Content-Type: multipart/form-data' -F "file=@dsBase_6.3.5-permissive.tar.gz" -X POST http://localhost:8080/install-package
+ curl -u admin:admin --max-time 300 -v -H 'Content-Type: multipart/form-data' -F "file=@dsBase_7.0.0-permissive.tar.gz" -X POST http://localhost:8080/install-package
sleep 60
docker container restart dsbaseclient_armadillo_1
@@ -274,7 +276,7 @@ jobs:
#
# "_-|arg-|smk-|datachk-|disc-|math-|expt-|expt_smk-"
# testthat::test_package("$(projectName)", filter = "_-|datachk-|smk-|arg-|disc-|perf-|smk_expt-|expt-|math-", reporter = multi_rep, stop_on_failure = FALSE)
- sudo R -q -e '
+ sudo env PERF_PROFILE=$PERF_PROFILE R -q -e '
library(covr);
dsbase.res <- covr::package_coverage(
type = c("none"),
@@ -396,7 +398,7 @@ jobs:
# testthat::testpackage uses a MultiReporter, comprised of a ProgressReporter and JunitReporter
# R output and messages are redirected by sink() to test_console_output.txt
# junit reporter output is to test_results.xml
- sudo R -q -e '
+ sudo env PERF_PROFILE=$PERF_PROFILE R -q -e '
library(covr);
dsdanger.res <- covr::package_coverage(
type = c("none"),
diff --git a/azure-pipelines.yml b/azure-pipelines.yml
index db3d7a186..bbd5632b2 100644
--- a/azure-pipelines.yml
+++ b/azure-pipelines.yml
@@ -32,6 +32,7 @@ variables:
branchName: $(Build.SourceBranchName)
test_filter: '*'
_r_check_system_clock_: 0
+ perf.profile: 'azure-pipeline'
#########################################################################################
@@ -44,10 +45,10 @@ schedules:
- master
always: true
- cron: "0 2 * * *"
- displayName: Nightly build - v6.3.5-dev
+ displayName: Nightly build - v7.0-dev
branches:
include:
- - v6.3.5-dev
+ - v7.0-dev
always: true
#########################################################################################
@@ -113,13 +114,13 @@ jobs:
sudo apt-get upgrade -y
sudo apt-get install -qq libxml2-dev libcurl4-openssl-dev libssl-dev libgsl-dev libgit2-dev r-base -y
- sudo apt-get install -qq libharfbuzz-dev libfribidi-dev libmagick++-dev libudunits2-dev -y
- sudo R -q -e "install.packages(c('curl','httr'), dependencies=TRUE, repos='https://cloud.r-project.org')"
- sudo R -q -e "install.packages(c('devtools','covr'), dependencies=TRUE, repos='https://cloud.r-project.org')"
- sudo R -q -e "install.packages(c('fields','meta','metafor','ggplot2','gridExtra','data.table'), dependencies=TRUE, repos='https://cloud.r-project.org')"
- sudo R -q -e "install.packages(c('DSI','DSOpal','DSLite'), dependencies=TRUE, repos='https://cloud.r-project.org')"
- sudo R -q -e "install.packages(c('MolgenisAuth', 'MolgenisArmadillo', 'DSMolgenisArmadillo'), dependencies=TRUE, repos='https://cloud.r-project.org')"
- sudo R -q -e "install.packages(c('DescTools','e1071'), dependencies=TRUE, repos='https://cloud.r-project.org')"
+ sudo apt-get install -qq libharfbuzz-dev libfribidi-dev libmagick++-dev libudunits2-dev libuv1-dev -y
+
+ # Use Posit Public Package Manager, which serves precompiled binary packages
+ # for this Ubuntu release instead of source - so dependencies are downloaded
+ # rather than compiled (the slow part). The HTTPUserAgent option is what makes
+ # the manager hand back binaries.
+ sudo R -q -e "options(repos=c(CRAN=paste0('https://packagemanager.posit.co/cran/__linux__/', system('lsb_release -cs', intern=TRUE), '/latest')), HTTPUserAgent=sprintf('R/%s R (%s)', getRversion(), paste(getRversion(), R.version\$platform, R.version\$arch, R.version\$os)), Ncpus=4); install.packages(c('curl','httr','devtools','covr','fields','meta','metafor','ggplot2','gridExtra','data.table','DSI','DSOpal','DSLite','MolgenisAuth','MolgenisArmadillo','DSMolgenisArmadillo','DescTools','e1071'), dependencies=TRUE)"
sudo R -q -e "library('devtools'); devtools::install_github(repo='datashield/dsDangerClient', ref='6.3.4', dependencies = TRUE)"
@@ -214,13 +215,15 @@ jobs:
# Install dsBase.
# If previous steps have failed then don't run.
- bash: |
- R -q -e "library(opalr); opal <- opal.login(username = 'administrator', password = 'datashield_test&', url = 'https://localhost:8443', opts = list(ssl_verifyhost=0, ssl_verifypeer=0)); opal.put(opal, 'system', 'conf', 'general', '_rPackage'); opal.logout(o)"
+ R -q -e "library(opalr); opal <- opal.login(username = 'administrator', password = 'datashield_test&', url = 'http://localhost:8080/'); opal.put(opal, 'system', 'conf', 'general', '_rPackage'); opal.logout(opal)"
- R -q -e "library(opalr); opal <- opal.login('administrator','datashield_test&', url='https://localhost:8443/', opts = list(ssl_verifyhost=0, ssl_verifypeer=0)); dsadmin.install_github_package(opal, 'dsBase', username = 'datashield', ref = 'v6.3.5-dev'); opal.logout(opal)"
+ R -q -e "library(opalr); opal <- opal.login('administrator','datashield_test&', url='http://localhost:8080/'); dsadmin.install_github_package(opal, 'dsBase', username = 'datashield', ref = 'v7.0-dev'); opal.logout(opal)"
sleep 60
- R -q -e "library(opalr); opal <- opal.login('administrator','datashield_test&', url='https://localhost:8443/', opts = list(ssl_verifyhost=0, ssl_verifypeer=0)); dsadmin.set_option(opal, 'default.datashield.privacyControlLevel', 'permissive'); opal.logout(opal)"
+ R -q -e "library(opalr); opal <- opal.login('administrator', 'datashield_test&', url='http://localhost:8080/'); dsadmin.profile_init(opal, name = 'default', packages = c('dsBase', 'dsTidyverse', 'resourcer')); opal.logout(opal)"
+
+ R -q -e "library(opalr); opal <- opal.login('administrator', 'datashield_test&', url='http://localhost:8080/'); dsadmin.set_option(opal, 'default.datashield.privacyControlLevel', 'permissive'); opal.logout(opal)"
workingDirectory: $(Pipeline.Workspace)/dsBaseClient/tests/testthat/data_files
displayName: 'Install dsBase to Opal, as set disclosure test options'
@@ -253,7 +256,7 @@ jobs:
#
# "_-|arg-|smk-|datachk-|disc-|math-|expt-|expt_smk-"
# testthat::test_package("$(projectName)", filter = "_-|datachk-|smk-|arg-|disc-|perf-|smk_expt-|expt-|math-", reporter = multi_rep, stop_on_failure = FALSE)
- sudo R -q -e '
+ sudo env PERF_PROFILE=$PERF_PROFILE R -q -e '
library(covr);
dsbase.res <- covr::package_coverage(
type = c("none"),
@@ -342,9 +345,9 @@ jobs:
# If previous steps have failed then don't run
- bash: |
- R -q -e "library(opalr); opal <- opal.login(username = 'administrator', password = 'datashield_test&', url = 'https://localhost:8443', opts = list(ssl_verifyhost=0, ssl_verifypeer=0)); opal.put(opal, 'system', 'conf', 'general', '_rPackage'); opal.logout(o)"
+ R -q -e "library(opalr); opal <- opal.login(username = 'administrator', password = 'datashield_test&', url = 'http://localhost:8080'); opal.put(opal, 'system', 'conf', 'general', '_rPackage'); opal.logout(opal)"
- R -q -e "library(opalr); opal <- opal.login('administrator','datashield_test&', url='https://localhost:8443/', opts = list(ssl_verifyhost=0, ssl_verifypeer=0)); dsadmin.install_github_package(opal, 'dsDanger', username = 'datashield', ref = '6.3.4'); opal.logout(opal)"
+ R -q -e "library(opalr); opal <- opal.login('administrator','datashield_test&', url='http://localhost:8080/'); dsadmin.install_github_package(opal, 'dsDanger', username = 'datashield', ref = '6.3.4'); opal.logout(opal)"
workingDirectory: $(Pipeline.Workspace)/dsBaseClient
displayName: 'Install dsDanger package on Opal server'
@@ -368,7 +371,7 @@ jobs:
# testthat::testpackage uses a MultiReporter, comprised of a ProgressReporter and JunitReporter
# R output and messages are redirected by sink() to test_console_output.txt
# junit reporter output is to test_results.xml
- sudo R -q -e '
+ sudo env PERF_PROFILE=$PERF_PROFILE R -q -e '
library(covr);
dsdanger.res <- covr::package_coverage(
type = c("none"),
diff --git a/codecov.yml b/codecov.yml
new file mode 100644
index 000000000..feeeecd26
--- /dev/null
+++ b/codecov.yml
@@ -0,0 +1,23 @@
+codecov:
+ notify:
+ # 7 armadillo-dsbase matrix shards each upload their own cobertura.xml
+ # (dsdanger is excluded - see dsBaseClient_test_suite.yaml) - without
+ # this, Codecov has no signal for when all uploads for a commit are in,
+ # and can delay posting codecov/patch by anywhere from minutes to hours.
+ after_n_builds: 7
+
+coverage:
+ status:
+ # Whole-repo coverage trend - informational only, never fails a PR. The
+ # combined figure is still shown in the GitHub Actions job summary
+ # (test-summary job) alongside a link to the full Codecov report.
+ project:
+ default:
+ target: auto
+ informational: true
+ # Coverage of lines actually changed by the PR - this is the enforced
+ # gate, so new/changed code is held to a bar without blocking on the
+ # pre-existing coverage backlog elsewhere in the repo.
+ patch:
+ default:
+ target: 80%
diff --git a/docker-compose_armadillo.yml b/docker-compose_armadillo.yml
index 37c44cdae..1cab1c3bb 100644
--- a/docker-compose_armadillo.yml
+++ b/docker-compose_armadillo.yml
@@ -3,20 +3,22 @@ services:
hostname: armadillo
ports:
- 8080:8080
- image: datashield/armadillo_citest:5.11.0
+ image: datashield/armadillo_citest:latest
environment:
LOGGING_CONFIG: 'classpath:logback-file.xml'
AUDIT_LOG_PATH: '/app/logs/audit.log'
SPRING_SECURITY_USER_PASSWORD: 'admin'
+ DEBUG: "FALSE"
volumes:
- ./tests/docker/armadillo/standard/logs:/logs
- ./tests/docker/armadillo/standard/data:/data
- ./tests/docker/armadillo/standard/config:/config
- /var/run/docker.sock:/var/run/docker.sock
+ depends_on:
+ - default
default:
hostname: default
- image: datashield/rock-quebrada-lamda:latest
-# image: datashield/rserver-panda-lamda:devel
+ image: datashield/rock_citest-permissive:latest
environment:
DEBUG: "FALSE"
diff --git a/docker-compose_opal.yml b/docker-compose_opal.yml
index a62dec679..70bffd8d1 100644
--- a/docker-compose_opal.yml
+++ b/docker-compose_opal.yml
@@ -3,6 +3,7 @@ services:
image: datashield/opal_citest:latest
ports:
- 8443:8443
+ - 8080:8080
links:
- mongo
- rock
@@ -15,11 +16,11 @@ services:
- ROCK_HOSTS=rock:8085
- ROCK_ADMINISTRATOR_PASSWORD=foobar
mongo:
- image: mongo:4.4.15
+ image: mongo:8.0
environment:
- MONGO_INITDB_ROOT_USERNAME=root
- MONGO_INITDB_ROOT_PASSWORD=foobar
rock:
- image: datashield/rock-quebrada-lamda-permissive:latest
+ image: datashield/rock_citest-permissive:latest
environment:
DEBUG: "FALSE"
diff --git a/docs/404.html b/docs/404.html
index 76de734e6..1534613f7 100644
--- a/docs/404.html
+++ b/docs/404.html
@@ -4,90 +4,70 @@
-
+
Page not found (404) • dsBaseClient
-
-
-
-
-
-
-
+
+
+
+
+
-
-
-
-