From 9f4138646d13941ee0e0c22ef054cb82559c75c4 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Sun, 24 Dec 2023 17:28:41 +0100 Subject: [PATCH] stye --- .github/workflows/R-CMD-check.yaml | 45 +++- .github/workflows/r-package.yml | 338 -------------------------- data-raw/elo.R | 14 +- data-raw/update_sgp_data.R | 36 +-- tests/testthat/test_rating.R | 281 +++++++++++----------- tests/testthat/test_terms.R | 367 +++++++++++++++-------------- tests/testthat/test_utils.R | 130 +++++----- vignettes/sport_in_r.Rmd | 2 +- 8 files changed, 476 insertions(+), 737 deletions(-) delete mode 100644 .github/workflows/r-package.yml diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index b5e3d98..9369bf6 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -26,9 +26,6 @@ jobs: - {os: macos-latest, r: 'release'} - {os: windows-latest, r: 'release'} - {os: ubuntu-latest, r: 'devel', http-user-agent: 'release'} - - {os: fedora-clang, r: 'devel'} - - {os: debian-gcc, r: 'devel'} - - {os: debian-clang, r: 'devel'} - {os: ubuntu-latest, r: 'oldrel-1'} - {os: ubuntu-latest, r: 'oldrel-2'} - {os: ubuntu-latest, r: 'oldrel-3'} @@ -62,3 +59,45 @@ jobs: - uses: r-lib/actions/check-r-package@v2 with: upload-snapshots: true + + check-r-devel-san: + runs-on: ubuntu-18.04 + container: rocker/r-devel-san + steps: + - name: Checkout repository 🛎 + uses: actions/checkout@v2 + + - name: Install dependencies + shell: Rscript {0} + run: | + install.packages(c("Rcpp", "knitr", "rmarkdown", "tinytest", "rcmdcheck")) + + - name: Check 🔍 + shell: Rscript {0} + run: | + rcmdcheck::rcmdcheck( + args = c("--as-cran", "--ignore-vignettes"), + build_args = "--no-build-vignettes", + error_on = "warning" + ) + + check-r-devel-ubsan-clang: + runs-on: ubuntu-18.04 + container: rocker/r-devel-ubsan-clang + steps: + - name: Checkout repository 🛎 + uses: actions/checkout@v2 + + - name: Install dependencies + shell: Rscript {0} + run: | + install.packages(c("Rcpp", "knitr", "rmarkdown", "tinytest", "rcmdcheck")) + + - name: Check 🔍 + shell: Rscript {0} + run: | + rcmdcheck::rcmdcheck( + args = c("--as-cran", "--ignore-vignettes"), + build_args = "--no-build-vignettes", + error_on = "warning" + ) diff --git a/.github/workflows/r-package.yml b/.github/workflows/r-package.yml deleted file mode 100644 index 3b35583..0000000 --- a/.github/workflows/r-package.yml +++ /dev/null @@ -1,338 +0,0 @@ -name: R-package - -on: - push: - branches: - - master - pull_request: - branches: - - master - - release/* - -# automatically cancel in-progress builds if another commit is pushed -concurrency: - group: ${{ github.workflow }}-${{ github.ref }} - cancel-in-progress: true - -env: - # hack to get around this: - # https://stat.ethz.ch/pipermail/r-package-devel/2020q3/005930.html - _R_CHECK_SYSTEM_CLOCK_: 0 - # ignore R CMD CHECK NOTE checking how long it has - # been since the last submission - _R_CHECK_CRAN_INCOMING_REMOTE_: 0 - # CRAN ignores the "installed size is too large" NOTE, - # so our CI can too. Setting to a large value here just - # to catch extreme problems - _R_CHECK_PKG_SIZES_THRESHOLD_: 100 - -jobs: - test: - name: ${{ matrix.task }} (${{ matrix.os }}, ${{ matrix.compiler }}, R ${{ matrix.r_version }}, ${{ matrix.build_type }}) - runs-on: ${{ matrix.os }} - container: ${{ matrix.container }} - timeout-minutes: 60 - strategy: - fail-fast: false - matrix: - include: - ################ - # CMake builds # - ################ - - os: ubuntu-latest - task: r-package - compiler: gcc - r_version: 3.6 - build_type: cmake - container: 'ubuntu:18.04' - - os: ubuntu-latest - task: r-package - compiler: gcc - r_version: 4.3 - build_type: cmake - container: 'ubuntu:22.04' - - os: ubuntu-latest - task: r-package - compiler: clang - r_version: 3.6 - build_type: cmake - container: 'ubuntu:18.04' - - os: ubuntu-latest - task: r-package - compiler: clang - r_version: 4.3 - build_type: cmake - container: 'ubuntu:22.04' - - os: macOS-latest - task: r-package - compiler: gcc - r_version: 4.3 - build_type: cmake - container: null - - os: macOS-latest - task: r-package - compiler: clang - r_version: 4.3 - build_type: cmake - container: null - - os: windows-latest - task: r-package - compiler: MINGW - toolchain: MINGW - r_version: 3.6 - build_type: cmake - container: null - - os: windows-latest - task: r-package - compiler: MINGW - toolchain: MSYS - r_version: 4.3 - build_type: cmake - container: null - # Visual Studio 2019 - - os: windows-2019 - task: r-package - compiler: MSVC - toolchain: MSVC - r_version: 3.6 - build_type: cmake - container: null - # Visual Studio 2022 - - os: windows-2022 - task: r-package - compiler: MSVC - toolchain: MSVC - r_version: 4.3 - build_type: cmake - container: null - ############### - # CRAN builds # - ############### - - os: windows-latest - task: r-package - compiler: MINGW - toolchain: MINGW - r_version: 3.6 - build_type: cran - container: null - - os: windows-latest - task: r-package - compiler: MINGW - toolchain: MSYS - r_version: 4.3 - build_type: cran - container: null - - os: ubuntu-latest - task: r-package - compiler: gcc - r_version: 4.3 - build_type: cran - container: 'ubuntu:22.04' - - os: macOS-latest - task: r-package - compiler: clang - r_version: 4.3 - build_type: cran - container: null - ################ - # Other checks # - ################ - - os: ubuntu-latest - task: r-rchk - compiler: gcc - r_version: 4.3 - build_type: cran - container: 'ubuntu:22.04' - steps: - - name: Prevent conversion of line endings on Windows - if: startsWith(matrix.os, 'windows') - shell: pwsh - run: git config --global core.autocrlf false - - name: Install packages used by third-party actions - if: startsWith(matrix.os, 'ubuntu') - shell: bash - run: | - apt-get update -y - apt-get install --no-install-recommends -y \ - ca-certificates \ - dirmngr \ - gpg \ - gpg-agent \ - software-properties-common \ - sudo - # install newest version of git - # ref: - # - https://unix.stackexchange.com/a/170831/550004 - # - https://git-scm.com/download/linux - add-apt-repository ppa:git-core/ppa -y - apt-get update -y - apt-get install --no-install-recommends -y \ - git - - name: Trust git cloning LightGBM - if: startsWith(matrix.os, 'ubuntu') - run: | - git config --global --add safe.directory "${GITHUB_WORKSPACE}" - - name: Checkout repository - uses: actions/checkout@v3 - with: - fetch-depth: 5 - submodules: true - - name: Install pandoc - uses: r-lib/actions/setup-pandoc@v2 - - name: install tinytex - if: startsWith(matrix.os, 'windows') - uses: r-lib/actions/setup-tinytex@v2 - env: - CTAN_MIRROR: https://ctan.math.illinois.edu/systems/win32/miktex - TINYTEX_INSTALLER: TinyTeX - - name: Setup and run tests on Linux and macOS - if: matrix.os == 'macOS-latest' || matrix.os == 'ubuntu-latest' - shell: bash - run: | - export TASK="${{ matrix.task }}" - export COMPILER="${{ matrix.compiler }}" - export GITHUB_ACTIONS="true" - if [[ "${{ matrix.os }}" == "macOS-latest" ]]; then - export OS_NAME="macos" - elif [[ "${{ matrix.os }}" == "ubuntu-latest" ]]; then - export OS_NAME="linux" - export IN_UBUNTU_BASE_CONTAINER="true" - # the default version of cmake provided on Ubuntu 18.04 (v3.10.2), is not supported by LightGBM - # see https://github.com/microsoft/LightGBM/issues/5642 - if [[ "${{ matrix.container }}" == "ubuntu:18.04" ]]; then - export INSTALL_CMAKE_FROM_RELEASES="true" - fi - fi - export BUILD_DIRECTORY="$GITHUB_WORKSPACE" - export R_VERSION="${{ matrix.r_version }}" - export R_BUILD_TYPE="${{ matrix.build_type }}" - $GITHUB_WORKSPACE/.ci/setup.sh - $GITHUB_WORKSPACE/.ci/test.sh - - name: Setup and run tests on Windows - if: startsWith(matrix.os, 'windows') - shell: pwsh -command ". {0}" - run: | - $env:BUILD_SOURCESDIRECTORY = $env:GITHUB_WORKSPACE - $env:LGB_VER = (Get-Content -TotalCount 1 $env:BUILD_SOURCESDIRECTORY\VERSION.txt).trim().replace('rc', '-') - $env:TOOLCHAIN = "${{ matrix.toolchain }}" - $env:R_VERSION = "${{ matrix.r_version }}" - $env:R_BUILD_TYPE = "${{ matrix.build_type }}" - $env:COMPILER = "${{ matrix.compiler }}" - $env:GITHUB_ACTIONS = "true" - $env:TASK = "${{ matrix.task }}" - & "$env:GITHUB_WORKSPACE/.ci/test_windows.ps1" - test-r-sanitizers: - name: r-sanitizers (ubuntu-latest, R-devel, ${{ matrix.compiler }} ASAN/UBSAN) - timeout-minutes: 60 - runs-on: ubuntu-latest - container: wch1/r-debug - strategy: - fail-fast: false - matrix: - include: - - r_customization: san - compiler: gcc - - r_customization: csan - compiler: clang - steps: - - name: Trust git cloning LightGBM - run: | - git config --global --add safe.directory "${GITHUB_WORKSPACE}" - - name: Checkout repository - uses: actions/checkout@v3 - with: - fetch-depth: 5 - submodules: true - - name: Install packages - shell: bash - run: | - RDscript${{ matrix.r_customization }} -e "install.packages(c('R6', 'data.table', 'jsonlite', 'knitr', 'Matrix', 'RhpcBLASctl', 'rmarkdown', 'testthat'), repos = 'https://cran.rstudio.com', Ncpus = parallel::detectCores())" - sh build-cran-package.sh --r-executable=RD${{ matrix.r_customization }} - RD${{ matrix.r_customization }} CMD INSTALL lightgbm_*.tar.gz || exit -1 - - name: Run tests with sanitizers - shell: bash - run: | - cd R-package/tests - exit_code=0 - RDscript${{ matrix.r_customization }} testthat.R >> tests.log 2>&1 || exit_code=-1 - cat ./tests.log - exit ${exit_code} - test-r-debian-clang: - name: r-package (debian, R-devel, clang) - timeout-minutes: 60 - runs-on: ubuntu-latest - container: rhub/debian-clang-devel - steps: - - name: Install Git before checkout - shell: bash - run: | - apt-get update --allow-releaseinfo-change - apt-get install --no-install-recommends -y git - - name: Trust git cloning LightGBM - run: | - git config --global --add safe.directory "${GITHUB_WORKSPACE}" - - name: Checkout repository - uses: actions/checkout@v3 - with: - fetch-depth: 5 - submodules: true - - name: update to clang 15 - shell: bash - run: | - # remove clang stuff that comes installed in the image - apt-get autoremove -y --purge \ - clang-* \ - libclang-* \ - libunwind-* \ - llvm-* - # - # replace it all with clang-15 - apt-get update -y - apt-get install --no-install-recommends -y \ - gnupg \ - lsb-release \ - software-properties-common \ - wget - # - wget -O - https://apt.llvm.org/llvm-snapshot.gpg.key | apt-key add - - # - add-apt-repository "deb http://apt.llvm.org/unstable/ llvm-toolchain main" - apt-get install -y --no-install-recommends \ - clang-15 \ - clangd-15 \ - clang-format-15 \ - clang-tidy-15 \ - clang-tools-15 \ - lldb-15 \ - lld-15 \ - llvm-15-dev \ - llvm-15-tools \ - libomp-15-dev \ - libc++-15-dev \ - libc++abi-15-dev \ - libclang-common-15-dev \ - libclang-15-dev \ - libclang-cpp15-dev \ - libunwind-15-dev - # overwrite everything in /usr/bin with the new v15 versions - cp --remove-destination /usr/lib/llvm-15/bin/* /usr/bin/ - - name: Install packages and run tests - shell: bash - run: | - export PATH=/opt/R-devel/bin/:${PATH} - Rscript -e "install.packages(c('R6', 'data.table', 'jsonlite', 'knitr', 'Matrix', 'RhpcBLASctl', 'rmarkdown', 'testthat'), repos = 'https://cran.rstudio.com', Ncpus = parallel::detectCores())" - sh build-cran-package.sh - R CMD check --as-cran --run-donttest lightgbm_*.tar.gz || exit -1 - if grep -q -E "NOTE|WARNING|ERROR" lightgbm.Rcheck/00check.log; then - echo "NOTEs, WARNINGs, or ERRORs have been found by R CMD check" - exit -1 - fi - all-r-package-jobs-successful: - if: always() - runs-on: ubuntu-latest - needs: [test, test-r-sanitizers, test-r-debian-clang] - steps: - - name: Note that all tests succeeded - uses: re-actors/alls-green@v1.2.2 - with: - jobs: ${{ toJSON(needs) }} \ No newline at end of file diff --git a/data-raw/elo.R b/data-raw/elo.R index b05a771..3f62672 100755 --- a/data-raw/elo.R +++ b/data-raw/elo.R @@ -25,20 +25,20 @@ test <- function() { teams <- customQuery( { " - SELECT - e.id event_id, + SELECT + e.id event_id, lc.type, e.round, lc.stage, lc.stage_level, - et.team_idx, - et.team_name, + et.team_idx, + et.team_name, et.points_scored - FROM league_competitions lc + FROM league_competitions lc LEFT JOIN events e using(competition, season, stage) LEFT JOIN event_teams et on et.event_id = e.id - WHERE - e.competition = '%s' and + WHERE + e.competition = '%s' and e.season = %s and team_name is not null ORDER BY et.id diff --git a/data-raw/update_sgp_data.R b/data-raw/update_sgp_data.R index 35fe4f5..e1ffa0c 100755 --- a/data-raw/update_sgp_data.R +++ b/data-raw/update_sgp_data.R @@ -4,21 +4,23 @@ update_sgp_data <- function() { library(dplyr) library(RMySQL) library(runner) - con <- dbConnect(drv = MySQL(), - username = "root", - dbname = "speedway", - password = "Elo#21ok", - encoding = "UTF-8") + con <- dbConnect( + drv = MySQL(), + username = "root", + dbname = "speedway", + password = "Elo#21ok", + encoding = "UTF-8" + ) dbGetQuery(con, "SET NAMES utf8") gpsquads <- customQuery({ " - SELECT + SELECT e.id, e.season, e.date, e.place, e.round, - e.name, + e.name, s.rider_name rider, s.points, s.classification @@ -29,12 +31,12 @@ update_sgp_data <- function() { }) gpheats <- customQuery({ " - SELECT + SELECT e.id, e.season, e.date, e.round, - e.name, + e.name, h.heat, h.field, h.rider_name rider, @@ -42,7 +44,7 @@ update_sgp_data <- function() { h.position FROM speedway.event_heats h LEFT JOIN speedway.events e on e.id = h.event_id - WHERE + WHERE competition = 'Grand-Prix' " }) @@ -65,13 +67,15 @@ update_sgp_data <- function() { rank = ifelse(is.na(rank), max(rank, na.rm = T) + 1, rank) ) - Encoding(gpheats$name) <- "UTF-8" + Encoding(gpheats$name) <- "UTF-8" Encoding(gpheats$rider) <- "UTF-8" - Encoding(gpsquads$name) <- "UTF-8" + Encoding(gpsquads$name) <- "UTF-8" Encoding(gpsquads$place) <- "UTF-8" Encoding(gpsquads$rider) <- "UTF-8" - - - usethis::use_data(gpsquads, - gpheats, overwrite = TRUE) + + + usethis::use_data(gpsquads, + gpheats, + overwrite = TRUE + ) } diff --git a/tests/testthat/test_rating.R b/tests/testthat/test_rating.R index 082dff5..cbb3be6 100644 --- a/tests/testthat/test_rating.R +++ b/tests/testthat/test_rating.R @@ -27,7 +27,7 @@ test_that("check rating default arguments", { kappa = 0.5 ) ) - + expect_silent( g2 <- rating_run( method = "glicko", @@ -43,7 +43,7 @@ test_that("check rating default arguments", { kappa = 0.5 ) ) - + expect_silent( g3 <- rating_run( method = "glicko", @@ -54,7 +54,7 @@ test_that("check rating default arguments", { kappa = 0.5 ) ) - + expect_silent( g4 <- glicko_run( data = df, @@ -66,7 +66,7 @@ test_that("check rating default arguments", { expect_identical(g2, g3) expect_identical(g3$final_r, g4$final_r) expect_identical(g3$final_rd, g4$final_rd) - + expect_silent( g5 <- rating_run( method = "glicko", @@ -77,7 +77,7 @@ test_that("check rating default arguments", { kappa = 0.5 ) ) - + expect_silent( g6 <- rating_run( method = "glicko", @@ -87,9 +87,9 @@ test_that("check rating default arguments", { init_rd = 350 ) ) - + expect_identical(g5, g6) - + expect_silent( g7 <- rating_run( method = "glicko", @@ -99,7 +99,7 @@ test_that("check rating default arguments", { init_rd = 350 ) ) - + expect_silent( g8 <- rating_run( method = "glicko", @@ -109,9 +109,9 @@ test_that("check rating default arguments", { init_rd = 350 ) ) - + expect_identical(g7, g8) - + expect_silent( g9 <- rating_run( method = "glicko2", @@ -124,19 +124,19 @@ test_that("check rating default arguments", { tau = 0.5 ) ) - + expect_silent( g10 <- glicko2_run( data = df, formula = rank | id ~ player(player | team) ) ) - + expect_identical(g9$final_r, g10$final_r) expect_identical(g9$final_rd, g10$final_rd) expect_identical(g9$final_sigma, g10$final_sigma) - - + + expect_silent( g11 <- rating_run( method = "bbt", @@ -147,18 +147,18 @@ test_that("check rating default arguments", { kappa = 0.5 ) ) - + expect_silent( g12 <- bbt_run( data = df, formula = rank | id ~ player(player | team) ) ) - + expect_identical(g11$final_r, g12$final_r) expect_identical(g11$final_rd, g12$final_rd) - - + + expect_warning( glicko_run( data = df, @@ -167,7 +167,7 @@ test_that("check rating default arguments", { ), "Missing parameters will be added with init_r" ) - + expect_warning( glicko_run( data = df, @@ -176,7 +176,7 @@ test_that("check rating default arguments", { ), "Missing parameters will be added with init_rd" ) - + expect_warning( glicko2_run( data = df, @@ -185,7 +185,7 @@ test_that("check rating default arguments", { ), "Missing parameters will be added with init_sigma" ) - + expect_warning( glicko2_run( data = df, @@ -194,7 +194,7 @@ test_that("check rating default arguments", { ), "Missing parameters will be added with init_sigma" ) - + expect_warning( glicko_run( data = df, @@ -204,7 +204,7 @@ test_that("check rating default arguments", { ), "init_rd" ) - + expect_warning( glicko <- glicko_run( data = df, @@ -214,18 +214,18 @@ test_that("check rating default arguments", { ), "init_r" ) - - + + expect_true( !"ff" %in% glicko$final_rd ) - - - glicko <- glicko_run(rank | id ~ player(rider), data = gpheats[1:4,]) + + + glicko <- glicko_run(rank | id ~ player(rider), data = gpheats[1:4, ]) expect_warning( glicko_run( formula = rank | id ~ player(rider), - data = gpheats[5:8,], + data = gpheats[5:8, ], r = glicko$final_r, rd = glicko$final_rd ), @@ -238,43 +238,51 @@ test_that("rating (argument) errors", { glicko_run(formula = rank ~ player), "Data is not provided" ) - + # check formula errors expect_error( glicko_run(data = df, formula = rank:id ~ player), "LHS" ) - + expect_error( glicko_run(data = df, formula = rank | id + test ~ player), "LHS" ) - + expect_error( glicko_run(data = df, formula = rank | id ~ player), "Formula requires specifying player\\(...\\) term" ) - + # stats::terms need also data if `.` specified - expect_error(glicko_run(data = df, formula = rank | id ~ .), - "in formula and no 'data' argument") - - expect_error(glicko_run(data = df, formula = rank | id ~ 1), - "Formula requires specifying player\\(...\\) term") - - expect_error(glicko_run(data = df, formula = rank | id ~ player(wrong)), - "Variable\\(s\\) wrong specified in formula not present in data") - + expect_error( + glicko_run(data = df, formula = rank | id ~ .), + "in formula and no 'data' argument" + ) + + expect_error( + glicko_run(data = df, formula = rank | id ~ 1), + "Formula requires specifying player\\(...\\) term" + ) + + expect_error( + glicko_run(data = df, formula = rank | id ~ player(wrong)), + "Variable\\(s\\) wrong specified in formula not present in data" + ) + expect_silent(glicko_run(data = df, formula = rank | id ~ player(player))) expect_silent(glicko_run(data = df, formula = rank | id ~ player(player | team))) - expect_error(dbl_run(data = df, formula = rank | id ~ player(player | team)), - "Please specify only one variable inside of the player") + expect_error( + dbl_run(data = df, formula = rank | id ~ player(player | team)), + "Please specify only one variable inside of the player" + ) }) test_that("glicko result", { expected_r <- setNames(c(1464.297, 1396.039, 1606.521, 1674.836), c("A", "B", "C", "D")) expected_rd <- setNames(c(150.847, 29.800, 92.544, 186.326), c("A", "B", "C", "D")) - + cpp_glicko <- sport:::glicko( unique_id = 1L, id = c(1, 1, 1, 1), @@ -293,7 +301,7 @@ test_that("glicko result", { kappa = 0.5, tau = 0.5 ) - + expect_warning( r_glicko <- glicko_run( data = data.frame( @@ -308,11 +316,11 @@ test_that("glicko result", { rd = setNames(c(200.0, 30.0, 100.0, 300.0), c("A", "B", "C", "D")) ) ) - - + + expect_identical(expected_r, round(cpp_glicko$final_r, 3)) expect_identical(expected_r, round(r_glicko$final_r, 3)) - + expect_identical(expected_rd, round(cpp_glicko$final_rd, 3)) expect_identical(expected_rd, round(r_glicko$final_rd, 3)) }) @@ -336,7 +344,7 @@ test_that("glicko2 result", { kappa = 0.5, tau = 0.5 ) - + r_glicko2 <- glicko2_run( formula = rank | id ~ player(player | team), data = data.frame( @@ -357,32 +365,32 @@ test_that("glicko2 result", { kappa = 0.5, tau = 0.5 ) - + expect_identical( setNames(c(1469, 1397, 1606, 1601), c("A", "B", "C", "D")), round(cpp_glicko2$final_r) ) - + expect_identical( setNames(c(154, 31, 94, 204), c("A", "B", "C", "D")), round(cpp_glicko2$final_rd) ) - + expect_identical( setNames(c(0.05, 0.05, 0.05, 0.05), c("A", "B", "C", "D")), round(cpp_glicko2$final_sigma, 2) ) - + expect_identical( cpp_glicko2$final_r, r_glicko2$final_r ) - + expect_identical( cpp_glicko2$final_rd, r_glicko2$final_rd ) - + expect_identical( cpp_glicko2$final_sigma, r_glicko2$final_sigma @@ -396,23 +404,19 @@ test_that("bbt result", { rank = c(3, 4, 1, 2), team = c("a", "b", "c", "d"), player = c("A", "B", "C", "D"), - r = setNames(c(25.0, 20.0, 15.0, 30.0), c("A", "B", "C", "D")), rd = setNames(c(6.0, 7.0, 5.0, 20.0), c("A", "B", "C", "D")), sigma = numeric(0), - lambda = c(1, 1, 1, 1), weight = c(1, 1, 1, 1), share = c(1, 1, 1, 1), - init_r = 25, init_rd = 25 / 3, init_sigma = 0, - kappa = 0.5, tau = 0.5 ) - + r_bbt <- bbt_run( formula = rank | id ~ player(player | team), data = data.frame( @@ -427,22 +431,22 @@ test_that("bbt result", { r = setNames(c(25.0, 20.0, 15.0, 30.0), c("A", "B", "C", "D")), rd = setNames(c(6.0, 7.0, 5.0, 20.0), c("A", "B", "C", "D")) ) - + expect_identical( setNames(c(22.50, 14.03, 19.61, 32.68), c("A", "B", "C", "D")), round(cpp_bbt$final_r, 2) ) - + expect_identical( setNames(c(5.98, 6.94, 4.99, 14.71), c("A", "B", "C", "D")), round(cpp_bbt$final_rd, 2) ) - + expect_identical( cpp_bbt$final_r, r_bbt$final_r ) - + expect_identical( cpp_bbt$final_rd, r_bbt$final_rd @@ -465,15 +469,15 @@ test_that("dbl result", { share = c(1, 1, 1, 1) ) ) - + expect_identical( round(r_dbl$final_r, 2), setNames( - c(-0.02, -0.18, 0.15, 0.05, -0.38, 0.64), + c(-0.02, -0.18, 0.15, 0.05, -0.38, 0.64), c("player=A", "player=B", "player=C", "player=D", "factor=a:gate", "factor=b:gate") ) ) - + expect_identical( round(r_dbl$final_rd, 2), setNames( @@ -484,19 +488,19 @@ test_that("dbl result", { }) test_that("Reasonable estimates", { - glicko <- glicko_run(rank | id ~ player(rider), data = gpheats[1:10000,]) - glicko2 <- glicko2_run(rank | id ~ player(rider), data = gpheats[1:10000,]) - bbt <- bbt_run(rank | id ~ player(rider), data = gpheats[1:10000,]) - dbl <- dbl_run(rank | id ~ player(rider), data = gpheats[1:10000,]) + glicko <- glicko_run(rank | id ~ player(rider), data = gpheats[1:10000, ]) + glicko2 <- glicko2_run(rank | id ~ player(rider), data = gpheats[1:10000, ]) + bbt <- bbt_run(rank | id ~ player(rider), data = gpheats[1:10000, ]) + dbl <- dbl_run(rank | id ~ player(rider), data = gpheats[1:10000, ]) library(dplyr) by_rank <- gpheats %>% head(10000) %>% group_by(rider) %>% summarize(mean_rank = mean(rank, na.rm = TRUE)) %>% - ungroup %>% + ungroup() %>% arrange(mean_rank) - + worst <- unique(c( names(sort(glicko$final_r)[1:10]), names(sort(glicko2$final_r)[1:10]), @@ -504,15 +508,17 @@ test_that("Reasonable estimates", { gsub("rider\\=", "", x = names(sort(dbl$final_r)[1:10])), tail(by_rank$rider, 10) )) - - best <- unique(c( - names(sort(glicko$final_r, decreasing = TRUE)[1:10]), - names(sort(glicko2$final_r, decreasing = TRUE)[1:10]), - names(sort(bbt$final_r, decreasing = TRUE)[1:10]), - gsub("rider\\=", "", x = names(sort(dbl$final_r, decreasing = TRUE)[1:10]))), + + best <- unique( + c( + names(sort(glicko$final_r, decreasing = TRUE)[1:10]), + names(sort(glicko2$final_r, decreasing = TRUE)[1:10]), + names(sort(bbt$final_r, decreasing = TRUE)[1:10]), + gsub("rider\\=", "", x = names(sort(dbl$final_r, decreasing = TRUE)[1:10])) + ), head(by_rank$rider, 10) ) - + expect_true(all(!worst %in% best)) expect_true(all(!best %in% worst)) @@ -531,20 +537,22 @@ test_that("Weighting", { ) bbt1 <- bbt_run(rank | id ~ player(player), - data = data) - + data = data + ) + bbt2 <- bbt_run(rank | id ~ player(player), - data = data, - weight = "weight") - + data = data, + weight = "weight" + ) + expect_equal( - abs(bbt2$final_r - 25), + abs(bbt2$final_r - 25), abs(bbt1$final_r - 25) * 2 ) - + expect_equal( - abs(bbt2$final_rd - 25/3), - abs(bbt1$final_rd - 25/3) * 2 + abs(bbt2$final_rd - 25 / 3), + abs(bbt1$final_rd - 25 / 3) * 2 ) }) @@ -559,58 +567,60 @@ test_that("Lambda", { weight = 2, stringsAsFactors = FALSE ) - + glicko1 <- glicko_run(rank | id ~ player(player), - data = data) - + data = data + ) + glicko2 <- glicko_run(rank | id ~ player(player), - data = data, - lambda = "lambda") - + data = data, + lambda = "lambda" + ) + expect_true( all( - abs(glicko2$final_r - 1500) < - abs(glicko1$final_r - 1500) + abs(glicko2$final_r - 1500) < + abs(glicko1$final_r - 1500) ) ) - + expect_true( all( - abs(glicko2$final_rd - 350) < + abs(glicko2$final_rd - 350) < abs(glicko1$final_rd - 350) ) ) }) test_that("kappa", { - glicko1 <- glicko2_run(rank | id ~ player(player), - data = df, - kappa = 1) + glicko1 <- glicko2_run(rank | id ~ player(player), + data = df, + kappa = 1 + ) expect_true(all( - glicko1$final_rd == 350 - ) - ) - - + glicko1$final_rd == 350 + )) + + glicko2 <- glicko_run(rank | id ~ player(player), - data = df, - kappa = 0.99) - + data = df, + kappa = 0.99 + ) + expect_true(all( - glicko2$final_rd == (350 * 0.99) - ) - ) - + glicko2$final_rd == (350 * 0.99) + )) + glicko3 <- bbt_run(rank | id ~ player(player), - data = df, - kappa = 0.98) - - expect_true(all( - glicko3$final_rd == (25 / 3 * 0.98) - ) + data = df, + kappa = 0.98 ) + + expect_true(all( + glicko3$final_rd == (25 / 3 * 0.98) + )) }) @@ -620,40 +630,43 @@ test_that("share", { rank = rep(c(3, 4, 1, 2), each = 2), team = c("A", "A", "B", "B", "C", "C", "D", "D"), player = letters[1:8], - contribution = c(0.9, 0.1, - 0.1, 0.9, - 0.5, 0.5, - 1, 0), + contribution = c( + 0.9, 0.1, + 0.1, 0.9, + 0.5, 0.5, + 1, 0 + ), stringsAsFactors = FALSE ) - x <- glicko_run(rank | id ~ player(player|team), - data = df, - share = "contribution") - + x <- glicko_run(rank | id ~ player(player | team), + data = df, + share = "contribution" + ) + expect_true( all( (x$final_r[1:4] - 1500) < 0 ) ) - + expect_true( all( (x$final_r[5:8] - 1500) >= 0 ) ) - - + + expect_equal( (1500 - x$final_r[1:2]) / sum((1500 - x$final_r[1:2])), setNames(c(0.9, 0.1), c("a", "b")) ) - + expect_equal( (1500 - x$final_r[3:4]) / sum((1500 - x$final_r[3:4])), setNames(c(0.1, 0.9), c("c", "d")) ) - + expect_equal( (x$final_r[5:6] - 1500) / sum((x$final_r[5:6] - 1500)), setNames(c(0.5, 0.5), c("e", "f")) diff --git a/tests/testthat/test_terms.R b/tests/testthat/test_terms.R index b9a04ea..2598e58 100644 --- a/tests/testthat/test_terms.R +++ b/tests/testthat/test_terms.R @@ -5,34 +5,34 @@ test_that("valid lhs formula", { is_formula_missing(NULL), "Formula is not specified" ) - + expect_error( is_formula_missing("y ~ x"), "Formula incorrectly specified" ) - + expect_error( is_lhs_valid(formula = rank:id ~ field, gpheats), "LHS of formula must be seperated by `\\|` operator eg." ) - + expect_error( is_lhs_valid(formula = rank + id ~ field, gpheats), "LHS of formula must be seperated by `\\|` operator eg." ) - + expect_warning( is_lhs_valid(formula = rank ~ field, gpheats), "all belongs to the same event id" ) - + expect_error( is_lhs_valid(formula = rank | wrong ~ field, gpheats), "Variable\\(s\\) wrong specified in formula are not present in data" ) - + expect_silent(is_lhs_valid(formula = rank | field ~ rider, gpheats)) - + expect_silent(is_lhs_valid(formula = rank | id ~ player(rider | name), gpheats)) }) @@ -41,17 +41,16 @@ test_that("check team term", { extract_team_terms(formula = rank + id ~ player(rider)), "rider" ) - + expect_identical( - extract_team_terms(formula = rank + id ~ player(rider|name)), + extract_team_terms(formula = rank + id ~ player(rider | name)), c("rider", "name") ) - + expect_error( - extract_team_terms(formula = rank + id ~ player(rider|name|elo)), + extract_team_terms(formula = rank + id ~ player(rider | name | elo)), "Only one or two variables are allowed within player" ) - }) test_that("valid rhs", { @@ -59,96 +58,94 @@ test_that("valid rhs", { is_rhs_valid(1 ~ 1, gpheats, only_team_term = TRUE, single = FALSE), "Formula requires specifying player" ) - + expect_error( is_rhs_valid(1 ~ ., gpheats, only_team_term = TRUE, single = FALSE), "'.' in formula and no 'data' argument" ) - + expect_error( is_rhs_valid(1 ~ rider, gpheats, only_team_term = TRUE, single = FALSE), "Formula requires specifying player" ) - + expect_error( is_rhs_valid(1 ~ player() + field, gpheats, only_team_term = TRUE, single = FALSE), "This formula requires only one RHS term which is player" ) - + expect_error( is_rhs_valid(1 ~ rider, gpheats, only_team_term = FALSE, single = TRUE), "Formula requires specifying player" ) - + expect_silent( is_rhs_valid(1 ~ player(rider), gpheats, only_team_term = FALSE, single = TRUE) ) - + expect_silent( is_rhs_valid(1 ~ player(rider), gpheats, only_team_term = FALSE, single = FALSE) ) - + expect_error( is_rhs_valid(1 ~ player(rider | team), gpheats, only_team_term = FALSE, single = TRUE), "Please specify only one variable inside of the player" ) - + expect_error( is_rhs_valid(1 ~ player(rider | team | elo), gpheats, only_team_term = FALSE, single = FALSE), "Only one or two variables are allowed within player" ) - + expect_error( is_rhs_valid(1 ~ player(rider | team) + field, gpheats, only_team_term = TRUE, single = FALSE), "This formula requires only one RHS term which is player" ) - + expect_error( is_rhs_valid(1 ~ player(rider | team) + field, gpheats, only_team_term = FALSE, single = FALSE), "team specified in formula not present in data" ) - + expect_silent( is_rhs_valid(1 ~ player(rider | name) + field, gpheats, only_team_term = FALSE, single = FALSE) ) - }) test_that("valid team term", { expect_silent( is_team_term_valid(formula = 1 ~ player(player), single = TRUE) - ) - + ) + expect_silent( is_team_term_valid(formula = 1 ~ player(player), single = FALSE) ) - + expect_silent( is_team_term_valid(formula = 1 ~ player(player | team), single = FALSE) ) - - - + + + expect_error( is_team_term_valid(formula = 1 ~ player(), single = TRUE), - "Formula requires specifying player" + "Formula requires specifying player" ) - + expect_error( is_team_term_valid(formula = 1 ~ player(player | team), single = TRUE), "Please specify only one variable inside of the player" ) - + expect_error( is_team_term_valid(formula = 1 ~ player(player | team | country), single = FALSE), "Only one or two variables are allowed within player" ) - + expect_error( is_team_term_valid(formula = 1 ~ player(player) + player(team), single = FALSE), "Only one player\\(...\\) term is allowed with one or two variables." ) - }) test_that("get_type", { @@ -180,182 +177,209 @@ test_that("get_type", { test_that("get terms", { term1 <- get_terms( gpheats, - rank|id ~ round + rank | id ~ round ) expected1 <- list(c(round = "numeric")) expect_identical(term1, expected1) - - + + term2 <- get_terms( gpheats, - rank|id ~ rider + round + rank | id ~ rider + round + ) + expected2 <- list( + c(rider = "character"), + c(round = "numeric") ) - expected2 <- list(c(rider = "character"), - c(round = "numeric")) expect_identical(term2, expected2) - - + + term3 <- get_terms( gpheats, - rank|id ~ rider + round + field:heat + rank | id ~ rider + round + field:heat + ) + expected3 <- list( + c(rider = "character"), + c(round = "numeric"), + c( + field = "numeric", + heat = "numeric" + ) ) - expected3 <- list(c(rider = "character"), - c(round = "numeric"), - c(field = "numeric", - heat = "numeric")) expect_identical(term3, expected3) - + gpheats$field_f <- as.factor(gpheats$field) term4 <- get_terms( gpheats, - rank|id ~ rider + round + field:heat + heat:field_f - ) - expected4 <- list(c(rider = "character"), - c(round = "numeric"), - c(field = "numeric", - heat = "numeric"), - c(field_f = "character", - heat = "numeric")) + rank | id ~ rider + round + field:heat + heat:field_f + ) + expected4 <- list( + c(rider = "character"), + c(round = "numeric"), + c( + field = "numeric", + heat = "numeric" + ), + c( + field_f = "character", + heat = "numeric" + ) + ) expect_identical(term4, expected4) - - + + term5 <- get_terms( gpheats, - rank|id ~ rider + round + field*heat - ) - expected5 <- list(c(rider = "character"), - c(round = "numeric"), - c(field = "numeric"), - c(heat = "numeric"), - c(field = "numeric", - heat = "numeric")) + rank | id ~ rider + round + field * heat + ) + expected5 <- list( + c(rider = "character"), + c(round = "numeric"), + c(field = "numeric"), + c(heat = "numeric"), + c( + field = "numeric", + heat = "numeric" + ) + ) expect_identical(term5, expected5) - + term6 <- get_terms( gpheats, - rank|id ~ player(rider) + round + field*heat - ) - expected6 <- list(c(rider = "character"), - c(round = "numeric"), - c(field = "numeric"), - c(heat = "numeric"), - c(field = "numeric", - heat = "numeric")) + rank | id ~ player(rider) + round + field * heat + ) + expected6 <- list( + c(rider = "character"), + c(round = "numeric"), + c(field = "numeric"), + c(heat = "numeric"), + c( + field = "numeric", + heat = "numeric" + ) + ) expect_identical(term6, expected6) - - + + term7 <- get_terms( gpheats, - rank|id ~ round + field*heat + player(rider) - ) - expected7 <- list(c(rider = "character"), - c(round = "numeric"), - c(field = "numeric"), - c(heat = "numeric"), - c(field = "numeric", - heat = "numeric")) + rank | id ~ round + field * heat + player(rider) + ) + expected7 <- list( + c(rider = "character"), + c(round = "numeric"), + c(field = "numeric"), + c(heat = "numeric"), + c( + field = "numeric", + heat = "numeric" + ) + ) expect_identical(term7, expected7) - - + + term8 <- get_terms( gpheats, - rank|id ~ round + field*heat + player(rider|name) - ) - expected8 <- list(c(rider = "character"), - c(name = "character"), - c(round = "numeric"), - c(field = "numeric"), - c(heat = "numeric"), - c(field = "numeric", - heat = "numeric")) + rank | id ~ round + field * heat + player(rider | name) + ) + expected8 <- list( + c(rider = "character"), + c(name = "character"), + c(round = "numeric"), + c(field = "numeric"), + c(heat = "numeric"), + c( + field = "numeric", + heat = "numeric" + ) + ) expect_identical(term8, expected8) - + expect_error( get_terms( gpheats, - rank|id ~ rider + round + field:heat + heat:field_f + unknown + rank | id ~ rider + round + field:heat + heat:field_f + unknown ), "Variable\\(s\\) .+ specified in formula not present in data" ) - + expect_error( get_terms( gpheats, - rank|id ~ rider + round + field:heat + heat:field_f:unknown + rank | id ~ rider + round + field:heat + heat:field_f:unknown ), "Variable\\(s\\) .+ specified in formula not present in data" ) - }) test_that("get terms map", { term1 <- get_terms( gpheats, - rank|id ~ round + rank | id ~ round ) - terms_map1 <- get_terms_map(gpheats[1:6,], term1) + terms_map1 <- get_terms_map(gpheats[1:6, ], term1) expected1 <- as.matrix( data.frame( round = rep("round", 6) ) ) - expect_identical(terms_map1, expected1) - - + expect_identical(terms_map1, expected1) + + term2 <- get_terms( gpheats, - rank|id ~ rider + round + rank | id ~ rider + round ) - terms_map2 <- get_terms_map(gpheats[1:6,], term2) + terms_map2 <- get_terms_map(gpheats[1:6, ], term2) expected2 <- as.matrix( data.frame( rider = paste0("rider=", gpheats$rider[1:6]), round = rep("round", 6) ) ) - expect_identical(terms_map2, expected2) - - + expect_identical(terms_map2, expected2) + + term4 <- get_terms( gpheats, - rank|id ~ rider + round + field:heat + heat:rider + rank | id ~ rider + round + field:heat + heat:rider ) - terms_map4 <- get_terms_map(gpheats[1:6,], term4) + terms_map4 <- get_terms_map(gpheats[1:6, ], term4) expected4 <- as.matrix( data.frame( rider = paste0("rider=", gpheats$rider[1:6]), round = rep("round", 6), `field*heat` = rep("field*heat", 6), - `rider|heat` = paste0("rider=", gpheats$rider[1:6],":heat"), + `rider|heat` = paste0("rider=", gpheats$rider[1:6], ":heat"), check.names = FALSE ) ) - expect_identical(terms_map4, expected4) - - + expect_identical(terms_map4, expected4) + + term5 <- get_terms( gpheats, - rank|id ~ rider + round + field:heat + name:rider + rank | id ~ rider + round + field:heat + name:rider ) - terms_map5 <- get_terms_map(gpheats[1:6,], term5) + terms_map5 <- get_terms_map(gpheats[1:6, ], term5) expected5 <- as.matrix( data.frame( rider = paste0("rider=", gpheats$rider[1:6]), round = rep("round", 6), `field*heat` = rep("field*heat", 6), - `rider|name` = paste0("rider=", gpheats$rider[1:6],":name=", gpheats$name[1:6]), + `rider|name` = paste0("rider=", gpheats$rider[1:6], ":name=", gpheats$name[1:6]), check.names = FALSE ) ) - expect_identical(terms_map5, expected5) - + expect_identical(terms_map5, expected5) + term6 <- get_terms( gpheats, - rank|id ~ rider + round + field:heat:name + rank | id ~ rider + round + field:heat:name ) - + expect_error( - get_terms_map(gpheats[1:6,], term6), + get_terms_map(gpheats[1:6, ], term6), "Only two-variable interactions are possible" ) }) @@ -363,36 +387,36 @@ test_that("get terms map", { test_that("get terms mat", { term1 <- get_terms( gpheats, - rank|id ~ round + rank | id ~ round ) - terms_mat1 <- get_terms_mat(gpheats[1:6,], term1) + terms_mat1 <- get_terms_mat(gpheats[1:6, ], term1) expected1 <- as.matrix( data.frame( round = gpheats[1:6, "round"] ) ) - expect_identical(terms_mat1, expected1) - - + expect_identical(terms_mat1, expected1) + + term2 <- get_terms( gpheats, - rank|id ~ rider + round + rank | id ~ rider + round ) - terms_mat2 <- get_terms_mat(gpheats[1:6,], term2) + terms_mat2 <- get_terms_mat(gpheats[1:6, ], term2) expected2 <- as.matrix( data.frame( rider = rep(1, 6), round = gpheats[1:6, "round"] ) ) - expect_identical(terms_mat2, expected2) - - + expect_identical(terms_mat2, expected2) + + term4 <- get_terms( gpheats, - rank|id ~ rider + round + field:heat + heat:rider + rank | id ~ rider + round + field:heat + heat:rider ) - terms_mat4 <- get_terms_mat(gpheats[1:6,], term4) + terms_mat4 <- get_terms_mat(gpheats[1:6, ], term4) expected4 <- as.matrix( data.frame( rider = rep(1, 6), @@ -403,14 +427,14 @@ test_that("get terms mat", { row.names = 1:6 ) ) - expect_identical(terms_mat4, expected4) - - + expect_identical(terms_mat4, expected4) + + term5 <- get_terms( gpheats, - rank|id ~ rider + round + field:heat + name:rider + rank | id ~ rider + round + field:heat + name:rider ) - terms_mat5 <- get_terms_mat(gpheats[1:6,], term5) + terms_mat5 <- get_terms_mat(gpheats[1:6, ], term5) expected5 <- as.matrix( data.frame( rider = rep(1, 6), @@ -422,15 +446,15 @@ test_that("get terms mat", { ) ) expect_identical(terms_mat5, expected5) - - + + term6 <- get_terms( gpheats, - rank|id ~ rider + round + field:heat:name + rank | id ~ rider + round + field:heat:name ) - + expect_error( - get_terms_mat(gpheats[1:6,], term6), + get_terms_mat(gpheats[1:6, ], term6), "Only two-variable interactions are possible" ) }) @@ -439,48 +463,47 @@ test_that("get terms mat", { test_that("get terms cls", { term1 <- get_terms( gpheats, - rank|id ~ round + rank | id ~ round ) - terms_cls1 <- get_terms_cls(gpheats[1:6,], term1) + terms_cls1 <- get_terms_cls(gpheats[1:6, ], term1) expected1 <- "numeric" - expect_identical(terms_cls1, expected1) - - + expect_identical(terms_cls1, expected1) + + term2 <- get_terms( gpheats, - rank|id ~ rider + round + rank | id ~ rider + round ) - terms_cls2 <- get_terms_cls(gpheats[1:6,], term2) - expected2 <- c("character", "numeric") - expect_identical(terms_cls2, expected2) - - + terms_cls2 <- get_terms_cls(gpheats[1:6, ], term2) + expected2 <- c("character", "numeric") + expect_identical(terms_cls2, expected2) + + term4 <- get_terms( gpheats, - rank|id ~ rider + round + field:heat + heat:rider + rank | id ~ rider + round + field:heat + heat:rider ) - terms_cls4 <- get_terms_cls(gpheats[1:6,], term4) + terms_cls4 <- get_terms_cls(gpheats[1:6, ], term4) expected4 <- c("character", "numeric", "numeric", "character") - expect_identical(terms_cls4, expected4) - - + expect_identical(terms_cls4, expected4) + + term5 <- get_terms( gpheats, - rank|id ~ rider + round + field:heat + name:rider + rank | id ~ rider + round + field:heat + name:rider ) - terms_cls5 <- get_terms_cls(gpheats[1:6,], term5) + terms_cls5 <- get_terms_cls(gpheats[1:6, ], term5) expected5 <- c("character", "numeric", "numeric", "character") expect_identical(terms_cls5, expected5) - - + + term6 <- get_terms( gpheats, - rank|id ~ rider + round + field:heat:name + rank | id ~ rider + round + field:heat:name ) - + expect_error( - get_terms_cls(gpheats[1:6,], term6), + get_terms_cls(gpheats[1:6, ], term6), "Only two-variable interactions are possible" ) }) - diff --git a/tests/testthat/test_utils.R b/tests/testthat/test_utils.R index e7b8c8a..d401907 100644 --- a/tests/testthat/test_utils.R +++ b/tests/testthat/test_utils.R @@ -30,64 +30,64 @@ test_that("check vector arguments", { check_numeric_argument("a", "test"), "test should be of type numeric" ) - + expect_error( check_numeric_argument(c(1, NA_real_), "test"), "test contains non-finite values" ) - + expect_error( check_numeric_argument(c(-1, 1), "test", min = 0), "test should be in range \\[0, Inf\\]" ) - + expect_error( check_numeric_argument(c(1, 2, 3), "test", max = 2), "values in variable test should be in range \\[-Inf, 2\\]" ) - + expect_error( check_numeric_argument(c(1, 2, 3), "test", min = 2), "values in variable test should be in range \\[2, Inf\\]" ) - + expect_silent(check_numeric_argument(c(1, 2, 3), "test", min = 1, max = 3)) - - - + + + expect_error( check_integer_argument("a", "test"), "test should be of type integer" ) - + expect_error( check_integer_argument(c(1L, NA_integer_), "test"), "test contains non-finite values" ) - + expect_error( check_integer_argument(c(-1L, 1L), "test", min = 0), "test should be in range \\[0, Inf\\]" ) - + expect_error( check_integer_argument(c(1L, 2L, 3L), "test", max = 2), "values in variable test should be in range \\[-Inf, 2\\]" ) - + expect_error( check_integer_argument(c(1L, 2L, 3L), "test", min = 2), "values in variable test should be in range \\[2, Inf\\]" ) - + expect_silent(check_integer_argument(c(1L, 2L, 3L), "test", min = 1, max = 3)) - - + + expect_error( check_string_argument(1, "test"), "test should be of type character" ) - + expect_error( check_string_argument(c("A", NA_character_), "test"), "test contains non-finite values" @@ -99,12 +99,11 @@ test_that("check data", { is_data_provided(), "Data is not provided" ) - + expect_error( are_variables_in_dataset(vars = c("rider2", "team"), data = gpheats), "rider2, team specified in formula not present in data" ) - }) test_that("check initial r", { @@ -117,7 +116,7 @@ test_that("check initial r", { unique_names = "A" ) ) - + expect_identical( setNames(c(1500, 1500), c("A", "B")), init_check_r( @@ -127,7 +126,7 @@ test_that("check initial r", { unique_names = c("A", "B") ) ) - + expect_identical( setNames(c(1500, -1), c("A", "B")), init_check_r( @@ -137,9 +136,9 @@ test_that("check initial r", { unique_names = c("A", "B") ) ) - - - + + + expect_identical( setNames(c(1500, 1500), c("A", "B")), init_check_r( @@ -149,7 +148,7 @@ test_that("check initial r", { unique_names = c("A", "B") ) ) - + expect_identical( setNames(c(99, 99), c("A", "B")), init_check_r( @@ -159,7 +158,7 @@ test_that("check initial r", { unique_names = c("A", "B") ) ) - + expect_warning( new_r <- init_check_r( r = c(A = 1500), @@ -170,7 +169,7 @@ test_that("check initial r", { "Missing parameters will be added" ) expect_identical(new_r, c(A = 1500, B = 1501)) - + expect_error( init_check_r( r = setNames(c(1500, 1500, 1500), c("A", "B", "A")), @@ -180,7 +179,7 @@ test_that("check initial r", { ), "All names in r should be unique. Duplicated names not allowed" ) - + expect_error( init_check_r( r = setNames(c(1500, NA_real_), c("A", "B")), @@ -190,7 +189,7 @@ test_that("check initial r", { ), "All values in r should be a finite number. NA's not allowed" ) - + expect_error( init_check_r( r = NULL, @@ -200,7 +199,7 @@ test_that("check initial r", { ), "init_r should be a finite number" ) - + r <- setNames(c(1500, 1500), c("A", "B")) new_r <- init_check_r( r = r, @@ -208,7 +207,7 @@ test_that("check initial r", { init_r = 1500, unique_names = c("A", "B") ) - + expect_identical( lobstr::obj_addr(r), lobstr::obj_addr(new_r) @@ -225,7 +224,7 @@ test_that("check initial rd", { unique_names = "A" ) ) - + expect_identical( setNames(c(1500, 1500), c("A", "B")), init_check_rd( @@ -235,7 +234,7 @@ test_that("check initial rd", { unique_names = c("A", "B") ) ) - + expect_identical( setNames(c(1500, 1500), c("A", "B")), init_check_rd( @@ -245,7 +244,7 @@ test_that("check initial rd", { unique_names = c("A", "B") ) ) - + expect_identical( setNames(c(9999, 9999), c("A", "B")), init_check_rd( @@ -255,7 +254,7 @@ test_that("check initial rd", { unique_names = c("A", "B") ) ) - + expect_warning( new_rd <- init_check_rd( rd = c(A = 1500), @@ -266,7 +265,7 @@ test_that("check initial rd", { "Missing parameters will be added" ) expect_identical(new_rd, c(A = 1500, B = 1501)) - + expect_error( init_check_rd( rd = setNames(c(1500, 1500, 1500), c("A", "B", "A")), @@ -276,7 +275,7 @@ test_that("check initial rd", { ), "All names in rd should be unique. Duplicated names not allowed" ) - + expect_error( init_check_rd( rd = setNames(c(1500, NA_real_), c("A", "B")), @@ -286,7 +285,7 @@ test_that("check initial rd", { ), "All values in rd should be a finite number. NA's not allowed" ) - + expect_error( init_check_rd( rd = NULL, @@ -296,7 +295,7 @@ test_that("check initial rd", { ), "init_rd value should be positive" ) - + expect_error( init_check_rd( rd = NULL, @@ -306,8 +305,8 @@ test_that("check initial rd", { ), "init_rd value should be positive" ) - - + + expect_error( init_check_rd( rd = setNames(c(1500, -1), c("A", "B")), @@ -317,8 +316,8 @@ test_that("check initial rd", { ), "All values in rd should be positive" ) - - + + rd <- setNames(c(1500, 1500), c("A", "B")) new_rd <- init_check_rd( rd = rd, @@ -326,12 +325,11 @@ test_that("check initial rd", { init_rd = 1500, unique_names = c("A", "B") ) - + expect_identical( lobstr::obj_addr(rd), lobstr::obj_addr(new_rd) ) - }) test_that("check initial sigma", { @@ -345,7 +343,7 @@ test_that("check initial sigma", { method = "glicko" ) ) - + expect_identical( setNames(1500, "A"), init_check_sigma( @@ -356,7 +354,7 @@ test_that("check initial sigma", { method = "glicko2" ) ) - + expect_identical( setNames(c(1500, 1500), c("A", "B")), init_check_sigma( @@ -367,7 +365,7 @@ test_that("check initial sigma", { method = "glicko2" ) ) - + expect_identical( setNames(c(1500, 1500), c("A", "B")), init_check_sigma( @@ -378,7 +376,7 @@ test_that("check initial sigma", { method = "glicko2" ) ) - + expect_identical( setNames(c(9999, 9999), c("A", "B")), init_check_sigma( @@ -400,7 +398,7 @@ test_that("check initial sigma", { "Missing parameters will be added" ) expect_identical(new_sigma, c(A = 1500, B = 1501)) - + expect_error( init_check_sigma( sigma = setNames(c(1500, 1500, 1500), c("A", "B", "A")), @@ -411,7 +409,7 @@ test_that("check initial sigma", { ), "All names in sigma should be unique. Duplicated names not allowed" ) - + expect_error( init_check_sigma( sigma = setNames(c(1500, NA_real_), c("A", "B")), @@ -422,7 +420,7 @@ test_that("check initial sigma", { ), "All values in sigma should be a finite number. NA's not allowed" ) - + expect_error( init_check_sigma( sigma = NULL, @@ -433,7 +431,7 @@ test_that("check initial sigma", { ), "init_sigma value should be positive" ) - + expect_error( init_check_sigma( sigma = NULL, @@ -444,9 +442,9 @@ test_that("check initial sigma", { ), "init_sigma value should be positive" ) - - - + + + expect_error( init_check_sigma( sigma = setNames(c(1500, -1), c("A", "B")), @@ -457,8 +455,8 @@ test_that("check initial sigma", { ), "All values in sigma should be positive" ) - - + + sigma <- setNames(c(1500, 1500), c("A", "B")) new_sigma <- init_check_sigma( sigma = sigma, @@ -467,7 +465,7 @@ test_that("check initial sigma", { unique_names = c("A", "B"), method = "glicko2" ) - + expect_identical( lobstr::obj_addr(sigma), lobstr::obj_addr(new_sigma) @@ -476,29 +474,29 @@ test_that("check initial sigma", { test_that("initialize vector", { gpheats$weight <- 1 - + expect_identical( lobstr::obj_addr(initialize_vec("weight", gpheats, "weight", min = 0)), lobstr::obj_addr(gpheats$weight) ) - + expect_identical( initialize_vec(2, gpheats, "weight", min = 0), rep(2, times = nrow(gpheats)) ) - + expect_error( initialize_vec("weight", gpheats, "weight", min = 0, max = .99), "range" - ) - + ) + expect_error( initialize_vec(2, gpheats, "weight", min = 0, max = .99), "range" - ) - + ) + expect_error( initialize_vec("wrong", gpheats, "weight", min = 0, max = .99), "is not present in data" - ) + ) }) diff --git a/vignettes/sport_in_r.Rmd b/vignettes/sport_in_r.Rmd index 09a2b84..b95bb26 100755 --- a/vignettes/sport_in_r.Rmd +++ b/vignettes/sport_in_r.Rmd @@ -321,4 +321,4 @@ per individuals. ```{r warning=FALSE , message=FALSE} glicko2$pairs glicko2$r -``` \ No newline at end of file +```