testing

reach 100% coverage - The portions of code not covered are those asking the installation of suggested packages
giovsaraceno · Sep 20, 2024 · d907dd7 · d907dd7
1 parent 64b6bce
commit d907dd7
Show file tree

Hide file tree

Showing 12 changed files with 109 additions and 18 deletions.
diff --git a/R/clustering_functions.R b/R/clustering_functions.R
@@ -926,6 +926,10 @@ setMethod("predict", signature(object="pkbc"),
       newdata <- as.matrix(newdata)
    }
 
+   if(!is.numeric(newdata)){
+      stop("newdata must be numeric")
+   }
+
    # Ensure that x has the same number of columns as the training data
    if (ncol(newdata) != ncol(object@input$dat)) {
    stop("newdata must have the same number of variables as the training data.")
@@ -1077,6 +1081,7 @@ setMethod("predict", signature(object="pkbc"),
 #' @export
 pkbc_validation <- function(object, true_label=NULL){
 
+   # nocov start
    if (!requireNamespace("mclust", quietly = TRUE)) {
       install <- readline(prompt = "'mclust' is required for ARI. Would you 
                           like to install it now? (yes/no): ")
@@ -1109,6 +1114,7 @@ pkbc_validation <- function(object, true_label=NULL){
          return(NULL)
       }
    }
+   # nocov end
 
    x <- object@input$dat
    x <- x/sqrt(rowSums(x^2))

diff --git a/R/critical_value.R b/R/critical_value.R
@@ -118,7 +118,6 @@ poisson_CV<-function(d, size, rho, B, Quantile){
 
    }
    return(as.numeric(quantile(Results, Quantile)))
-
 }
 #' 
 #' Compute the critical value for the KBQD tests for multivariate Normality 

diff --git a/R/h_selection.R b/R/h_selection.R
@@ -338,8 +338,9 @@ select_h <- function(x, y=NULL, alternative=NULL, method="subsampling", b=0.8,
 
    chk <- Sys.getenv("_R_CHECK_LIMIT_CORES_", "")
    if (nzchar(chk) && chk == "TRUE") {
-      # use 2 cores in CRAN/Travis/AppVeyor
-      num_cores <- 2L
+      # nocov start 
+      num_cores <- 2
+      # nocov end
    } else if(is.null(n_cores)) {
       num_cores <- detectCores()
    } else if (is.numeric(n_cores)) {

diff --git a/R/kb.test.R b/R/kb.test.R
@@ -318,7 +318,7 @@ setMethod("kb.test", signature(x = "ANY"),
                 if(any(is.na(y))){
                    stop("There are missing values in y!")
                 } else if(any(is.infinite(y) |is.nan(y))){
-                   stop("There are undefined values in y, that is Nan, Inf")
+               stop("There are undefined values in y, that is Nan, Inf, -Inf")
                 }
              }
 

diff --git a/R/pkbd_functions.R b/R/pkbd_functions.R
@@ -168,8 +168,10 @@ rpkb <- function(n, mu, rho, method = 'rejacg',
                  tol.eps = .Machine$double.eps^0.25, 
                  max.iter = 1000) {
 
+
+   # nocov start
    if (!requireNamespace("movMF", quietly = TRUE)) {
-      install <- readline(prompt = "'movMF' is required for 'rejvmf' method. 
+      install <- readline(prompt = "'movMF' is required for 'rejvmf' method.
                            Would you like to install it now? (yes/no): ")
       if (tolower(install) == "yes") {
          install.packages("movMF")
@@ -189,6 +191,7 @@ rpkb <- function(n, mu, rho, method = 'rejacg',
          return(NULL)
       }
    }
+   # nocov end
    if (rho >= 1 | rho < 0) {
       stop('Input argument rho must be within [0,1)')
    }
@@ -396,4 +399,4 @@ rejpsaw <- function(n, rho, mu, p){
 
    res <- list(x = retvals, numAccepted = numAccepted, numTries = numTries)
    return(res)   
-}
+}
diff --git a/README.md b/README.md
@@ -1,11 +1,8 @@
 <!-- badges: start -->
 
-[![Project Status: Active – The project has reached a stable, usable state and is being actively developed.](https://www.repostatus.org/badges/latest/active.svg)](https://www.repostatus.org/#active) 
-[![CRAN status](https://www.r-pkg.org/badges/version/QuadratiK)](https://CRAN.R-project.org/package=QuadratiK) 
-[![Status at rOpenSci Software Peer Review](https://badges.ropensci.org/632_status.svg)](https://github.com/ropensci/software-review/issues/632) 
-[![R-CMD-check](https://github.com/giovsaraceno/QuadratiK-package/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/giovsaraceno/QuadratiK-package/actions/workflows/R-CMD-check.yaml) 
-[![CRAN_Downloads_Badge](https://cranlogs.r-pkg.org/badges/grand-total/QuadratiK)](https://cran.r-project.org/package=QuadratiK)
-[![codecov](https://codecov.io/github/giovsaraceno/QuadratiK-package/graph/badge.svg?token=M4CDTQPONE)](https://codecov.io/github/giovsaraceno/QuadratiK-package)
+| Usage  | Release | Development |
+|------------------|------------------------|------------------------------|
+| [![CRAN_Downloads_Badge](https://cranlogs.r-pkg.org/badges/grand-total/QuadratiK)](https://cran.r-project.org/package=QuadratiK) [![License: GPL (\>= 3)](https://img.shields.io/badge/license-GPL%20(%3E=%203)-blue.svg)](https://cran.r-project.org/web/licenses/GPL%20(%3E=%203)) | [![arXiv](https://img.shields.io/badge/doi-arXiv:2402.02290v2-green.svg)](https://doi.org/arXiv:2402.02290v2) [![CRAN version](https://www.r-pkg.org/badges/version/QuadratiK)](https://CRAN.R-project.org/package=QuadratiK) [![GitHub version](https://img.shields.io/badge/devel%20version-1.1.2-blue.svg)](https://github.com/giovsaraceno/QuadratiK-package) | [![Project Status: Active – The project has reached a stable, usable state and is being actively developed.](https://www.repostatus.org/badges/latest/active.svg)](https://www.repostatus.org/#active) [![Status at rOpenSci Software Peer Review](https://badges.ropensci.org/632_status.svg)](https://github.com/ropensci/software-review/issues/632) [![codecov](https://codecov.io/github/giovsaraceno/QuadratiK-package/graph/badge.svg?token=M4CDTQPONE)](https://codecov.io/github/giovsaraceno/QuadratiK-package) [![R-CMD-check](https://github.com/giovsaraceno/QuadratiK-package/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/giovsaraceno/QuadratiK-package/actions/workflows/R-CMD-check.yaml) [![Lifecycle](https://img.shields.io/badge/lifecycle-experimental-green.svg)](https://lifecycle.r-lib.org/articles/stages.html#stable) |
 
 <!-- badges: end -->
 
@@ -64,7 +61,7 @@ Saraceno G, Markatou M, Mukhopadhyay R, Golzy M (2024). QuadratiK: Collection of
 
 and the associated paper:
 
-Saraceno Giovanni, Markatou Marianthi, Mukhopadhyay Raktim, Golzy Mojgan (2024). Goodness-of-Fit and Clustering of Spherical Data: the QuadratiK package in R and Python. arXiv preprint [arXiv:2402.02290](https://arxiv.org/abs/2402.02290).
+Saraceno Giovanni, Markatou Marianthi, Mukhopadhyay Raktim, Golzy Mojgan (2024). Goodness-of-Fit and Clustering of Spherical Data: the QuadratiK package in R and Python. arXiv preprint [arXiv:2402.02290v2](https://arxiv.org/abs/2402.02290).
 
 ```         
 @misc{saraceno2024package, 

diff --git a/man/plot.pkbc.Rd b/man/plot.pkbc.Rd
diff --git a/src/QuadratiK.dll b/src/QuadratiK.dll
diff --git a/tests/testthat/test-kb.test.R b/tests/testthat/test-kb.test.R
@@ -58,6 +58,28 @@ test_that("Error on invalid centeringType input", {
 # Test 5: Correct handling of vector x input
 test_that("Handle vector x input correctly", {
 
+   # NA in the data
+   datx <- matrix(rnorm(100),ncol=2)
+   daty <- matrix(rnorm(100),ncol=2)
+   daty[1,] <- NA 
+   expect_error(kb.test(x = datx, y = daty, h = 0.8), 
+                'There are missing values in y!', fixed=TRUE)
+   datx[1,] <- NA 
+   expect_error(kb.test(x = datx, h = 0.8), 
+                'There are missing values in x!', fixed=TRUE)
+
+   # Inf or Nan in the data
+   datx <- matrix(rnorm(100),ncol=2)
+   daty <- matrix(rnorm(100),ncol=2)
+   daty[1,] <- Inf 
+   expect_error(kb.test(x = datx, y = daty, h = 0.8), 
+                'There are undefined values in y, that is Nan, Inf, -Inf', 
+                fixed=TRUE)
+   datx[1,] <- Inf 
+   expect_error(kb.test(x = datx, h = 0.8), 
+                'There are undefined values in x, that is Nan, Inf, -Inf', 
+                fixed=TRUE)
+
    set.seed(123)
    # x is a vector
    result <- kb.test(x = rnorm(10), h=0.5)
@@ -72,6 +94,11 @@ test_that("Handle vector x input correctly", {
    result <- kb.test(x = matrix(rnorm(20),ncol=2), h=0.5)
    expect_s4_class(result, "kb.test")
 
+   # test show method
+   output <- capture.output(show(result))
+   expect_true(any(grepl("\t\tU-statistic\tV-statistic", output)))
+   expect_true(any(grepl("H0 is rejected:\t", output)))
+
    # test summary method
    s <- summary(result)
    expect_true("matrix" %in% class(s$summary_tables))

diff --git a/tests/testthat/test-pk.test.R b/tests/testthat/test-pk.test.R
@@ -24,6 +24,19 @@ test_that("Error on invalid x input", {
          "x must be a matrix or a data.frame with dimension greater 
                      than 1.", 
          fixed=TRUE)
+
+   # NA in the data
+   dat <- matrix(rnorm(100),ncol=2)
+   dat[1,] <- NA 
+   expect_error(pk.test(x = dat, rho = 0.8), 
+                'There are missing values in x!', fixed=TRUE)
+
+   # Inf or Nan in the data
+   dat <- matrix(rnorm(100),ncol=2)
+   dat[1,] <- Inf 
+   expect_error(pk.test(x = dat, rho = 0.8), 
+                'There are undefined values in x, that is Nan, Inf, -Inf', 
+                fixed=TRUE)
 })
 
 # Test 2: Error on Invalid Quantile Input

diff --git a/tests/testthat/test-pkbc.R b/tests/testthat/test-pkbc.R
@@ -171,7 +171,7 @@ test_that("plot method for the clustering algorithm", {
    label <- rep(c(1,2),each=50)
    pkbd_res<- pkbc(dat, c(2,3))
    # Tests for plot method
-   expect_silent(plot(pkbd_res,k = 2))
+   expect_silent(plot(pkbd_res,k = 2, pca_res = TRUE))
    expect_silent(plot(pkbd_res,k = 2,true_label=label))
 })
 
@@ -184,11 +184,27 @@ test_that("plot method for the clustering algorithm", {
    dat<-rbind(x,y)
    label <- rep(c(1,2),each=50)
    pkbd_res<- pkbc(dat, c(2,3))
+
+   # Correct newdata input
+   newdat <- "invalid"
+   expect_error(predict(pkbd_res, k = 2, newdat), 
+                'newdata must be a matrix or data.frame.', fixed=TRUE)
+
+   newdat <- matrix("invalid", ncol=2, nrow=50)
+   expect_error(predict(pkbd_res, k = 2, newdat), 
+                'newdata must be numeric', fixed=TRUE)
+
+   newdat <- matrix(rnorm(150),ncol=3)
+   expect_error(predict(pkbd_res, k = 2, newdat), 
+         'newdata must have the same number of variables as the training data.', 
+                fixed=TRUE)
+
+
    # Tests for predict method
    expect_equal(predict(pkbd_res,k=2),pkbd_res@res_k[[2]]$finalMemb)
 
-   newdat <- rbind(rpkb(50, c(1,0),0.99, method = "rejacg")$x,
-                   rpkb(50, c(-1,0),0.99, method = "rejacg")$x)
+   newdat <- as.data.frame(rbind(rpkb(50, c(1,0),0.99, method = "rejacg")$x,
+                   rpkb(50, c(-1,0),0.99, method = "rejacg")$x))
    expect_equal(predict(pkbd_res, k=2, newdat)$Memb,rep(c(2,1),each=50))
 
 

diff --git a/tests/testthat/test-select_h.R b/tests/testthat/test-select_h.R
@@ -15,6 +15,10 @@ library(testthat)
 # Test 1: Verify Error on Invalid Input
 test_that("Error on invalid method input", {
 
+   expect_error(select_h(x = matrix(rnorm(100), ncol = 2), 
+                         alternative = "location", n_cores = "invalid"), 
+                "n_cores must be a numeric value", fixed=TRUE)
+
    set.seed(123)
    expect_error(select_h(x = matrix(rnorm(100), ncol = 2), 
                         alternative = "invalid"), 
@@ -58,8 +62,8 @@ test_that("Error on invalid method input", {
    "delta_dim must be 1 or a numeric vector of length equal to the 
               number of columns of pooled.", fixed=TRUE)
 
-   x <- matrix(rnorm(100), ncol = 2)
-   y <- matrix(rnorm(100), ncol = 2)
+   x <- rnorm(50)
+   y <- rnorm(50, 10)
    expect_error(select_h(x, y, alternative="skewness", 
                          h_values = c("a","b","c")), 
                 "h_values must be a numeric vector", fixed=TRUE)
@@ -78,16 +82,38 @@ test_that("Select h", {
                       alternative="location")
    expect_equal(class(result$h_sel), "numeric")
    expect_equal(class(result$power), "data.frame")
+
+   result <- select_h(x = as.data.frame(matrix(rnorm(20),ncol=2)), 
+                      alternative="scale", n_cores = 2)
+   expect_equal(class(result$h_sel), "numeric")
+   expect_equal(class(result$power), "data.frame")
 
    # two-sample
+   result <- select_h(x = matrix(rnorm(20),ncol=2),
+                      y = as.data.frame(matrix(rnorm(20),ncol=2)), alternative="location")
+   expect_equal(class(result$h_sel), "numeric")
+   expect_equal(class(result$power), "data.frame")
+
    result <- select_h(x = matrix(rnorm(20),ncol=2),
    y = matrix(rnorm(20),ncol=2), alternative="skewness")
    expect_equal(class(result$h_sel), "numeric")
    expect_equal(class(result$power), "data.frame")
+
+   result <- select_h(x = matrix(rnorm(20),ncol=2),
+                      y = matrix(rnorm(20),ncol=2), alternative="scale")
+   expect_equal(class(result$h_sel), "numeric")
+   expect_equal(class(result$power), "data.frame")
 
    # k-sample
    result <- select_h(x = matrix(rnorm(30),ncol=2), y = rep(c(1,2,3),each=5),
    alternative="scale")
    expect_equal(class(result$h_sel), "numeric")
    expect_equal(class(result$power), "data.frame")
+
+   result <- select_h(x = matrix(rnorm(30),ncol=2), y = rep(c(1,2,3),each=5),
+                      alternative="location")
+   expect_equal(class(result$h_sel), "numeric")
+   expect_equal(class(result$power), "data.frame")
 })
+
+