From b174ff3cc8953878750779f003f4ea9a73e94327 Mon Sep 17 00:00:00 2001 From: Claudia Beleites Date: Mon, 31 May 2021 20:50:37 +0200 Subject: [PATCH 01/27] include deprecated.R in Collate: order --- hyperSpec/DESCRIPTION | 1 - 1 file changed, 1 deletion(-) diff --git a/hyperSpec/DESCRIPTION b/hyperSpec/DESCRIPTION index e907ecd5..1b2e5ff9 100644 --- a/hyperSpec/DESCRIPTION +++ b/hyperSpec/DESCRIPTION @@ -132,7 +132,6 @@ Collate: 'constants-units.R' 'cov.R' 'decomposition.R' - 'deprecated.R' 'dim.R' 'dimnames.R' 'droplevels.R' From 611513d9d39945d473b72919d54cc75827e9e1a6 Mon Sep 17 00:00:00 2001 From: Claudia Beleites Date: Mon, 31 May 2021 20:51:24 +0200 Subject: [PATCH 02/27] fix deprecated function unit test unit test should only check for deprecation message --- hyperSpec/R/DEPRECATED-read.txt.Witec.R | 188 ++---------------------- 1 file changed, 15 insertions(+), 173 deletions(-) diff --git a/hyperSpec/R/DEPRECATED-read.txt.Witec.R b/hyperSpec/R/DEPRECATED-read.txt.Witec.R index e5bd3d7a..e0780fa1 100644 --- a/hyperSpec/R/DEPRECATED-read.txt.Witec.R +++ b/hyperSpec/R/DEPRECATED-read.txt.Witec.R @@ -38,7 +38,7 @@ #' @export #' #' @importFrom utils head -read.txt.Witec <- function(file = stop("filename or connection needed"), +read.txt.Witec <- function(file = NULL, points.per.line = NULL, lines.per.image = NULL, type = c("single", "map"), @@ -50,6 +50,9 @@ read.txt.Witec <- function(file = stop("filename or connection needed"), # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ deprecated_read_txt() + + if (is.null (file)) return (NA) # allow checking for deprecation w/o failure + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ## check for valid data connection @@ -94,101 +97,7 @@ read.txt.Witec <- function(file = stop("filename or connection needed"), hySpc.testthat::test(read.txt.Witec) <- function() { context("read.txt.Witec") - test_that("Map with neither header nor label lines", { - skip_if_not_fileio_available() - expect_error(suppressWarnings(read.txt.Witec("fileio/txt.Witec/Witec-Map_no.txt", - type = "map", hdr.units = TRUE, hdr.label = TRUE - ))) - expect_warning(read.txt.Witec("fileio/txt.Witec/Witec-Map_no.txt", type = "map")) - - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_no.txt", type = "map", points.per.line = 5, lines.per.image = 5) - expect_known_hash(spc, hash = "6816a87cf3") - }) - - test_that("Map: one of points.per.line and lines.per.image is sufficient", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_no.txt", type = "map", lines.per.image = 5) - expect_known_hash(spc, hash = "6816a87cf3") - - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_no.txt", type = "map", points.per.line = 5) - expect_known_hash(spc, hash = "6816a87cf3") - }) - - test_that("Map with label line but no units header", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_label.txt", type = "map", hdr.units = FALSE, hdr.label = TRUE) - expect_known_hash(spc, "c4a384d6b2") - }) - - test_that("Map with units header line but no labels", { - skip_if_not_fileio_available() - expect_warning(spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_unit.txt", type = "map", hdr.units = TRUE, hdr.label = FALSE)) - expect_null(spc$x) - expect_null(spc$y) - - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_unit.txt", - type = "map", hdr.units = TRUE, hdr.label = FALSE, - points.per.line = 5, lines.per.image = 5 - ) - expect_known_hash(spc, "86ecc17360") - }) - - test_that("Map with header and label lines", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_full.txt", type = "map", hdr.units = TRUE, hdr.label = TRUE) - expect_known_hash(spc, "76db6397fc") - }) - - test_that("Map can be read as time series", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_no.txt") - expect_known_hash(spc, "6213aefc6b") - expect_null(spc$x) - expect_null(spc$y) - }) - - - test_that("parameter default type = 'single'", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_no.txt") - expect_known_hash(spc, "1a8c3be079") - }) - - test_that("Time series with neither header nor label lines", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_no.txt") - expect_known_hash(spc, "1a8c3be079") - }) - - test_that("Time series with label line but no units header", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_label.txt", hdr.units = FALSE, hdr.label = TRUE) - expect_known_hash(spc, "4cb098a671") - }) - - test_that("Time series with units header line but no labels", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_unit.txt", hdr.units = TRUE, hdr.label = FALSE) - - expect_known_hash(spc, "6b6abac4e8") - }) - - test_that("Time series with header and label lines", { - skip_if_not_fileio_available() - expect_error(spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_full.txt")) - - spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_full.txt", hdr.units = TRUE, hdr.label = TRUE) - expect_known_hash(spc, "db5b1a5db0") - }) - - test_that("encoding", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_full.txt", - hdr.units = TRUE, hdr.label = TRUE, - encoding = "ascii" - ) - expect_known_hash(spc, "db5b1a5db0") - }) + test_that("deprecated", expect_warning(read.txt.Witec (), "deprecated")) } #' @rdname DEPRECATED-read.txt.Witec @@ -198,7 +107,7 @@ hySpc.testthat::test(read.txt.Witec) <- function() { #' @param filey filename intensity file #' #' @export -read.dat.Witec <- function(filex = stop("filename or connection needed"), +read.dat.Witec <- function(filex = NULL, filey = sub("-x", "-y", filex), points.per.line = NULL, lines.per.image = NULL, @@ -209,6 +118,9 @@ read.dat.Witec <- function(filex = stop("filename or connection needed"), # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ deprecated_read_txt() + + if (is.null (file)) return (NA) # allow checking for deprecation w/o failure + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ## check valid data connection @@ -240,43 +152,8 @@ read.dat.Witec <- function(filex = stop("filename or connection needed"), hySpc.testthat::test(read.dat.Witec) <- function() { context("read.dat.Witec") - test_that("-y file guessing", { - skip_if_not_fileio_available() - spc <- read.dat.Witec("fileio/txt.Witec/Witec-timeseries-x.dat") - expect_known_hash(spc, "9562f59323") - }) - - test_that("encoding", { - skip_if_not_fileio_available() - spc <- read.dat.Witec("fileio/txt.Witec/Witec-timeseries-x.dat", encoding = "ascii") - expect_known_hash(spc, "9562f59323") - }) - - test_that("Time series", { - skip_if_not_fileio_available() - spc <- read.dat.Witec("fileio/txt.Witec/Witec-timeseries-x.dat", "fileio/txt.Witec/Witec-timeseries-y.dat") - expect_known_hash(spc, "9562f59323") - }) - - test_that("Map: .dat does not have spatial information", { - skip_if_not_fileio_available() - spc <- read.dat.Witec("fileio/txt.Witec/Witec-Map-x.dat", "fileio/txt.Witec/Witec-Map-y.dat") - expect_null(spc$x) - expect_null(spc$y) - expect_known_hash(spc, "8a7ed06b0b") - }) - - test_that("Map", { - skip_if_not_fileio_available() - expect_warning(read.dat.Witec("fileio/txt.Witec/Witec-Map-x.dat", "fileio/txt.Witec/Witec-Map-y.dat", - points.per.line = 5, lines.per.image = 5 - )) + test_that("deprecated", expect_warning(read.dat.Witec (), "deprecated")) - spc <- read.dat.Witec("fileio/txt.Witec/Witec-Map-x.dat", "fileio/txt.Witec/Witec-Map-y.dat", - type = "map", points.per.line = 5, lines.per.image = 5 - ) - expect_known_hash(spc, "3d6339675b") - }) } @@ -286,7 +163,7 @@ hySpc.testthat::test(read.dat.Witec) <- function() { #' @param headerfile filename or connection to ASCII file with header information #' #' @export -read.txt.Witec.Graph <- function(headerfile = stop("filename or connection needed"), +read.txt.Witec.Graph <- function(headerfile = NULL, filex = gsub("Header", "X-Axis", headerfile), filey = gsub("Header", "Y-Axis", headerfile), type = c("single", "map"), encoding = "unknown", @@ -294,6 +171,9 @@ read.txt.Witec.Graph <- function(headerfile = stop("filename or connection neede # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ deprecated_read_txt() + + if (is.null (file)) return (NA) # allow checking for deprecation w/o failure + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ## check for valid data connection @@ -341,45 +221,7 @@ read.txt.Witec.Graph <- function(headerfile = stop("filename or connection neede hySpc.testthat::test(read.txt.Witec.Graph) <- function() { context("read.txt.Witec.Graph") - test_that("defaults and (X-Axis)/(Y-Axis) file guessing", { - skip_if_not_fileio_available() - spc <- read.txt.Witec.Graph("fileio/txt.Witec/Witec-timeseries (Header).txt") - expect_known_hash(spc, "295499c43c") - }) - - test_that("encoding", { - skip_if_not_fileio_available() - expect_warning(read.txt.Witec.Graph("fileio/txt.Witec/nofilename (Header).txt")) - - spc <- read.txt.Witec.Graph("fileio/txt.Witec/nofilename (Header).txt", encoding = "latin1") - expect_known_hash(spc, "2bad36adb3") - }) - - test_that("Time Series", { - skip_if_not_fileio_available() - spc <- read.txt.Witec.Graph("fileio/txt.Witec/Witec-timeseries (Header).txt", type = "single") - expect_known_hash(spc, "295499c43c") - }) - - test_that("Map", { - skip_if_not_fileio_available() - expect_warning(read.txt.Witec.Graph("fileio/txt.Witec/Witec-Map (Header).txt")) - expect_warning(read.txt.Witec.Graph("fileio/txt.Witec/Witec-Map (Header).txt", type = "single")) - - spc <- read.txt.Witec.Graph("fileio/txt.Witec/Witec-Map (Header).txt", type = "map") - expect_known_hash(spc, "cb9cd9757a") - }) - - test_that("missing filename", { - skip_if_not_fileio_available() - spc <- read.txt.Witec.Graph("fileio/txt.Witec/nofilename (Header).txt", encoding = "latin1") - expect_known_hash(spc, "2bad36adb3") - }) - - test_that("wrong combination of file names", { - skip_if_not_fileio_available() - expect_error(read.txt.Witec.Graph("fileio/txt.Witec/Witec-timeseries (Header).txt", "fileio/txt.Witec/Witec-timeseries (Y-Axis).txt")) - }) + test_that("deprecated", expect_warning(read.txt.Witec.Graph (), "deprecated")) } ### -------- helpers ------------------------ From a49a8d016393ab79d4f7222b0d03ac76fb56a984 Mon Sep 17 00:00:00 2001 From: Claudia Beleites Date: Mon, 31 May 2021 20:51:24 +0200 Subject: [PATCH 03/27] fix deprecated function unit test unit test should only check for deprecation message --- hyperSpec/R/DEPRECATED-read.txt.Witec.R | 188 ++---------------------- 1 file changed, 15 insertions(+), 173 deletions(-) diff --git a/hyperSpec/R/DEPRECATED-read.txt.Witec.R b/hyperSpec/R/DEPRECATED-read.txt.Witec.R index e5bd3d7a..1ae087b0 100644 --- a/hyperSpec/R/DEPRECATED-read.txt.Witec.R +++ b/hyperSpec/R/DEPRECATED-read.txt.Witec.R @@ -38,7 +38,7 @@ #' @export #' #' @importFrom utils head -read.txt.Witec <- function(file = stop("filename or connection needed"), +read.txt.Witec <- function(file = NULL, points.per.line = NULL, lines.per.image = NULL, type = c("single", "map"), @@ -50,6 +50,9 @@ read.txt.Witec <- function(file = stop("filename or connection needed"), # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ deprecated_read_txt() + + if (is.null (file)) return (NA) # allow checking for deprecation w/o failure + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ## check for valid data connection @@ -94,101 +97,7 @@ read.txt.Witec <- function(file = stop("filename or connection needed"), hySpc.testthat::test(read.txt.Witec) <- function() { context("read.txt.Witec") - test_that("Map with neither header nor label lines", { - skip_if_not_fileio_available() - expect_error(suppressWarnings(read.txt.Witec("fileio/txt.Witec/Witec-Map_no.txt", - type = "map", hdr.units = TRUE, hdr.label = TRUE - ))) - expect_warning(read.txt.Witec("fileio/txt.Witec/Witec-Map_no.txt", type = "map")) - - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_no.txt", type = "map", points.per.line = 5, lines.per.image = 5) - expect_known_hash(spc, hash = "6816a87cf3") - }) - - test_that("Map: one of points.per.line and lines.per.image is sufficient", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_no.txt", type = "map", lines.per.image = 5) - expect_known_hash(spc, hash = "6816a87cf3") - - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_no.txt", type = "map", points.per.line = 5) - expect_known_hash(spc, hash = "6816a87cf3") - }) - - test_that("Map with label line but no units header", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_label.txt", type = "map", hdr.units = FALSE, hdr.label = TRUE) - expect_known_hash(spc, "c4a384d6b2") - }) - - test_that("Map with units header line but no labels", { - skip_if_not_fileio_available() - expect_warning(spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_unit.txt", type = "map", hdr.units = TRUE, hdr.label = FALSE)) - expect_null(spc$x) - expect_null(spc$y) - - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_unit.txt", - type = "map", hdr.units = TRUE, hdr.label = FALSE, - points.per.line = 5, lines.per.image = 5 - ) - expect_known_hash(spc, "86ecc17360") - }) - - test_that("Map with header and label lines", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_full.txt", type = "map", hdr.units = TRUE, hdr.label = TRUE) - expect_known_hash(spc, "76db6397fc") - }) - - test_that("Map can be read as time series", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-Map_no.txt") - expect_known_hash(spc, "6213aefc6b") - expect_null(spc$x) - expect_null(spc$y) - }) - - - test_that("parameter default type = 'single'", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_no.txt") - expect_known_hash(spc, "1a8c3be079") - }) - - test_that("Time series with neither header nor label lines", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_no.txt") - expect_known_hash(spc, "1a8c3be079") - }) - - test_that("Time series with label line but no units header", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_label.txt", hdr.units = FALSE, hdr.label = TRUE) - expect_known_hash(spc, "4cb098a671") - }) - - test_that("Time series with units header line but no labels", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_unit.txt", hdr.units = TRUE, hdr.label = FALSE) - - expect_known_hash(spc, "6b6abac4e8") - }) - - test_that("Time series with header and label lines", { - skip_if_not_fileio_available() - expect_error(spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_full.txt")) - - spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_full.txt", hdr.units = TRUE, hdr.label = TRUE) - expect_known_hash(spc, "db5b1a5db0") - }) - - test_that("encoding", { - skip_if_not_fileio_available() - spc <- read.txt.Witec("fileio/txt.Witec/Witec-timeseries_full.txt", - hdr.units = TRUE, hdr.label = TRUE, - encoding = "ascii" - ) - expect_known_hash(spc, "db5b1a5db0") - }) + test_that("deprecated", expect_warning(read.txt.Witec (), "deprecated")) } #' @rdname DEPRECATED-read.txt.Witec @@ -198,7 +107,7 @@ hySpc.testthat::test(read.txt.Witec) <- function() { #' @param filey filename intensity file #' #' @export -read.dat.Witec <- function(filex = stop("filename or connection needed"), +read.dat.Witec <- function(filex = NULL, filey = sub("-x", "-y", filex), points.per.line = NULL, lines.per.image = NULL, @@ -209,6 +118,9 @@ read.dat.Witec <- function(filex = stop("filename or connection needed"), # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ deprecated_read_txt() + + if (is.null (filex)) return (NA) # allow checking for deprecation w/o failure + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ## check valid data connection @@ -240,43 +152,8 @@ read.dat.Witec <- function(filex = stop("filename or connection needed"), hySpc.testthat::test(read.dat.Witec) <- function() { context("read.dat.Witec") - test_that("-y file guessing", { - skip_if_not_fileio_available() - spc <- read.dat.Witec("fileio/txt.Witec/Witec-timeseries-x.dat") - expect_known_hash(spc, "9562f59323") - }) - - test_that("encoding", { - skip_if_not_fileio_available() - spc <- read.dat.Witec("fileio/txt.Witec/Witec-timeseries-x.dat", encoding = "ascii") - expect_known_hash(spc, "9562f59323") - }) - - test_that("Time series", { - skip_if_not_fileio_available() - spc <- read.dat.Witec("fileio/txt.Witec/Witec-timeseries-x.dat", "fileio/txt.Witec/Witec-timeseries-y.dat") - expect_known_hash(spc, "9562f59323") - }) - - test_that("Map: .dat does not have spatial information", { - skip_if_not_fileio_available() - spc <- read.dat.Witec("fileio/txt.Witec/Witec-Map-x.dat", "fileio/txt.Witec/Witec-Map-y.dat") - expect_null(spc$x) - expect_null(spc$y) - expect_known_hash(spc, "8a7ed06b0b") - }) - - test_that("Map", { - skip_if_not_fileio_available() - expect_warning(read.dat.Witec("fileio/txt.Witec/Witec-Map-x.dat", "fileio/txt.Witec/Witec-Map-y.dat", - points.per.line = 5, lines.per.image = 5 - )) + test_that("deprecated", expect_warning(read.dat.Witec (), "deprecated")) - spc <- read.dat.Witec("fileio/txt.Witec/Witec-Map-x.dat", "fileio/txt.Witec/Witec-Map-y.dat", - type = "map", points.per.line = 5, lines.per.image = 5 - ) - expect_known_hash(spc, "3d6339675b") - }) } @@ -286,7 +163,7 @@ hySpc.testthat::test(read.dat.Witec) <- function() { #' @param headerfile filename or connection to ASCII file with header information #' #' @export -read.txt.Witec.Graph <- function(headerfile = stop("filename or connection needed"), +read.txt.Witec.Graph <- function(headerfile = NULL, filex = gsub("Header", "X-Axis", headerfile), filey = gsub("Header", "Y-Axis", headerfile), type = c("single", "map"), encoding = "unknown", @@ -294,6 +171,9 @@ read.txt.Witec.Graph <- function(headerfile = stop("filename or connection neede # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ deprecated_read_txt() + + if (is.null (headerfile)) return (NA) # allow checking for deprecation w/o failure + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ## check for valid data connection @@ -341,45 +221,7 @@ read.txt.Witec.Graph <- function(headerfile = stop("filename or connection neede hySpc.testthat::test(read.txt.Witec.Graph) <- function() { context("read.txt.Witec.Graph") - test_that("defaults and (X-Axis)/(Y-Axis) file guessing", { - skip_if_not_fileio_available() - spc <- read.txt.Witec.Graph("fileio/txt.Witec/Witec-timeseries (Header).txt") - expect_known_hash(spc, "295499c43c") - }) - - test_that("encoding", { - skip_if_not_fileio_available() - expect_warning(read.txt.Witec.Graph("fileio/txt.Witec/nofilename (Header).txt")) - - spc <- read.txt.Witec.Graph("fileio/txt.Witec/nofilename (Header).txt", encoding = "latin1") - expect_known_hash(spc, "2bad36adb3") - }) - - test_that("Time Series", { - skip_if_not_fileio_available() - spc <- read.txt.Witec.Graph("fileio/txt.Witec/Witec-timeseries (Header).txt", type = "single") - expect_known_hash(spc, "295499c43c") - }) - - test_that("Map", { - skip_if_not_fileio_available() - expect_warning(read.txt.Witec.Graph("fileio/txt.Witec/Witec-Map (Header).txt")) - expect_warning(read.txt.Witec.Graph("fileio/txt.Witec/Witec-Map (Header).txt", type = "single")) - - spc <- read.txt.Witec.Graph("fileio/txt.Witec/Witec-Map (Header).txt", type = "map") - expect_known_hash(spc, "cb9cd9757a") - }) - - test_that("missing filename", { - skip_if_not_fileio_available() - spc <- read.txt.Witec.Graph("fileio/txt.Witec/nofilename (Header).txt", encoding = "latin1") - expect_known_hash(spc, "2bad36adb3") - }) - - test_that("wrong combination of file names", { - skip_if_not_fileio_available() - expect_error(read.txt.Witec.Graph("fileio/txt.Witec/Witec-timeseries (Header).txt", "fileio/txt.Witec/Witec-timeseries (Y-Axis).txt")) - }) + test_that("deprecated", expect_warning(read.txt.Witec.Graph (), "deprecated")) } ### -------- helpers ------------------------ From ee14e8d9954504e407bc0c90c813cc13d6b874ee Mon Sep 17 00:00:00 2001 From: Claudia Beleites Date: Mon, 31 May 2021 21:43:21 +0200 Subject: [PATCH 04/27] fix deprecation --- hyperSpec/DESCRIPTION | 2 +- hyperSpec/R/DEPRECATED-wl_eval.R | 123 +++++-------------------------- 2 files changed, 19 insertions(+), 106 deletions(-) diff --git a/hyperSpec/DESCRIPTION b/hyperSpec/DESCRIPTION index 1b2e5ff9..d1c5e800 100644 --- a/hyperSpec/DESCRIPTION +++ b/hyperSpec/DESCRIPTION @@ -113,6 +113,7 @@ Collate: 'DEPRECATED-spc_spline.R' 'DEPRECATED-wc.R' 'DEPRECATED-wl_convert_units.R' + 'wl_eval.R' 'DEPRECATED-wl_eval.R' 'DEPRECATED-wl_sort.R' 'DEPRECATED-write_txt_long.R' @@ -208,7 +209,6 @@ Collate: 'vandermonde.R' 'wl.R' 'wl_convert_units.R' - 'wl_eval.R' 'wl_sort.R' 'write_txt_long.R' 'write_txt_wide.R' diff --git a/hyperSpec/R/DEPRECATED-wl_eval.R b/hyperSpec/R/DEPRECATED-wl_eval.R index 86db7b7d..471368c2 100644 --- a/hyperSpec/R/DEPRECATED-wl_eval.R +++ b/hyperSpec/R/DEPRECATED-wl_eval.R @@ -23,6 +23,7 @@ #' @return `hyperSpec` object containing one spectrum for each expression. #' #' @export +#' @include wl_eval.R #' #' @seealso #' @@ -32,49 +33,34 @@ #' #' @author C. Beleites, V. Gegzna #' -#' @examples -#' plot(wl.eval(laser, exp = function(x) exp(-x))) -#' -#' plot(wl.eval(1000:4000, y = function(x) 1/log(x))) -#' -#' plot(wl.eval(300:550, y2 = function(x) x*2, y3 = function(x) x*3)) -#' + wl.eval <- function(x, ..., normalize.wl = I) { # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ hySpc_deprecated("wl_eval") # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - UseMethod("wl.eval") + UseMethod("wl_eval") } #' @rdname DEPRECATED-wl.eval #' @export wl.eval.hyperSpec <- function(x, ..., normalize.wl = I) { - chk.hy(x) - validObject(x) - - fun <- list(...) - - wl <- normalize.wl(x@wavelength) + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + hySpc_deprecated("wl_eval.hyperSpec") + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - x <- decomposition(x, t(sapply(fun, function(f) f(wl))), scores = FALSE) - x$.f <- if (is.null(names(fun))) { - rep(NA, length(fun)) - } else { - names(fun) - } - x + wl_eval.hyperSpec (x, ..., normalize.wl = I) } #' @rdname DEPRECATED-wl.eval #' @export wl.eval.numeric <- function(x, ..., normalize.wl = I) { - if (!is.vector(x)) { - class_txt <- paste(class(x), collapse = ", ") - stop("`x` must be a vector. Now it is ", class_txt, ".") - } - x <- new("hyperSpec", spc = seq_along(x), wavelength = x) - wl.eval(x, ..., normalize.wl = normalize.wl) + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + hySpc_deprecated("wl_eval.numeric") + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + wl_eval.numeric (x, ..., normalize.wl = I) + } @@ -84,84 +70,11 @@ wl.eval.numeric <- function(x, ..., normalize.wl = I) { hySpc.testthat::test(wl.eval.hyperSpec) <- function() { context("wl.eval") - test_that("error on function not returning same length as input", { - expect_error(wl.eval(flu, function(x) 1)) - }) - - test_that("wl.eval() against manual evaluation", { - expect_equivalent( - wl.eval(flu, function(x) rep(5, length(x)), normalize.wl = normalize01)[[]], - matrix(rep(5, nwl(flu)), nrow = 1) - ) - - expect_equivalent( - wl.eval(flu, function(x) x), - vanderMonde(flu, 1)[2] - ) - - expect_equivalent( - wl.eval(flu, function(x) exp(-x))[[]], - matrix(exp(-flu@wavelength), nrow = 1) - ) + test_that("deprecated", { + expect_warning(wl.eval.hyperSpec (flu, function(x) x), + "Function 'wl.eval.hyperSpec' is deprecated.") + expect_warning(wl.eval.numeric (1:5, function(x) x), + "Function 'wl.eval.numeric' is deprecated.") }) - test_that("normalization", { - expect_equivalent( - wl.eval(flu, function(x) rep(5, length(x)), normalize.wl = normalize01)[[]], - matrix(rep(5, nwl(flu)), nrow = 1) - ) - - expect_equivalent( - wl.eval(flu, function(x) x, normalize.wl = normalize01)[[]], - matrix(seq(0, 1, length.out = nwl(flu)), nrow = 1) - ) - - expect_equivalent( - wl.eval(flu, function(x) exp(x), normalize.wl = normalize01)[[]], - matrix(exp(seq(0, 1, length.out = nwl(flu))), nrow = 1) - ) - }) - - - test_that("multiple functions", { - expect_equivalent( - wl.eval(flu, function(x) rep(1, length(x)), function(x) x), - vanderMonde(flu, 1) - ) - }) - - test_that("function names", { - tmp <- wl.eval(flu, f = function(x) x, g = function(x) exp(-x)) - - expect_equal(tmp$.f, c("f", "g")) - }) - - test_that("wl.eval() works", { - - expect_equal( - as.vector(wl.eval(1:10, f = function(x) x)$spc), - 1:10 - ) - - expect_equal( - as.vector(wl.eval(1:10, f = function(x) x**2)$spc), - (1:10)**2 - ) - - expect_equal( - wl.eval(wl(flu), f = function(x) x)$.f, - wl.eval( flu, f = function(x) x)$.f - ) - - expect_warning( - tmp <- wl.eval(300:500, f = function(x) x, g = function(x) exp(-x)), - "deprecated" - ) - expect_equal(tmp$.f, c("f", "g")) - }) - - test_that("wl.eval fails with matrix input", { - expect_error(wl.eval(matrix(1:10), f = function(x) x)) - expect_error(wl.eval(matrix(), f = function(x) x)) - }) } From e15f9668a86071b09b9ca6ce71c07c85942d6d79 Mon Sep 17 00:00:00 2001 From: Claudia Beleites Date: Mon, 31 May 2021 21:51:27 +0200 Subject: [PATCH 05/27] fix deprecation --- hyperSpec/DESCRIPTION | 2 +- hyperSpec/R/DEPRECATED-extract_numbers.R | 27 +++++------------------- 2 files changed, 6 insertions(+), 23 deletions(-) diff --git a/hyperSpec/DESCRIPTION b/hyperSpec/DESCRIPTION index d1c5e800..e64a1581 100644 --- a/hyperSpec/DESCRIPTION +++ b/hyperSpec/DESCRIPTION @@ -90,6 +90,7 @@ Collate: 'DEPRECATED-count_lines.R' 'hy_options.R' 'constants-regexps.R' + 'extract_numbers.R' 'DEPRECATED-extract_numbers.R' 'DEPRECATED-ggplot2.R' 'fileio.optional.R' @@ -124,7 +125,6 @@ Collate: 'all.equal.R' 'apply.R' 'as.data.frame.R' - 'extract_numbers.R' 'as_hyperSpec.R' 'barbiturates.R' 'bind.R' diff --git a/hyperSpec/R/DEPRECATED-extract_numbers.R b/hyperSpec/R/DEPRECATED-extract_numbers.R index 20f5bfc3..87c87838 100644 --- a/hyperSpec/R/DEPRECATED-extract_numbers.R +++ b/hyperSpec/R/DEPRECATED-extract_numbers.R @@ -35,22 +35,14 @@ #' tmp <- data.frame(flu[[, , 400 ~ 410]]) #' (wl <- colnames(tmp)) #' guess.wavelength(wl) +#' @include extract_numbers.R guess.wavelength <- function(X) { # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ hySpc_deprecated("extract_numbers") # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - wl <- regmatches(X, regexpr(.PATTERN.number, X)) - wl <- as.numeric(wl) + extract_numbers(X) - if (is.null(wl) || length(wl) == 0L || any(is.na(wl))) { - if (hy.getOption("debuglevel") >= 1L) { - message("could not guess wavelengths") - } - wl <- NULL - } - - wl } #' @include constants-regexps.R @@ -58,17 +50,8 @@ guess.wavelength <- function(X) { hySpc.testthat::test(guess.wavelength) <- function() { context("guess.wavelength") - test_that("simple test", { - expect_equal(guess.wavelength(1:5), 1:5) - }) - - test_that("wavelengths containing characters", { - wl <- seq(600, 602, length.out = 11) - expect_equal(guess.wavelength(make.names(wl)), wl) - }) - - test_that("return NULL if could not guess wavelenths", { - expect_equal(guess.wavelength(colnames(matrix(1:12, 3))), NULL) - expect_equal(guess.wavelength(letters[1:4]), NULL) + test_that("deprecated", { + expect_warning (guess.wavelength(1:5), + "Function 'guess.wavelength' is deprecated.") }) } From 0847d8dd60f9469403b470400a1693af3fbc4211 Mon Sep 17 00:00:00 2001 From: Claudia Beleites Date: Mon, 31 May 2021 21:51:36 +0200 Subject: [PATCH 06/27] fix deprecation --- hyperSpec/R/DEPRECATED-spc_fix_colnames.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/hyperSpec/R/DEPRECATED-spc_fix_colnames.R b/hyperSpec/R/DEPRECATED-spc_fix_colnames.R index f8f226e1..331e22af 100644 --- a/hyperSpec/R/DEPRECATED-spc_fix_colnames.R +++ b/hyperSpec/R/DEPRECATED-spc_fix_colnames.R @@ -32,11 +32,16 @@ hySpc.testthat::test(.fix_spc_colnames) <- function() { context(".fix_spc_colnames") + test_that ("deprecated", + expect_warning (.fix_spc_colnames(flu), + "Function '.fix_spc_colnames' is deprecated.") + ) + test_that("colnames get fixed", { tmp <- flu colnames(tmp@data$spc) <- NULL - tmp <- .fix_spc_colnames(tmp) + tmp <- suppressWarnings(.fix_spc_colnames(tmp)) expect_equal(colnames(tmp@data$spc), as.character(wl(tmp))) }) } From ca2dee14c37e66ec983976ef94578ddcd4297dff Mon Sep 17 00:00:00 2001 From: Claudia Beleites Date: Mon, 31 May 2021 21:59:58 +0200 Subject: [PATCH 07/27] deprecation: fix parameters for calling new version --- hyperSpec/R/DEPRECATED-wl_eval.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/hyperSpec/R/DEPRECATED-wl_eval.R b/hyperSpec/R/DEPRECATED-wl_eval.R index 471368c2..14884766 100644 --- a/hyperSpec/R/DEPRECATED-wl_eval.R +++ b/hyperSpec/R/DEPRECATED-wl_eval.R @@ -48,7 +48,7 @@ wl.eval.hyperSpec <- function(x, ..., normalize.wl = I) { hySpc_deprecated("wl_eval.hyperSpec") # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - wl_eval.hyperSpec (x, ..., normalize.wl = I) + wl_eval.hyperSpec (x, ..., normalize.wl = normalize.wl) } @@ -59,7 +59,7 @@ wl.eval.numeric <- function(x, ..., normalize.wl = I) { hySpc_deprecated("wl_eval.numeric") # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - wl_eval.numeric (x, ..., normalize.wl = I) + wl_eval.numeric (x, ..., normalize.wl = normalize.wl) } From 8d6840aef22626551ef591ac384f60c5e19e7a4a Mon Sep 17 00:00:00 2001 From: Claudia Beleites Date: Mon, 31 May 2021 22:05:40 +0200 Subject: [PATCH 08/27] fix deprecation --- hyperSpec/DESCRIPTION | 2 +- hyperSpec/R/DEPRECATED-spc_fit_poly.R | 354 +------------------------- 2 files changed, 14 insertions(+), 342 deletions(-) diff --git a/hyperSpec/DESCRIPTION b/hyperSpec/DESCRIPTION index e64a1581..067a637c 100644 --- a/hyperSpec/DESCRIPTION +++ b/hyperSpec/DESCRIPTION @@ -106,6 +106,7 @@ Collate: 'DEPRECATED-scan.R' 'DEPRECATED-spc-various.R' 'DEPRECATED-spc_bin.R' + 'spc_fit_poly.R' 'DEPRECATED-spc_fit_poly.R' 'DEPRECATED-spc_fix_colnames.R' 'DEPRECATED-spc_loess.R' @@ -195,7 +196,6 @@ Collate: 'seq.R' 'show.R' 'spc_bin.R' - 'spc_fit_poly.R' 'spc_fix_colnames.R' 'spc_identify.R' 'spc_loess.R' diff --git a/hyperSpec/R/DEPRECATED-spc_fit_poly.R b/hyperSpec/R/DEPRECATED-spc_fit_poly.R index 1ed66f63..ab960b01 100644 --- a/hyperSpec/R/DEPRECATED-spc_fit_poly.R +++ b/hyperSpec/R/DEPRECATED-spc_fit_poly.R @@ -25,123 +25,35 @@ #' `poly.order` to the *complete* spectra given in `fit.to`. #' Thus `fit.to` needs to be cut appropriately. #' -#' @param fit.to `hyperSpec` object on which the baselines are fitted -#' @param apply.to `hyperSpec` object on which the baselines are evaluted -#' If `NULL`, a `hyperSpec` object containing the polynomial -#' coefficients rather than evaluted baselines is returned. -#' @param poly.order order of the polynomial to be used -#' @param offset.wl should the wavelength range be mapped to -> \[0, delta wl\]? -#' This enhances numerical stability. +#' @param ... handed to [hyperSpec::spc_fit_poly_below()] #' @return `hyperSpec` object containing the baselines in the spectra #' matrix, either as polynomial coefficients or as polynomials evaluted on #' the spectral range of `apply.to` #' @author C. Beleites +#' @include spc_fit_poly.R #' #' @seealso `vignette("baseline", package = "hyperSpec")` #' #' @export #' #' @keywords manip datagen -#' -#' @examples -#' -#' \dontrun{ -#' vignette("baseline", package = "hyperSpec") -#' } -#' -#' spc <- faux_cell[1:10] -#' baselines <- spc.fit.poly(spc[, , c(625 ~ 640, 1785 ~ 1800)], spc) -#' plot(spc - baselines) -spc.fit.poly <- function(fit.to, apply.to = NULL, poly.order = 1, - offset.wl = !(is.null(apply.to))) { +spc.fit.poly <- function(...) { # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ hySpc_deprecated("spc_fit_poly") # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - chk.hy(fit.to) - if (!is.null(apply.to)) { - chk.hy(apply.to) - } - - validObject(fit.to) - validObject(apply.to) - - x <- fit.to@wavelength - - if (offset.wl) { - minx <- min(x) - x <- x - min(x) - } else { - minx <- 0 - } - - x <- vanderMonde(x, poly.order) # Vandermonde matrix of x - - p <- apply( - fit.to, 1, - function(y, x) { - x <- x[!is.na(y), , drop = FALSE] - y <- y[!is.na(y)] - qr.solve(x, y) - }, - x - ) - - if (is.null(apply.to)) { - colnames(p@data$spc) <- paste0("(x - minx)^", 0:poly.order) - - p$min.x <- minx - return(p) - } else { - wl <- apply.to@wavelength - minx - - x <- vanderMonde(wl, poly.order) # Vandermonde matrix of x - apply.to@data$spc <- I(t(apply(p[[]], 1, function(p, x) { - x %*% p - }, x))) - - validObject(apply.to) - - apply.to - } + spc_fit_poly(...) } hySpc.testthat::test(spc.fit.poly) <- function() { context("spc.fit.poly") test_that( - "no normalization", - { - bl.nonorm <- spc.fit.poly(flu, flu, poly.order = 3, offset.wl = FALSE) - } + "deprecated", + expect_warning (spc.fit.poly(flu), + "Function 'spc.fit.poly' is deprecated.") ) - # test effect of wavelength axis normalization - # was issue 1 on github - tmp <- flu - wl(tmp) <- wl(tmp) + 1e4 - - test_that("normalization/offset wavelengths", { - expect_error(spc.fit.poly(tmp, poly.order = 3, offset.wl = FALSE)) - - bl.1e4 <- spc.fit.poly(tmp, tmp, poly.order = 3, offset.wl = TRUE) - bl.nonorm <- spc.fit.poly(flu, flu, poly.order = 3, offset.wl = FALSE) - expect_equal(bl.nonorm[[]], bl.1e4[[]]) - }) - - test_that("spectrum containing NA", { - tmp <- faux_cell[1] - tmp[[, , 1600]] <- NA - - coefs <- spc.fit.poly(tmp, apply.to = NULL)[[]] - expect_equal( - coefs, - spc.fit.poly(faux_cell[1, , !is.na(tmp)], apply.to = NULL)[[]] - ) - - ## bug was: all coefficients were silently 0 - expect_true(all(abs(coefs) > sqrt(.Machine$double.eps))) - }) } #' @rdname DEPRECATED-baselines @@ -151,265 +63,25 @@ hySpc.testthat::test(spc.fit.poly) <- function() { #' ranges of the spectra in `fit.to`. For details, see the #' `vignette("baseline")`. #' -#' @param npts.min minimal number of points used for fitting the polynomial -#' @param noise noise level to be considered during the fit. It may be given as -#' one value for all the spectra, or for each spectrum separately. -#' @param max.iter stop at the latest after so many iterations. -#' @param stop.on.increase additional stopping rule: stop if the number of -#' support points would increase, regardless whether npts.min was reached or -#' not. -#' @param debuglevel additional output: `1` shows `npts.min`, -#' `2` plots support points for the final baseline of 1st spectrum, -#' `3` plots support points for 1st spectrum, `4` plots support -#' points for all spectra. -#' @seealso see [hyperSpec::options()] for more on `debuglevel` +#' @param ... handed to [hyperSpec::spc_fit_poly_below()] #' #' @export -#' @examples -#' -#' baselines <- spc.fit.poly.below(spc) -#' plot(spc - baselines) -#' -#' spc.fit.poly.below(faux_cell[1:3], debuglevel = 1) -#' spc.fit.poly.below(faux_cell[1:3], debuglevel = 2) -#' spc.fit.poly.below(faux_cell[1:3], -#' debuglevel = 3, -#' noise = sqrt(rowMeans(faux_cell[[1:3]])) -#' ) -spc.fit.poly.below <- function(fit.to, apply.to = fit.to, poly.order = 1, - npts.min = max( - round(nwl(fit.to) * 0.05), - 3 * (poly.order + 1) - ), - noise = 0, offset.wl = FALSE, - max.iter = nwl(fit.to), - stop.on.increase = FALSE, - debuglevel = hy.getOption("debuglevel")) { +spc.fit.poly.below <- function(...) { # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ hySpc_deprecated("spc_fit_poly_below") # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ## for debuglevel >= 2L - cols <- matlab.dark.palette(max.iter) - - chk.hy(fit.to) - if (!is.null(apply.to)) { - chk.hy(apply.to) - } - - validObject(fit.to) - validObject(apply.to) - - if (missing(npts.min) && debuglevel >= 1L) { - message("Fitting with npts.min = ", npts.min, "\n") - } - - if (npts.min <= poly.order) { - npts.min <- poly.order + 1 - warning(paste("npts.min too small: adjusted to", npts.min)) - } - - if (length(noise) == 1) { - noise <- rep(noise, nrow(fit.to)) - } - - x <- fit.to@wavelength - - if (offset.wl) { - minx <- min(x) - x <- x - min(x) - } else { - minx <- 0 - } - - vdm <- vanderMonde(x, poly.order) - y <- t(fit.to[[]]) - - p <- matrix(nrow = nrow(fit.to), ncol = poly.order + 1) - for (i in row.seq(fit.to)) { - use.old <- logical(nwl(fit.to)) - use <- !is.na(y[, i]) + spc_fit_poly_below (...) - if (debuglevel %in% c(2L, 3L) && i == 1L || debuglevel >= 4L) { - plot(fit.to[i], title.args = list(main = paste("spectrum", i))) - message("start: ", sum(use, na.rm = TRUE), " support points") - } - - for (iter in 1:max.iter) { - p[i, ] <- qr.solve(vdm[use, ], y[use, i]) - bl <- vdm %*% p[i, ] - use.old <- use - use <- y[, i] < bl + noise[i] & !is.na(y[, i]) - - if ((debuglevel == 3L && i == 1L || debuglevel >= 4L) && sum(use) > 0L) { - plot(fit.to[i, , use], - add = TRUE, - lines.args = list(pch = 20, type = "p"), col = cols[iter] - ) - - lines(fit.to@wavelength, bl, col = cols[iter]) - lines(fit.to@wavelength, bl + noise, col = cols[iter], lty = 2) - - message( - "Iteration ", iter, ": ", sum(use, na.rm = TRUE), - " support points" - ) - } - - if ((sum(use, na.rm = TRUE) < npts.min) || - all(use == use.old, na.rm = TRUE)) { - break - } - - if (sum(use, na.rm = TRUE) > sum(use.old, na.rm = TRUE) && - stop.on.increase) { - warning( - "Iteration ", iter, ": ", - "Number of support points is about to increase again. ", - "Stopping with ", sum(use.old, na.rm = TRUE), - " support points, but this may be a local minimum." - ) - - break - } - } - - if (iter == max.iter) { - if ((sum(use.old, na.rm = TRUE) == npts.min) && - !all(use == use.old, na.rm = TRUE) && - !sum(use, na.rm = TRUE) < npts.min) { - warning( - "Reached npts.min, but the solution is not stable. ", - "Stopped after ", iter, " iterations." - ) - } else if (sum(use, na.rm = TRUE) >= npts.min) { - warning( - "Stopped after ", iter, " iterations with ", - sum(use.old, na.rm = TRUE), " support points." - ) - } - } - - if (debuglevel >= 1L) { - message(sprintf( - "spectrum % 6i: % 5i support points, noise = %0.1f, %3i iterations", - i, sum(use.old, na.rm = TRUE), noise[i], iter - )) - } - - if ((debuglevel == 2L) && (i == 1L)) { - plot(fit.to[i, , use.old], - add = TRUE, - lines.args = list(pch = 20, type = "p"), col = cols[iter] - ) - - lines(fit.to@wavelength, bl, col = cols[iter]) - - lines(fit.to@wavelength, bl + noise, col = cols[iter], lty = 2) - } - } - - if (is.null(apply.to)) { - fit.to <- new("hyperSpec", spc = p, wavelength = 0:poly.order) - colnames(fit.to@data$spc) <- paste0("(x - minx)^", 0:poly.order) - - validObject(fit.to) - - fit.to$min.x <- minx - return(fit.to) - } else { - x <- apply.to@wavelength - minx - - vdm <- vanderMonde(x, poly.order) # Vandermonde matrix of x - - apply.to@data$spc <- I(t(apply(p, 1, function(p, x) { - x %*% p - }, vdm))) - - validObject(apply.to) - - apply.to - } } hySpc.testthat::test(spc.fit.poly.below) <- function() { context("spc.fit.poly.below") test_that( - "no normalization", - { - bl.nonorm <- spc.fit.poly.below(flu, flu, - poly.order = 3, offset.wl = FALSE, - npts.min = 25 - ) - } + "deprecated", + expect_warning (spc.fit.poly.below(flu), + "Function 'spc.fit.poly.below' is deprecated.") ) - # test effect of wavelength axis normalization - # was issue 1 on github - tmp <- flu - wl(tmp) <- wl(tmp) + 1e4 - - test_that("normalization/offset wavelengths", { - expect_error(spc.fit.poly.below(tmp, - poly.order = 3, offset.wl = FALSE, - npts.min = 25 - )) - - bl.1e4 <- spc.fit.poly.below(tmp, tmp, - poly.order = 3, offset.wl = TRUE, - npts.min = 25 - ) - - bl.nonorm <- spc.fit.poly.below(flu, flu, - poly.order = 3, offset.wl = FALSE, - npts.min = 25 - ) - - expect_equal(bl.nonorm[[]], bl.1e4[[]]) - }) - - test_that("stopping rules for unstable solutions - issue #58", { - # test object origninally created from chondro: - # tmp <- chondro[103,,c(600 ~ 700, 1650 ~ 1800)] - # tmp[[]] <- round(tmp[[]], digits = 1) - - tmp <- t(c( - 331.8, 336.7, 325.3, 313.2, 328.6, 348.5, 304.6, 286.8, 283.9, - 294.2, 323.3, 312.2, 298.8, 299.8, 299.7, 301.8, 305.2, 308.4, - 311.2, 318.2, 321, 322.1, 323, 336.7, 362.1, 776.9, 835.3, 902, - 967, 1019.3, 1020.5, 942.3, 848.8, 774.8, 701.1, 612.1, 514.4, - 420.8, 340.1, 282.5, 242.7, 220, 206, 196.8, 192.1, 189.1, 185.3, - 184, 181.8, 178.7, 178.8, 174.8, 175.6, 173.2, 174.3, 173.1, - 173.2, 171.4, 171.5, 171.9, 171.3, 171.1, 171.8 - )) - tmp <- as.hyperSpec(tmp) - wl(tmp) <- c(seq(602, 698, by = 4), seq(1650, 1798, by = 4)) - - expect_warning( - spc.fit.poly.below(tmp, npts.min = 2), - "Reached npts.min, but the solution is not stable." - ) - expect_warning( - spc.fit.poly.below(tmp, - npts.min = 2, - stop.on.increase = TRUE - ), - "Number of support points is about to increase again." - ) - }) - - test_that("spectrum containing NA", { - tmp <- faux_cell[1] - tmp[[, , 1600]] <- NA - - coefs <- spc.fit.poly.below(tmp, apply.to = NULL)[[]] - expect_equal( - coefs, - spc.fit.poly.below(faux_cell[1, , !is.na(tmp)], apply.to = NULL)[[]] - ) - - ## bug was: all coefficients were silently 0 - expect_true(all(abs(coefs) > sqrt(.Machine$double.eps))) - }) } From 14b28f1081e5eb2cb111be7ecbe96246cdac6782 Mon Sep 17 00:00:00 2001 From: Claudia Beleites Date: Tue, 1 Jun 2021 20:48:31 +0200 Subject: [PATCH 09/27] fix deprecation --- hyperSpec/R/DEPRECATED-spc_rubberband.R | 130 ++---------------------- 1 file changed, 10 insertions(+), 120 deletions(-) diff --git a/hyperSpec/R/DEPRECATED-spc_rubberband.R b/hyperSpec/R/DEPRECATED-spc_rubberband.R index 1ee06675..7302d4d4 100644 --- a/hyperSpec/R/DEPRECATED-spc_rubberband.R +++ b/hyperSpec/R/DEPRECATED-spc_rubberband.R @@ -16,8 +16,7 @@ #' #' Use `debuglevel >= 1` to obtain debug plots, either directly via function #' argument or by setting hyperSpec's `debuglevel` option. -#' @param spc `hyperSpec` object -#' @param ... further parameters handed to [stats::smooth.spline()] +#' @param ... handed to [hyperSpec::spc_rubberband()] #' @param upper logical indicating whether the lower or upper part of the hull should be used #' @param noise noise level to be taken into account #' @param spline logical indicating whether the baseline should be an interpolating spline through @@ -25,142 +24,33 @@ #' @return `hyperSpec` object containing the baselines #' #' @author Claudia Beleites -#' @seealso [hyperSpec::spc.fit.poly()], [hyperSpec::spc.fit.poly.below()] +#' @seealso [hyperSpec::spc_rubberband()] #' #' `vignette ("baseline")` #' #' [hyperSpec::hy.setOptions()] #' -#' @note This function is still experimental #' @export +#' @include spc_rubberband.R #' #' -#' @examples -#' plot(paracetamol[, , 175 ~ 1800]) -#' bl <- spc.rubberband(paracetamol[, , 175 ~ 1800], noise = 300, df = 20) -#' plot(bl, add = TRUE, col = 2) -#' -#' plot(paracetamol[, , 175 ~ 1800] - bl) -spc.rubberband <- function(spc, ..., upper = FALSE, noise = 0, spline = TRUE) { +spc.rubberband <- function(...) { # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ hySpc_deprecated("spc_rubberband") - # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - spc <- orderwl(spc) - - if (upper) spc@data$spc <- -spc@data$spc - spc@data$spc <- .rubberband(spc@wavelength, spc@data$spc, - noise = noise, spline = spline, ... - ) - - if (upper) spc@data$spc <- -spc@data$spc - - spc + spc_rubberband(...) + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ } -#' @importFrom grDevices chull -.rubberband <- function(x, y, noise, spline, ..., debuglevel = hy.getOption("debuglevel")) { - for (s in seq_len(nrow(y))) { - use <- which(!is.na(y[s, ])) - - pts <- chull(x[use], y[s, use]) - pts <- use[pts] - - if (debuglevel >= 1L) { - plot(x, y[s, ], type = "l") - points(x[pts], y[s, pts], pch = 1, col = matlab.dark.palette(length(pts))) - } - - ## `chull` returns points in cw order - ## => points between ncol (y) and 1 are lower part of hull - imax <- which.max(pts) - 1 - - ## if necessary, rotate pts so that ncol (y) is at position 1 - if (imax > 0L) { - pts <- c(pts[-seq_len(imax)], pts[seq_len(imax)]) - } - - ## now keep only pts until column index 1 - pts <- pts[1:which.min(pts)] - - ## check whether first and last point are minima, - ## if not remove them. - ## If they are minima, 2nd and 2nd last point do not appear in pts - ## last point: - if (pts[2] == pts[1] - 1) pts <- pts[-1] - - ## now sort ascending (anyways needed later on) - pts <- rev(pts) - - ## fist point: - if (pts[2] == pts[1] + 1) pts <- pts[-1] - - if (debuglevel >= 1L) { - points(x[pts], y[s, pts], pch = 19, col = matlab.dark.palette(length(pts)), cex = 0.7) - } - - tmp <- approx(x = x[pts], y = y[s, pts], xout = x, method = "linear")$y - - if (spline) { - pts <- which(y[s, ] <= tmp + noise) - - if (length(pts) > 3) { - tmp <- predict(smooth.spline(x[pts], y[s, pts], ...)$fit, x, 0)$y - } else { - tmp <- spline(x[pts], y[s, pts], xout = x)$y - } - } - - y[s, ] <- tmp - } - - y -} # Unit tests ----------------------------------------------------------------- hySpc.testthat::test(spc.rubberband) <- function() { context("spc.rubberband") - ## use data that yields fairly stable baseline solution - paracetamol <- paracetamol[, , 300 ~ 550] - + test_that("deprecated", + expect_warning(spc.rubberband(paracetamol), + "Function 'spc.rubberband' is deprecated.") + ) - test_that("spectrum containing NA inside", { - tmp <- paracetamol - tmp[[, , 400]] <- NA - - coefs <- spc.rubberband(tmp) - expect_equal( - coefs[[, , !is.na(tmp)]], - spc.rubberband(paracetamol[, , !is.na(tmp)])[[]] - ) - - ## bug was: all coefficients were silently 0 - expect_true(all(abs(coefs[[]]) > sqrt(.Machine$double.eps))) - }) - - test_that("spectrum containing NA at first wavelength (issue #95)", { - tmp <- paracetamol - tmp[[, , 1, wl.index = TRUE]] <- NA - - coefs <- spc.rubberband(tmp) - expect_equal( - coefs[[, , !is.na(tmp)]], - spc.rubberband(paracetamol[, , !is.na(tmp)])[[]] - ) - }) - - test_that("spectrum containing NA at end", { - tmp <- paracetamol[1] - tmp[[, , nwl(paracetamol), wl.index = TRUE]] <- NA - - coefs <- spc.rubberband(tmp) - expect_equal( - coefs[[, , !is.na(tmp)]], - spc.rubberband(paracetamol[1, , !is.na(tmp)])[[]] - ) - }) } - From d95ac466e776b8dfd89b44eead04efa55413e69c Mon Sep 17 00:00:00 2001 From: Claudia Beleites Date: Sat, 3 Jul 2021 21:45:02 +0200 Subject: [PATCH 10/27] deprecate read.jdx() --- hyperSpec/DESCRIPTION | 2 +- hyperSpec/R/read.jdx.R | 98 +++++++----------------------------------- 2 files changed, 16 insertions(+), 84 deletions(-) diff --git a/hyperSpec/DESCRIPTION b/hyperSpec/DESCRIPTION index 067a637c..1def79f1 100644 --- a/hyperSpec/DESCRIPTION +++ b/hyperSpec/DESCRIPTION @@ -111,6 +111,7 @@ Collate: 'DEPRECATED-spc_fix_colnames.R' 'DEPRECATED-spc_loess.R' 'DEPRECATED-spc_na_approx.R' + 'spc_rubberband.R' 'DEPRECATED-spc_rubberband.R' 'DEPRECATED-spc_spline.R' 'DEPRECATED-wc.R' @@ -200,7 +201,6 @@ Collate: 'spc_identify.R' 'spc_loess.R' 'spc_na_approx.R' - 'spc_rubberband.R' 'spc_spline.R' 'split.R' 'subset.R' diff --git a/hyperSpec/R/read.jdx.R b/hyperSpec/R/read.jdx.R index fc9a7366..1778467b 100644 --- a/hyperSpec/R/read.jdx.R +++ b/hyperSpec/R/read.jdx.R @@ -1,6 +1,9 @@ -#' @title JCAMP-DX Import for Shimadzu Library Spectra. +#' @title DEPRECATED JCAMP-DX Import for Shimadzu Library Spectra. #' #' @description +#' This function is DEPRECATED and will be removed in the next release. +#' Please use [hySpc.read.jdx::read_jdx()] instead. +#' #' This is a first rough import function for JCAMP-DX spectra. #' #' So far, AFFN and PAC formats are supported for simple XYDATA, DATA TABLEs and PEAK TABLEs. @@ -33,15 +36,22 @@ #' #' @export #' -#' @concept io +#' @concept deprecated #' #' @importFrom utils head modifyList maintainer -read.jdx <- function(filename = stop("filename is needed"), encoding = "", +read.jdx <- function(filename = NULL, encoding = "", header = list(), keys.hdr2data = FALSE, ..., NA.symbols = c("NA", "N/A", "N.A."), collapse.multi = TRUE, wl.tolerance = hy.getOption("wl.tolerance"), collapse.equal = TRUE) { + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + hySpc_deprecated(new="read_jdx()", package = "hySpc.read.jdx") + + if(is.null(filename)) return(NA) + + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + ## see readLines help: this way, encoding is translated to standard encoding on current system. file <- file(filename, "r", encoding = encoding, blocking = FALSE) jdx <- readLines(file) @@ -339,85 +349,7 @@ read.jdx <- function(filename = stop("filename is needed"), encoding = "", hySpc.testthat::test(read.jdx) <- function() { context("test-read.jdx") - files <- c( - Sys.glob("fileio/jcamp-dx/*.DX"), Sys.glob("fileio/jcamp-dx/*.dx"), - Sys.glob("fileio/jcamp-dx/*.jdx"), Sys.glob("fileio/jcamp-dx/*.JCM"), - Sys.glob("fileio/jcamp-dx/PE-IR/*.DX"), - "fileio/jcamp-dx/GMD_20111121_MDN35_ALK_JCAMP-shortened.txt" # MPI Golm, long version one is *slow* to read and exceeds memory limit - ) - - ## these files need special parameters: - files <- setdiff(files, c("fileio/jcamp-dx/shimadzu.jdx", "fileio/jcamp-dx/virgilio.jdx")) + test_that("deprecated", + expect_warning(read.jdx(), "deprecated.*hySpc.read.jdx")) - test_that("JCAMP-DX examples that need particular parameter sets", { - skip_if_not_fileio_available() - - expect_known_hash( - read.jdx("fileio/jcamp-dx/shimadzu.jdx", encoding = "latin1", keys.hdr2data = TRUE), - "55c392d767f7a7f268e55540d4496fb1" - ) - expect_known_hash( - read.jdx("fileio/jcamp-dx/virgilio.jdx", ytol = 1e-9), - "da4a725d23efe4a1888496f1739294c2" - ) - }) - - unsupported <- c( - "fileio/jcamp-dx/BRUKER2.JCM", - "fileio/jcamp-dx/BRUKER1.JCM", - "fileio/jcamp-dx/TESTSPEC.DX", - "fileio/jcamp-dx/TEST32.DX", - "fileio/jcamp-dx/SPECFILE.DX", - "fileio/jcamp-dx/ISAS_MS2.DX", - "fileio/jcamp-dx/ISAS_MS3.DX", # NTUPLES - "fileio/jcamp-dx/BRUKSQZ.DX", - "fileio/jcamp-dx/BRUKDIF.DX", - "fileio/jcamp-dx/BRUKNTUP.DX", # NTUPLES - "fileio/jcamp-dx/ISAS_CDX.DX", # PEAK ASSIGNMENTS= (XYMA) - "fileio/jcamp-dx/TESTFID.DX", # NTUPLES - "fileio/jcamp-dx/TESTNTUP.DX" # NTUPLES - ) - - checksums <- c( - `fileio/jcamp-dx/AMA1.DX` = "5e8523b7022ec26cfb2541fdf929e997", - `fileio/jcamp-dx/AMA2.DX` = "b336f71c592bc81de04d27bbbb9ede52", - `fileio/jcamp-dx/AMA3.DX` = "34344a42a232227c14ab5de5dc04e096", - `fileio/jcamp-dx/br_154_1.DX` = "232ef45bf818221c05927e311ac407a3", - `fileio/jcamp-dx/BRUKAFFN.DX` = "2498cac17635ad21e4998a3e3e7eebfa", - `fileio/jcamp-dx/BRUKPAC.DX` = "401cbaa375b79323ed0dcc30a135d11d", - `fileio/jcamp-dx/IR_S_1.DX` = "8d7032508efaf79fcc955f888d60cd8f", - `fileio/jcamp-dx/ISAS_MS1.DX` = "43017647aa339d8e7aaf3fadbdbbf065", - `fileio/jcamp-dx/LABCALC.DX` = "55ffdb250279aee967b2f65bbbf7dd5e", - `fileio/jcamp-dx/PE1800.DX` = "31ac39a5db243c3aa01e1978b9ab1aa3", - `fileio/jcamp-dx/testjose.dx` = "3b229eb9b8f229acd57783328d36a697", - `fileio/jcamp-dx/sign-rustam.jdx` = "386bf0b94baa5007e11e6af294895012", - `fileio/jcamp-dx/PE-IR/br_1.DX` = "ab5fa92227625c287871d9e95091c364", - `fileio/jcamp-dx/PE-IR/br_2.DX` = "eff5a1b37121a8902c0e62ebb5de0013", - `fileio/jcamp-dx/PE-IR/br_3.DX` = "2762712b1317631d32969624c97fa940", - `fileio/jcamp-dx/PE-IR/br_4.DX` = "11ddb20e9f6676f709827ececda360ab", - `fileio/jcamp-dx/PE-IR/br_5.DX` = "ffa08204bfb2521dd8caa9d286eba519", - `fileio/jcamp-dx/PE-IR/fort_1.DX` = "e808e243ae646c0526ba009f3ac3f80a", - `fileio/jcamp-dx/PE-IR/fort_2.DX` = "df90e70f203294c8bfeac7a6141a552d", - `fileio/jcamp-dx/PE-IR/fort_3.DX` = "d43a2c4fbb2598a5028a1406f83e3c3d", - `fileio/jcamp-dx/PE-IR/fort_4.DX` = "5382afba5c8b7fffdc26f00e129035c7", - `fileio/jcamp-dx/PE-IR/fort_5.DX` = "745c8b0fdad48a945e084d6e6cb9f0c6", - `fileio/jcamp-dx/PE-IR/lp_1.DX` = "bcb0a1e1150bcd038a3e0e0e5a896b2b", - `fileio/jcamp-dx/PE-IR/lp_2.DX` = "7bc1c53f1363b2b02374442a1e8baa74", - `fileio/jcamp-dx/PE-IR/lp_3.DX` = "eaa58c46360be604169e979c0fe2caeb", - `fileio/jcamp-dx/PE-IR/lp_4.DX` = "3b8d54eca48095d3f6c3eafc7b903a25", - `fileio/jcamp-dx/PE-IR/lp_5.DX` = "a0eaa3ca11fb5a0dde83fa01296d72db", - `fileio/jcamp-dx/GMD_20111121_MDN35_ALK_JCAMP-shortened.txt` = "fd2e686f5dc78691c22033805ed56463" - ) - - - test_that("JCAMP-DX example files", { - skip_if_not_fileio_available() - for (f in files [!files %in% unsupported]) { - spc <- read.jdx(f, ytol = 1e-6) - ## for wholesale updating of hashes (e.g. due to changes in initialize) - ## output filename hash pairs: - # cat (sprintf ("`%s` = '%s',\n", f, digest (spc))) - expect_known_hash(spc, checksums [f]) - } - }) } From ce106f29536a50168fab6e706b3fac057df5e53c Mon Sep 17 00:00:00 2001 From: Claudia Beleites Date: Sat, 3 Jul 2021 21:50:03 +0200 Subject: [PATCH 11/27] fix collate order for wl_eval() --- hyperSpec/DESCRIPTION | 2 +- hyperSpec/R/wl_eval.R | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/hyperSpec/DESCRIPTION b/hyperSpec/DESCRIPTION index 1def79f1..f6b135ea 100644 --- a/hyperSpec/DESCRIPTION +++ b/hyperSpec/DESCRIPTION @@ -116,6 +116,7 @@ Collate: 'DEPRECATED-spc_spline.R' 'DEPRECATED-wc.R' 'DEPRECATED-wl_convert_units.R' + 'normalize01.R' 'wl_eval.R' 'DEPRECATED-wl_eval.R' 'DEPRECATED-wl_sort.R' @@ -168,7 +169,6 @@ Collate: 'merge.R' 'mergeextra.R' 'mvtnorm.R' - 'normalize01.R' 'palette_colorblind.R' 'palette_matlab.R' 'pearson_dist.R' diff --git a/hyperSpec/R/wl_eval.R b/hyperSpec/R/wl_eval.R index ec8f8c28..4e84fa5a 100644 --- a/hyperSpec/R/wl_eval.R +++ b/hyperSpec/R/wl_eval.R @@ -28,6 +28,7 @@ #' #' plot(wl_eval(300:550, y2 = function(x) x*2, y3 = function(x) x*3)) #' +#' @include normalize01.R wl_eval <- function(x, ..., normalize.wl = I) { UseMethod("wl_eval") } From 0b7693592b4db27fc9ae4e2836afbe132921f902 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sat, 10 Jul 2021 21:07:05 +0300 Subject: [PATCH 12/27] Update style in read.jdj.R Update style in description and in code. --- hyperSpec/R/read.jdx.R | 108 ++++++++++++++++++++++++----------------- 1 file changed, 63 insertions(+), 45 deletions(-) diff --git a/hyperSpec/R/read.jdx.R b/hyperSpec/R/read.jdx.R index 1778467b..8382ec63 100644 --- a/hyperSpec/R/read.jdx.R +++ b/hyperSpec/R/read.jdx.R @@ -1,25 +1,40 @@ -#' @title DEPRECATED JCAMP-DX Import for Shimadzu Library Spectra. +#' @name DEPRECATED-read.jdx +#' @concept moved to hySpc.read.jdx +#' +#' @title (DEPRECATED) JCAMP-DX import for Shimadzu library spectra #' #' @description -#' This function is DEPRECATED and will be removed in the next release. -#' Please use [hySpc.read.jdx::read_jdx()] instead. +#' This function is **deprecated** and will be removed in the next release +#' of \pkg{hyperSpec} package. +#' Please use function `hySpc.read.jdx::read_jdx()` instead. +#' More on functions in package \pkg{hySpc.read.jdx} +#' [here (link)](https://r-hyperspec.github.io/hySpc.read.jdx/reference/index.html). +#' +#' *** +#' +#' **Old description:** #' #' This is a first rough import function for JCAMP-DX spectra. #' -#' So far, AFFN and PAC formats are supported for simple XYDATA, DATA TABLEs and PEAK TABLEs. +#' So far, AFFN and PAC formats are supported for simple XYDATA, DATA TABLEs and +#' PEAK TABLEs. #' #' NTUPLES / PAGES are not (yet) supported. #' #' DIF, DUF, DIFDUP and SQZ data formats are not (yet) supported. #' -#' @note JCAMP-DX support is incomplete and the functions may change without notice. See -#' `vignette ("fileio")` and the details section. +#' @note JCAMP-DX support is incomplete and the functions may change without +#' notice. +# +# See `vignette ("fileio")` and the details section. +# #' @param filename file name and path of the .jdx file #' @param encoding encoding of the JCAMP-DX file (used by [base::readLines()]) #' @param header list with manually set header values -#' @param keys.hdr2data index vector indicating which header entries should be tranfered into the -#' extra data. Usually a character vector of labels (lowercase, without and dashes, blanks, -#' underscores). If `TRUE`, all header entries are read. +#' @param keys.hdr2data index vector indicating which header entries should be +#' transferred into the extra data. Usually a character vector of labels +#' (lowercase, without and dashes, blanks, underscores). If `TRUE`, all +#' header entries are read. #' @param ... further parameters handed to the data import function, e.g. #' #' | parameter | meaning | default | @@ -27,32 +42,34 @@ #' | `xtol` | tolerance for checking calculated x values against checkpoints at beginning of line | XFACTOR | #' | `ytol` | tolerance for checking Y values against MINY and MAXY | YFACTOR | #' -#' @param NA.symbols character vector of text values that should be converted to `NA` -#' @param collapse.multi should hyperSpec objects from multispectra files be collapsed into one -#' hyperSpec object (if `FALSE`, a list of hyperSpec objects is returned). +#' @param NA.symbols character vector of text values that should be converted +#' to `NA` +#' @param collapse.multi should hyperSpec objects from multispectra files be +#' collapsed into one hyperSpec object (if `FALSE`, a list of hyperSpec +#' objects is returned). #' @param wl.tolerance,collapse.equal see [collapse] #' @return hyperSpec object #' @author C. Beleites with contributions by Bryan Hanson #' #' @export #' -#' @concept deprecated -#' #' @importFrom utils head modifyList maintainer read.jdx <- function(filename = NULL, encoding = "", header = list(), keys.hdr2data = FALSE, ..., NA.symbols = c("NA", "N/A", "N.A."), collapse.multi = TRUE, - wl.tolerance = hy.getOption("wl.tolerance"), collapse.equal = TRUE) { + wl.tolerance = hy.getOption("wl.tolerance"), + collapse.equal = TRUE) { # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - hySpc_deprecated(new="read_jdx()", package = "hySpc.read.jdx") + hySpc_deprecated(new = "read_jdx()", package = "hySpc.read.jdx") - if(is.null(filename)) return(NA) + if (is.null(filename)) return(NA) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - ## see readLines help: this way, encoding is translated to standard encoding on current system. + ## see readLines help: this way, encoding is translated to standard encoding + ## on current system. file <- file(filename, "r", encoding = encoding, blocking = FALSE) jdx <- readLines(file) close(file) @@ -83,7 +100,7 @@ read.jdx <- function(filename = NULL, encoding = "", for (s in seq_along(datastart)) { ## look for header data - hdr <- modifyList(header, .jdx.readhdr(jdx [hdrstart [s]:(datastart [s] - 1)])) + hdr <- modifyList(header, .jdx.readhdr(jdx[hdrstart[s]:(datastart[s] - 1)])) if (!is.null(hdr$page) || !is.null(hdr$ntuples)) { stop("NTUPLES / PAGEs are not yet supported.") @@ -91,18 +108,18 @@ read.jdx <- function(filename = NULL, encoding = "", if (s == 1L) { ## file header may contain overall settings hdr <- modifyList(list(file = as.character(filename)), hdr) - header <- hdr [!names(hdr) %in% .key2names(.DATA.START)] + header <- hdr[!names(hdr) %in% .key2names(.DATA.START)] } ## evaluate data block - if (grepl("[A-DF-Za-df-z%@]", jdx[datastart [s]])) { + if (grepl("[A-DF-Za-df-z%@]", jdx[datastart[s]])) { stop("SQZ, DIF, and DIFDUP forms are not yet supported.") } spc[[s]] <- switch(hdr$.format, - `(X++(Y..Y))` = .jdx.TABULAR.PAC(hdr, jdx [datastart [s]:spcend [s]], ...), - `(XY..XY)` = .jdx.TABULAR.AFFN(hdr, jdx [datastart [s]:spcend [s]], ...), + `(X++(Y..Y))` = .jdx.TABULAR.PAC(hdr, jdx[datastart[s]:spcend[s]], ...), + `(XY..XY)` = .jdx.TABULAR.AFFN(hdr, jdx[datastart[s]:spcend[s]], ...), stop("unknown JCAMP-DX data format: ", hdr$xydata) ) @@ -126,16 +143,16 @@ read.jdx <- function(filename = NULL, encoding = "", .jdx.readhdr <- function(hdr) { ## get rid of comments. JCAMP-DX comments start with $$ and go to the end of the line. - hdr <- hdr [!grepl("^[[:blank:]]*[$][$]", hdr)] + hdr <- hdr[!grepl("^[[:blank:]]*[$][$]", hdr)] hdr <- gsub("([[:blank:]][$][$].*)$", "", hdr) ## now join lines that are not starting with ##KEY= with the KEYed line before nokey <- grep("^[[:blank:]]*##.*=", hdr, invert = TRUE) if (length(nokey) > 0) { for (l in rev(nokey)) { # these are few, so no optimization needed - hdr [l - 1] <- paste(hdr [(l - 1):l], collapse = " ") + hdr[l - 1] <- paste(hdr[(l - 1):l], collapse = " ") } - hdr <- hdr [-nokey] + hdr <- hdr[-nokey] } names <- .key2names(sub("^[[:blank:]]*##(.*)=.*$", "\\1", hdr)) @@ -145,7 +162,7 @@ read.jdx <- function(filename = NULL, encoding = "", i <- grepl("^[[:blank:]]*[-+]?[.[:digit:]]*[eE]?[-+]?[.[:digit:]]*[[:blank:]]*$", hdr) & !names %in% c("title", "datatype", "owner") hdr <- as.list(hdr) - hdr [i] <- as.numeric(hdr [i]) + hdr[i] <- as.numeric(hdr[i]) names(hdr) <- names ## e.g. Shimadzu does not always save XFACTOR and YFACTOR @@ -153,8 +170,8 @@ read.jdx <- function(filename = NULL, encoding = "", if (is.null(hdr$xfactor)) hdr$xfactor <- 1 ## we treat XYDATA and PEAK TABLEs the same way - format <- hdr [names(hdr) %in% .key2names(.DATA.START)] - format <- format [!sapply(format, is.null)] + format <- hdr[names(hdr) %in% .key2names(.DATA.START)] + format <- format[!sapply(format, is.null)] if (length(format) != 1) { stop( "contradicting format specification: please contact the maintainer (", @@ -207,9 +224,9 @@ read.jdx <- function(filename = NULL, encoding = "", "concentrations" )] <- NULL if (is.character(keys)) { - keys <- keys [keys %in% names(hdr)] + keys <- keys[keys %in% names(hdr)] } - hdr <- hdr [keys] + hdr <- hdr[keys] if (length(hdr) > 0L) { spc@data <- cbind(spc@data, hdr) @@ -218,8 +235,7 @@ read.jdx <- function(filename = NULL, encoding = "", spc } -### DATA FORMATS ------------------------------------------------------------------------------------ - +### DATA FORMATS -------------------------------------------------------------- .jdx.TABULAR.PAC <- function(hdr, data, ..., xtol = hdr$xfactor) { ## regexp for numbers including scientific notation @@ -249,7 +265,7 @@ read.jdx <- function(filename = NULL, encoding = "", ## X checkpoints x <- sub(paste0("^[[:blank:]]*(", .PATTERN.number, ")[[:blank:]]*.*$"), "\\1", data) x <- as.numeric(x) * hdr$xfactor - diffx <- abs(wl [c(1, head(cumsum(ny) + 1, -1))] - x) + diffx <- abs(wl[c(1, head(cumsum(ny) + 1, -1))] - x) if (any(diffx > xtol)) { message( "JDX file inconsistency: X axis differs from checkpoints. ", @@ -270,7 +286,7 @@ read.jdx <- function(filename = NULL, encoding = "", data <- unlist(data) data <- matrix(as.numeric(data), nrow = 2) - new("hyperSpec", wavelength = data [1, ] * hdr$xfactor, spc = data [2, ] * hdr$yfactor) + new("hyperSpec", wavelength = data[1, ] * hdr$xfactor, spc = data[2, ] * hdr$yfactor) } ### UNITS ------------------------------------------------------------------------------------------- @@ -307,30 +323,30 @@ read.jdx <- function(filename = NULL, encoding = "", ## HDR processing functions .jdx.hdr.concentrations <- function(spc, hdr, NA.symbols) { hdr <- strsplit(hdr$concentrations, "[)][[:blank:]]*[(]")[[1]] - hdr [length(hdr)] <- gsub(")$", "", hdr [length(hdr)]) - if (hdr [1] == "(NCU") { - hdr <- hdr [-1] + hdr[length(hdr)] <- gsub(")$", "", hdr[length(hdr)]) + if (hdr[1] == "(NCU") { + hdr <- hdr[-1] } else { - message("Unknown type of concentration specification in JDX file: ", hdr [1], ")") + message("Unknown type of concentration specification in JDX file: ", hdr[1], ")") } hdr <- simplify2array(strsplit(hdr, ",")) - hdr [hdr %in% NA.symbols] <- NA + hdr[hdr %in% NA.symbols] <- NA ## names - N <- hdr [1, ] + N <- hdr[1, ] N <- sub("^([^[:alpha:]]*)", "", N) N <- sub("([^[:alpha:]]*)$", "", N) N <- gsub("([^[:alnum:]_-])", ".", N) ## concentrations - C <- t(as.numeric(hdr [2, ])) + C <- t(as.numeric(hdr[2, ])) colnames(C) <- N C <- as.data.frame(C) spc@data <- cbind(spc@data, C) ## units - U <- as.list(hdr [3, ]) + U <- as.list(hdr[3, ]) names(U) <- N spc@label <- modifyList(spc@label, U) @@ -349,7 +365,9 @@ read.jdx <- function(filename = NULL, encoding = "", hySpc.testthat::test(read.jdx) <- function() { context("test-read.jdx") - test_that("deprecated", - expect_warning(read.jdx(), "deprecated.*hySpc.read.jdx")) + test_that( + "deprecated", + expect_warning(read.jdx(), "deprecated.*hySpc.read.jdx") + ) } From 574cdbaa8ffeb7e9fa332903f585b3e495a8ff5c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sat, 10 Jul 2021 21:07:43 +0300 Subject: [PATCH 13/27] Add message to rename file in separate PR --- hyperSpec/R/read.jdx.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/hyperSpec/R/read.jdx.R b/hyperSpec/R/read.jdx.R index 8382ec63..f147711d 100644 --- a/hyperSpec/R/read.jdx.R +++ b/hyperSpec/R/read.jdx.R @@ -1,3 +1,5 @@ +# TODO: rename this file to "DEPRECATED-read.jdx.R" in a separate pull request. + #' @name DEPRECATED-read.jdx #' @concept moved to hySpc.read.jdx #' From 7b1d104350d5b85be0e57794acc1ed424404a8a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sat, 10 Jul 2021 21:13:23 +0300 Subject: [PATCH 14/27] Update code style --- hyperSpec/R/DEPRECATED-spc_rubberband.R | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/hyperSpec/R/DEPRECATED-spc_rubberband.R b/hyperSpec/R/DEPRECATED-spc_rubberband.R index 743ca01a..6bfbe3ad 100644 --- a/hyperSpec/R/DEPRECATED-spc_rubberband.R +++ b/hyperSpec/R/DEPRECATED-spc_rubberband.R @@ -47,9 +47,11 @@ spc.rubberband <- function(...) { hySpc.testthat::test(spc.rubberband) <- function() { context("spc.rubberband") - test_that("deprecated", - expect_warning(spc.rubberband(paracetamol), - "Function 'spc.rubberband' is deprecated.") - ) - + test_that( + "deprecated", + expect_warning( + spc.rubberband(paracetamol), + "Function 'spc.rubberband' is deprecated." + ) + ) } From cee96119b8853d12f100caef98759f4210e593c8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sat, 10 Jul 2021 21:17:02 +0300 Subject: [PATCH 15/27] Undocument unused arguments of spc.rubberband() To avoid R CMD check warnings --- hyperSpec/R/DEPRECATED-spc_rubberband.R | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/hyperSpec/R/DEPRECATED-spc_rubberband.R b/hyperSpec/R/DEPRECATED-spc_rubberband.R index 6bfbe3ad..02b1f0e5 100644 --- a/hyperSpec/R/DEPRECATED-spc_rubberband.R +++ b/hyperSpec/R/DEPRECATED-spc_rubberband.R @@ -17,10 +17,13 @@ #' Use `debuglevel >= 1` to obtain debug plots, either directly via function #' argument or by setting hyperSpec's `debuglevel` option. #' @param ... handed to [hyperSpec::spc_rubberband()] -#' @param upper logical indicating whether the lower or upper part of the hull should be used -#' @param noise noise level to be taken into account -#' @param spline logical indicating whether the baseline should be an interpolating spline through -#' the support points or piecewise linear. +# +# @param upper logical indicating whether the lower or upper part of the +# hull should be used +# @param noise noise level to be taken into account +# @param spline logical indicating whether the baseline should be an +# interpolating spline through the support points or piecewise linear. +#' #' @return `hyperSpec` object containing the baselines #' #' @author Claudia Beleites From 6b77298025aa675409d46de0e8966bb77e69ee48 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sat, 10 Jul 2021 21:20:41 +0300 Subject: [PATCH 16/27] Update style --- hyperSpec/R/DEPRECATED-extract_numbers.R | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/hyperSpec/R/DEPRECATED-extract_numbers.R b/hyperSpec/R/DEPRECATED-extract_numbers.R index 87c87838..d0433606 100644 --- a/hyperSpec/R/DEPRECATED-extract_numbers.R +++ b/hyperSpec/R/DEPRECATED-extract_numbers.R @@ -1,7 +1,7 @@ #' @name DEPRECATED-guess.wavlength #' @concept deprecated #' -#' @title (DEPRECATED) Guess Wavelengths from Character Vector +#' @title (DEPRECATED) Guess wavelengths from character vector #' #' #' @description @@ -16,7 +16,7 @@ #' #' Character vectors used for names (e.g. colnames for matrices or data.frames) #' are often treated by [base::make.names()] or similar functions that -#' produce suitable names (e.g. by prepending "X" to numbers). Such names +#' produce suitable names (e.g. by pre-pending "X" to numbers). Such names #' cannot be directly converted to numeric. #' #' `guess.wavlength()` tries to extract numbers from X which may be @@ -40,9 +40,7 @@ guess.wavelength <- function(X) { # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ hySpc_deprecated("extract_numbers") # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - extract_numbers(X) - } #' @include constants-regexps.R @@ -51,7 +49,9 @@ hySpc.testthat::test(guess.wavelength) <- function() { context("guess.wavelength") test_that("deprecated", { - expect_warning (guess.wavelength(1:5), - "Function 'guess.wavelength' is deprecated.") + expect_warning( + guess.wavelength(1:5), + "Function 'guess.wavelength' is deprecated." + ) }) } From cd38f23fda8ee95301fc9b40ee7c7f92c12c18ed Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sat, 10 Jul 2021 21:24:17 +0300 Subject: [PATCH 17/27] Update style --- hyperSpec/R/DEPRECATED-spc_fit_poly.R | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/hyperSpec/R/DEPRECATED-spc_fit_poly.R b/hyperSpec/R/DEPRECATED-spc_fit_poly.R index ab960b01..ece02c24 100644 --- a/hyperSpec/R/DEPRECATED-spc_fit_poly.R +++ b/hyperSpec/R/DEPRECATED-spc_fit_poly.R @@ -13,7 +13,7 @@ #' #' `_____________` #' -#' These functions fit polynomal baselines. +#' These functions fit polynomial baselines. #' #' @details #' Both functions fit polynomials to be used as baselines. If `apply.to` @@ -26,9 +26,9 @@ #' Thus `fit.to` needs to be cut appropriately. #' #' @param ... handed to [hyperSpec::spc_fit_poly_below()] -#' @return `hyperSpec` object containing the baselines in the spectra -#' matrix, either as polynomial coefficients or as polynomials evaluted on -#' the spectral range of `apply.to` +#' @return `hyperSpec` object containing the baselines in the spectra matrix, +#' either as polynomial coefficients or as polynomials evaluted on +#' the spectral range of `apply.to` #' @author C. Beleites #' @include spc_fit_poly.R #' @@ -50,10 +50,11 @@ hySpc.testthat::test(spc.fit.poly) <- function() { test_that( "deprecated", - expect_warning (spc.fit.poly(flu), - "Function 'spc.fit.poly' is deprecated.") + expect_warning( + spc.fit.poly(flu), + "Function 'spc.fit.poly' is deprecated." + ) ) - } #' @rdname DEPRECATED-baselines @@ -71,7 +72,7 @@ spc.fit.poly.below <- function(...) { hySpc_deprecated("spc_fit_poly_below") # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - spc_fit_poly_below (...) + spc_fit_poly_below(...) } @@ -80,8 +81,9 @@ hySpc.testthat::test(spc.fit.poly.below) <- function() { test_that( "deprecated", - expect_warning (spc.fit.poly.below(flu), - "Function 'spc.fit.poly.below' is deprecated.") + expect_warning( + spc.fit.poly.below(flu), + "Function 'spc.fit.poly.below' is deprecated." + ) ) - } From 96803fefe34b6680b8ff44c71e1282a1375d32ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sat, 10 Jul 2021 21:29:47 +0300 Subject: [PATCH 18/27] Update style --- hyperSpec/R/DEPRECATED-spc_fix_colnames.R | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/hyperSpec/R/DEPRECATED-spc_fix_colnames.R b/hyperSpec/R/DEPRECATED-spc_fix_colnames.R index 331e22af..a550c169 100644 --- a/hyperSpec/R/DEPRECATED-spc_fix_colnames.R +++ b/hyperSpec/R/DEPRECATED-spc_fix_colnames.R @@ -1,7 +1,7 @@ #' @name DEPRECATED-fix_spc_colnames #' @concept deprecated #' -#' @title (DEPRECATED) Ensure That the Spectra Matrix Has the Wavelengths in Column Names +#' @title (DEPRECATED) Ensure that the spectra matrix has the wavelengths in column names #' #' #' @description @@ -32,10 +32,13 @@ hySpc.testthat::test(.fix_spc_colnames) <- function() { context(".fix_spc_colnames") - test_that ("deprecated", - expect_warning (.fix_spc_colnames(flu), - "Function '.fix_spc_colnames' is deprecated.") - ) + test_that( + "deprecated", + expect_warning( + .fix_spc_colnames(flu), + "Function '.fix_spc_colnames' is deprecated." + ) + ) test_that("colnames get fixed", { tmp <- flu From 1eb06ada73b49c6df1f2baf3dc32c3e32e83bcf1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sat, 10 Jul 2021 21:29:54 +0300 Subject: [PATCH 19/27] Update style --- hyperSpec/R/DEPRECATED-wl_eval.R | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/hyperSpec/R/DEPRECATED-wl_eval.R b/hyperSpec/R/DEPRECATED-wl_eval.R index 14884766..e6c1b33e 100644 --- a/hyperSpec/R/DEPRECATED-wl_eval.R +++ b/hyperSpec/R/DEPRECATED-wl_eval.R @@ -17,7 +17,7 @@ #' #' @param x either `hyperSpec` object or numeric vector. #' @param ... expressions to be evaluated. -#' @param normalize.wl function to transorm the wavelengths before evaluating +#' @param normalize.wl function to transform the wavelengths before evaluating #' the polynomial (or other function). Use [hyperSpec::normalize01()] to map #' the wavelength range to the interval \[0, 1\]. #' @return `hyperSpec` object containing one spectrum for each expression. @@ -27,7 +27,7 @@ #' #' @seealso #' -#' - [hyperSpec::vanderMonde()] for polynomials, +#' - [hyperSpec::vanderMonde()] for polynomials, #' - [hyperSpec::normalize01()] to normalize the wavenumbers before evaluating #' the function. #' @@ -48,7 +48,7 @@ wl.eval.hyperSpec <- function(x, ..., normalize.wl = I) { hySpc_deprecated("wl_eval.hyperSpec") # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - wl_eval.hyperSpec (x, ..., normalize.wl = normalize.wl) + wl_eval.hyperSpec(x, ..., normalize.wl = normalize.wl) } @@ -59,7 +59,7 @@ wl.eval.numeric <- function(x, ..., normalize.wl = I) { hySpc_deprecated("wl_eval.numeric") # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - wl_eval.numeric (x, ..., normalize.wl = normalize.wl) + wl_eval.numeric(x, ..., normalize.wl = normalize.wl) } @@ -71,10 +71,13 @@ hySpc.testthat::test(wl.eval.hyperSpec) <- function() { context("wl.eval") test_that("deprecated", { - expect_warning(wl.eval.hyperSpec (flu, function(x) x), - "Function 'wl.eval.hyperSpec' is deprecated.") - expect_warning(wl.eval.numeric (1:5, function(x) x), - "Function 'wl.eval.numeric' is deprecated.") + expect_warning( + wl.eval.hyperSpec(flu, function(x) x), + "Function 'wl.eval.hyperSpec' is deprecated." + ) + expect_warning( + wl.eval.numeric(1:5, function(x) x), + "Function 'wl.eval.numeric' is deprecated." + ) }) - } From b4f7cf6276ea049b4e0bef9b746ffa4bf90b90f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sat, 10 Jul 2021 21:42:30 +0300 Subject: [PATCH 20/27] Update style of function titles Addresses #330 --- hyperSpec/DESCRIPTION | 2 +- hyperSpec/R/DEPRECATED-count_lines.R | 3 ++- hyperSpec/R/DEPRECATED-extract_numbers.R | 3 ++- hyperSpec/R/DEPRECATED-ggplot2.R | 2 +- hyperSpec/R/DEPRECATED-read.asc.Andor.R | 4 ++-- hyperSpec/R/DEPRECATED-read.asc.PerkinElmer.R | 3 ++- hyperSpec/R/DEPRECATED-read.ini.R | 3 ++- hyperSpec/R/DEPRECATED-read.txt.Horiba.R | 3 ++- hyperSpec/R/DEPRECATED-read.txt.Renishaw.R | 3 ++- hyperSpec/R/DEPRECATED-read.txt.Shimadzu.R | 3 ++- hyperSpec/R/DEPRECATED-read.txt.Witec.R | 3 ++- hyperSpec/R/DEPRECATED-read.txt.wide.R | 3 ++- hyperSpec/R/DEPRECATED-scan.R | 6 +++--- hyperSpec/R/DEPRECATED-spc-various.R | 3 ++- hyperSpec/R/DEPRECATED-spc_bin.R | 3 ++- hyperSpec/R/DEPRECATED-spc_fit_poly.R | 3 ++- hyperSpec/R/DEPRECATED-spc_fix_colnames.R | 3 ++- hyperSpec/R/DEPRECATED-spc_loess.R | 3 ++- hyperSpec/R/DEPRECATED-spc_na_approx.R | 3 ++- hyperSpec/R/DEPRECATED-spc_rubberband.R | 3 ++- hyperSpec/R/DEPRECATED-spc_spline.R | 3 ++- hyperSpec/R/DEPRECATED-wc.R | 3 ++- hyperSpec/R/DEPRECATED-wl_convert_units.R | 3 ++- hyperSpec/R/DEPRECATED-wl_sort.R | 3 ++- hyperSpec/R/DEPRECATED-write_txt_long.R | 3 ++- hyperSpec/R/read.jdx.R | 3 ++- 26 files changed, 51 insertions(+), 29 deletions(-) diff --git a/hyperSpec/DESCRIPTION b/hyperSpec/DESCRIPTION index f6b135ea..1365fd48 100644 --- a/hyperSpec/DESCRIPTION +++ b/hyperSpec/DESCRIPTION @@ -4,7 +4,7 @@ Type: Package Title: Work with Hyperspectral Data, i.e. Spectra + Meta Information (Spatial, Time, Concentration, ...) Version: 0.100.0 -Date: 2020-08-24 +Date: 2021-07-10 Maintainer: Claudia Beleites Authors@R: c( person("Claudia", "Beleites", role = c("aut", "cre", "dtc"), email = "Claudia.Beleites@chemometrix.gmbh"), diff --git a/hyperSpec/R/DEPRECATED-count_lines.R b/hyperSpec/R/DEPRECATED-count_lines.R index 320367f0..6d0a089c 100644 --- a/hyperSpec/R/DEPRECATED-count_lines.R +++ b/hyperSpec/R/DEPRECATED-count_lines.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-count_lines #' @concept moved to hySpc.read.txt #' -#' @title (DEPRECATED) Count Lines (of an ASCII File) +#' @title (DEPRECATED) +#' Count lines (of an ASCII File) #' #' @description #' diff --git a/hyperSpec/R/DEPRECATED-extract_numbers.R b/hyperSpec/R/DEPRECATED-extract_numbers.R index d0433606..0528a361 100644 --- a/hyperSpec/R/DEPRECATED-extract_numbers.R +++ b/hyperSpec/R/DEPRECATED-extract_numbers.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-guess.wavlength #' @concept deprecated #' -#' @title (DEPRECATED) Guess wavelengths from character vector +#' @title (DEPRECATED) +#' Guess wavelengths from character vector #' #' #' @description diff --git a/hyperSpec/R/DEPRECATED-ggplot2.R b/hyperSpec/R/DEPRECATED-ggplot2.R index ab8e5651..c4bf6006 100644 --- a/hyperSpec/R/DEPRECATED-ggplot2.R +++ b/hyperSpec/R/DEPRECATED-ggplot2.R @@ -2,7 +2,7 @@ #' @concept moved to hySpc.ggplot2 #' #' @title (DEPRECATED) -#' Spectra Plotting with \pkg{ggplot2} Was Moved to \pkg{hySpc.ggplot2} +#' Spectra plotting with \pkg{ggplot2} was moved to \pkg{hySpc.ggplot2} #' #' @description #' diff --git a/hyperSpec/R/DEPRECATED-read.asc.Andor.R b/hyperSpec/R/DEPRECATED-read.asc.Andor.R index ac88f5f0..4ae13c74 100644 --- a/hyperSpec/R/DEPRECATED-read.asc.Andor.R +++ b/hyperSpec/R/DEPRECATED-read.asc.Andor.R @@ -2,9 +2,9 @@ #' @concept moved to hySpc.read.txt #' #' @title (DEPRECATED) -#' Import Raman Spectra/Maps from Andor Cameras/Solis ASCII Files -#' @description +#' Import Raman spectra/maps from Andor cameras/solis ASCII files #' +#' @description #' These data input functions are **deprecated** and they will be removed in #' the next release of \pkg{hyperspec} package. #' Now functions in package \pkg{hySpc.read.txt} diff --git a/hyperSpec/R/DEPRECATED-read.asc.PerkinElmer.R b/hyperSpec/R/DEPRECATED-read.asc.PerkinElmer.R index 9cf6a0ef..dbc76f3c 100644 --- a/hyperSpec/R/DEPRECATED-read.asc.PerkinElmer.R +++ b/hyperSpec/R/DEPRECATED-read.asc.PerkinElmer.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-read.asc.PerkinElmer #' @concept moved to hySpc.read.txt #' -#' @title (DEPRECATED) File import filter PerkinElmer ASCII spectra +#' @title (DEPRECATED) +#' File import filter PerkinElmer ASCII spectra #' #' @description #' diff --git a/hyperSpec/R/DEPRECATED-read.ini.R b/hyperSpec/R/DEPRECATED-read.ini.R index 692f7905..c2ce1615 100644 --- a/hyperSpec/R/DEPRECATED-read.ini.R +++ b/hyperSpec/R/DEPRECATED-read.ini.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-read.ini #' @concept moved to hySpc.read.txt #' -#' @title (DEPRECATED) Read INI files +#' @title (DEPRECATED) +#' Read INI files #' #' @description #' diff --git a/hyperSpec/R/DEPRECATED-read.txt.Horiba.R b/hyperSpec/R/DEPRECATED-read.txt.Horiba.R index ab94a254..d3c0a98e 100644 --- a/hyperSpec/R/DEPRECATED-read.txt.Horiba.R +++ b/hyperSpec/R/DEPRECATED-read.txt.Horiba.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-read.txt.Horiba #' @concept moved to hySpc.read.txt #' -#' @title (DEPRECATED) Import Horiba Labspec exported ASCII files +#' @title (DEPRECATED) +#' Import Horiba Labspec exported ASCII files #' #' @description #' These data input functions are **deprecated** and they will be removed in diff --git a/hyperSpec/R/DEPRECATED-read.txt.Renishaw.R b/hyperSpec/R/DEPRECATED-read.txt.Renishaw.R index 1495c510..bca5cb42 100644 --- a/hyperSpec/R/DEPRECATED-read.txt.Renishaw.R +++ b/hyperSpec/R/DEPRECATED-read.txt.Renishaw.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-read.txt.Renishaw #' @concept moved to hySpc.read.txt #' -#' @title (DEPRECATED) Import Raman measurements from Renishaw ASCII-files +#' @title (DEPRECATED) +#' Import Raman measurements from Renishaw ASCII-files #' #' @description #' diff --git a/hyperSpec/R/DEPRECATED-read.txt.Shimadzu.R b/hyperSpec/R/DEPRECATED-read.txt.Shimadzu.R index c52209aa..7ea2c3b2 100644 --- a/hyperSpec/R/DEPRECATED-read.txt.Shimadzu.R +++ b/hyperSpec/R/DEPRECATED-read.txt.Shimadzu.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-read.txt.Shimadzu #' @concept moved to hySpc.read.txt #' -#' @title (DEPRECATED) Reads Shimadzu GCxGC-qMS - Spectra Files (`.txt`) +#' @title (DEPRECATED) +#' Read Shimadzu GCxGC-qMS - spectra files (`.txt`) #' #' @description #' diff --git a/hyperSpec/R/DEPRECATED-read.txt.Witec.R b/hyperSpec/R/DEPRECATED-read.txt.Witec.R index 1ae087b0..e13df1dc 100644 --- a/hyperSpec/R/DEPRECATED-read.txt.Witec.R +++ b/hyperSpec/R/DEPRECATED-read.txt.Witec.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-read.txt.Witec #' @concept moved to hySpc.read.txt #' -#' @title (DEPRECATED) File Import Witec Raman +#' @title (DEPRECATED) +#' File import Witec Raman #' #' @description #' diff --git a/hyperSpec/R/DEPRECATED-read.txt.wide.R b/hyperSpec/R/DEPRECATED-read.txt.wide.R index be50225a..2e713f87 100644 --- a/hyperSpec/R/DEPRECATED-read.txt.wide.R +++ b/hyperSpec/R/DEPRECATED-read.txt.wide.R @@ -9,7 +9,8 @@ #' @rdname DEPRECATED-textio #' @concept deprecated #' -#' @title (DEPRECATED) Import `hyperSpec` objects from ASCII (text) files +#' @title (DEPRECATED) +#' Import `hyperSpec` objects from ASCII (text) files #' #' @description #' These \pkg{hyperSpec} functions are **deprecated** and not maintained any diff --git a/hyperSpec/R/DEPRECATED-scan.R b/hyperSpec/R/DEPRECATED-scan.R index ea1d2694..0ddb1ec6 100644 --- a/hyperSpec/R/DEPRECATED-scan.R +++ b/hyperSpec/R/DEPRECATED-scan.R @@ -1,7 +1,8 @@ #' @name deprecated #' @concept deprecated #' -#' @title Deprecated and Defunct Functions +#' @title Deprecated and defunct functions +#' #' @description #' These \pkg{hyperSpec} functions are **deprecated** and not maintained any #' more. You should not use these. @@ -72,8 +73,7 @@ scan.txt.Witec.Graph <- function(...) { } -#### DEFUNCT ################################################################################################## - +#### DEFUNCT ################################################################## #' @rdname deprecated #' @details #' - Instead of `read.cytomat()` use [read.mat.Cytospec()]. diff --git a/hyperSpec/R/DEPRECATED-spc-various.R b/hyperSpec/R/DEPRECATED-spc-various.R index 41024651..ef9714ed 100644 --- a/hyperSpec/R/DEPRECATED-spc-various.R +++ b/hyperSpec/R/DEPRECATED-spc-various.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-count_lines #' @concept moved to hySpc.read.txt #' -#' Count Lines (of an ASCII File) (DEPRECATED) +#' @title (DEPRECATED) +#' Count lines (of an ASCII file) #' #' @description #' diff --git a/hyperSpec/R/DEPRECATED-spc_bin.R b/hyperSpec/R/DEPRECATED-spc_bin.R index 32bfb0f2..c007c3ae 100644 --- a/hyperSpec/R/DEPRECATED-spc_bin.R +++ b/hyperSpec/R/DEPRECATED-spc_bin.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-spc.bin #' @concept deprecated #' -#' @title (DEPRECATED) Wavelength Binning +#' @title (DEPRECATED) +#' Wavelength binning #' #' #' @description diff --git a/hyperSpec/R/DEPRECATED-spc_fit_poly.R b/hyperSpec/R/DEPRECATED-spc_fit_poly.R index ece02c24..1d3014a3 100644 --- a/hyperSpec/R/DEPRECATED-spc_fit_poly.R +++ b/hyperSpec/R/DEPRECATED-spc_fit_poly.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-baselines #' @concept deprecated #' -#' @title (DEPRECATED) Polynomial Baseline Fitting +#' @title (DEPRECATED) +#' Polynomial baseline fitting #' #' #' @description diff --git a/hyperSpec/R/DEPRECATED-spc_fix_colnames.R b/hyperSpec/R/DEPRECATED-spc_fix_colnames.R index a550c169..43ace3aa 100644 --- a/hyperSpec/R/DEPRECATED-spc_fix_colnames.R +++ b/hyperSpec/R/DEPRECATED-spc_fix_colnames.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-fix_spc_colnames #' @concept deprecated #' -#' @title (DEPRECATED) Ensure that the spectra matrix has the wavelengths in column names +#' @title (DEPRECATED) +#' Ensure that the spectra matrix has the wavelengths in column names #' #' #' @description diff --git a/hyperSpec/R/DEPRECATED-spc_loess.R b/hyperSpec/R/DEPRECATED-spc_loess.R index e15c9288..02bea966 100644 --- a/hyperSpec/R/DEPRECATED-spc_loess.R +++ b/hyperSpec/R/DEPRECATED-spc_loess.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-spc.loess #' @concept deprecated #' -#' @title (DEPRECATED) LOESS Smoothing Interpolation for Spectra +#' @title (DEPRECATED) +#' LOESS smoothing interpolation for spectra #' #' @description #' These \pkg{hyperSpec} functions are **deprecated** and not maintained any diff --git a/hyperSpec/R/DEPRECATED-spc_na_approx.R b/hyperSpec/R/DEPRECATED-spc_na_approx.R index 5ce97efa..3b81161e 100644 --- a/hyperSpec/R/DEPRECATED-spc_na_approx.R +++ b/hyperSpec/R/DEPRECATED-spc_na_approx.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-spc.NA.approx #' @concept deprecated #' -#' @title (DEPRECATED) Impute Missing Data Points +#' @title (DEPRECATED) +#' Impute missing data points #' #' @description #' These \pkg{hyperSpec} functions are **deprecated** and not maintained any diff --git a/hyperSpec/R/DEPRECATED-spc_rubberband.R b/hyperSpec/R/DEPRECATED-spc_rubberband.R index 02b1f0e5..59fc5c64 100644 --- a/hyperSpec/R/DEPRECATED-spc_rubberband.R +++ b/hyperSpec/R/DEPRECATED-spc_rubberband.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-spc-rubberband #' @concept deprecated #' -#' @title (DEPRECATED) Rubberband baseline correction +#' @title (DEPRECATED) +#' Rubberband baseline correction #' #' @description #' These \pkg{hyperSpec} functions are **deprecated** and not maintained any diff --git a/hyperSpec/R/DEPRECATED-spc_spline.R b/hyperSpec/R/DEPRECATED-spc_spline.R index 5679c446..fded773d 100644 --- a/hyperSpec/R/DEPRECATED-spc_spline.R +++ b/hyperSpec/R/DEPRECATED-spc_spline.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-spc.spline #' @concept deprecated #' -#' @title (DEPRECATED) Spectral smoothing by splines +#' @title (DEPRECATED) +#' Spectral smoothing by splines #' #' @description #' diff --git a/hyperSpec/R/DEPRECATED-wc.R b/hyperSpec/R/DEPRECATED-wc.R index dc8caee1..7d309dc9 100644 --- a/hyperSpec/R/DEPRECATED-wc.R +++ b/hyperSpec/R/DEPRECATED-wc.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-wc #' @concept moved to hySpc.read.txt #' -#' @title (DEPRECATED) Line/word/character count of ASCII files +#' @title (DEPRECATED) +#' Line/word/character count of ASCII files #' #' @description #' diff --git a/hyperSpec/R/DEPRECATED-wl_convert_units.R b/hyperSpec/R/DEPRECATED-wl_convert_units.R index b5c9a7b2..9d586c4a 100644 --- a/hyperSpec/R/DEPRECATED-wl_convert_units.R +++ b/hyperSpec/R/DEPRECATED-wl_convert_units.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-wlconv #' @concept deprecated #' -#' @title (DEPRECATED) Convert different wavelength units +#' @title (DEPRECATED) +#' Convert different wavelength units #' #' @description #' These \pkg{hyperSpec} functions are **deprecated** and not maintained any diff --git a/hyperSpec/R/DEPRECATED-wl_sort.R b/hyperSpec/R/DEPRECATED-wl_sort.R index 8574176f..d3c9d82a 100644 --- a/hyperSpec/R/DEPRECATED-wl_sort.R +++ b/hyperSpec/R/DEPRECATED-wl_sort.R @@ -1,7 +1,8 @@ #' @name DEPRECATED-orderwl #' @concept deprecated #' -#' @title (DEPRECATED) Sorting the Wavelengths of a `hyperSpec` Object +#' @title (DEPRECATED) +#' Sorting the wavelengths of a `hyperSpec` object #' #' @description #' These \pkg{hyperSpec} functions are **deprecated** and not maintained any diff --git a/hyperSpec/R/DEPRECATED-write_txt_long.R b/hyperSpec/R/DEPRECATED-write_txt_long.R index 9a8cae0c..a16d3fef 100644 --- a/hyperSpec/R/DEPRECATED-write_txt_long.R +++ b/hyperSpec/R/DEPRECATED-write_txt_long.R @@ -7,7 +7,8 @@ #' @name DEPRECATED-write_txt #' @concept deprecated #' -#' @title (DEPRECATED) Export `hyperSpec` objects to ASCII (text) files +#' @title (DEPRECATED) +#' Export `hyperSpec` objects to ASCII (text) files #' #' @description #' These \pkg{hyperSpec} functions are **deprecated** and not maintained any diff --git a/hyperSpec/R/read.jdx.R b/hyperSpec/R/read.jdx.R index f147711d..ec7f4245 100644 --- a/hyperSpec/R/read.jdx.R +++ b/hyperSpec/R/read.jdx.R @@ -3,7 +3,8 @@ #' @name DEPRECATED-read.jdx #' @concept moved to hySpc.read.jdx #' -#' @title (DEPRECATED) JCAMP-DX import for Shimadzu library spectra +#' @title (DEPRECATED) +#' JCAMP-DX import for Shimadzu library spectra #' #' @description #' This function is **deprecated** and will be removed in the next release From 20e05e6e45649db50c089f2a668a6994faed85f5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sun, 11 Jul 2021 03:12:28 +0300 Subject: [PATCH 21/27] Update unit tests: ggplot2 --- hyperSpec/R/DEPRECATED-ggplot2.R | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/hyperSpec/R/DEPRECATED-ggplot2.R b/hyperSpec/R/DEPRECATED-ggplot2.R index c4bf6006..1ad3637f 100644 --- a/hyperSpec/R/DEPRECATED-ggplot2.R +++ b/hyperSpec/R/DEPRECATED-ggplot2.R @@ -609,3 +609,15 @@ colmix.rgb <- function(x, purecol, against = 1, sub = TRUE, cols } + +# Unit tests ----------------------------------------------------------------- + +hySpc.testthat::test(qplotspc) <- function() { + context("ggplot2") + + test_that("deprecated", { + expect_warning(res <- qplotspc(flu), "deprecated") + expect_warning(res <- qplotmap(flu), "deprecated") + expect_warning(res <- qplotc(flu), "deprecated") + }) +} From 0ead2b0d416cff14dc6b4d29bb2a0f82f059ac1c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sun, 11 Jul 2021 03:12:38 +0300 Subject: [PATCH 22/27] Update unit tests --- hyperSpec/R/DEPRECATED-spc_bin.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/hyperSpec/R/DEPRECATED-spc_bin.R b/hyperSpec/R/DEPRECATED-spc_bin.R index c007c3ae..8287f351 100644 --- a/hyperSpec/R/DEPRECATED-spc_bin.R +++ b/hyperSpec/R/DEPRECATED-spc_bin.R @@ -123,7 +123,7 @@ hySpc.testthat::test(spc.bin) <- function() { test_that("spc.bin() returns errors", { - expect_error(spc.bin(sp), "reduction factor needed") + expect_warning(expect_error(spc.bin(sp), "reduction factor needed"), "deprecated") }) test_that("$spc after spc.bin() is correct", { @@ -147,7 +147,7 @@ hySpc.testthat::test(spc.bin) <- function() { test_that("spc.bin() sets spc matrix column names correctly", { # Wavelengths should be identical - sp_binned <- spc.bin(sp, 1) + sp_binned <- expect_warning(spc.bin(sp, 1), "deprecated") # Wavelengths should be identical expect_silent(wl_regular <- wl(sp)) @@ -167,7 +167,9 @@ hySpc.testthat::test(spc.bin) <- function() { expect_true(any(is.na(sp_na[[]]))) # NA's are present - na_rm_false <- spc.bin(sp_na, 3, na.rm = FALSE)[[]] + na_rm_false <- + expect_warning(spc.bin(sp_na, 3, na.rm = FALSE)[[]], "deprecated") + expect_equal(ncol(na_rm_false), 3) expect_equal(nrow(na_rm_false), 5) expect_true(any(is.na(na_rm_false))) From 3d6a5d4d778d656680e3c830141130bc2a7728b6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sun, 11 Jul 2021 03:12:47 +0300 Subject: [PATCH 23/27] Update unit tests --- hyperSpec/R/DEPRECATED-wl_convert_units.R | 26 +++++++++++++++-------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/hyperSpec/R/DEPRECATED-wl_convert_units.R b/hyperSpec/R/DEPRECATED-wl_convert_units.R index 9d586c4a..e4ea1371 100644 --- a/hyperSpec/R/DEPRECATED-wl_convert_units.R +++ b/hyperSpec/R/DEPRECATED-wl_convert_units.R @@ -324,24 +324,32 @@ hySpc.testthat::test(wlconv) <- function() { context("wlconv") test_that("wlconv() throws error", { - expect_error(wlconv()) + expect_error(expect_warning(wlconv(), "deprecated")) expect_error( - wlconv(1000, "raman", "nm"), + expect_warning(wlconv(1000, "raman", "nm"), "deprecated"), "Working with Raman shift requires knowledge of laser wavelength" ) - expect_error(wlconv(1000, "non-existing", "nm"), "Unknown unit type") - expect_error(wlconv(1000, "nm", "non-existing"), "Unknown unit type") + + expect_error( + expect_warning(wlconv(1000, "non-existing", "nm"), "deprecated"), + "Unknown unit type" + ) + + expect_error( + expect_warning(wlconv(1000, "nm", "non-existing"), "deprecated"), + "Unknown unit type" + ) }) test_that("wlconv() output is correct if units do not change", { # No conversion is expected - expect_equal(wlconv(1000, "raman", "raman"), 1000) - expect_equal(wlconv(1000, "invcm", "invcm"), 1000) - expect_equal(wlconv(1000, "nm", "nm"), 1000) - expect_equal(wlconv(1000, "ev", "ev"), 1000) - expect_equal(wlconv(1000, "freq", "freq"), 1000) + expect_warning(expect_equal(wlconv(1000, "raman", "raman"), 1000), "deprecated") + expect_warning(expect_equal(wlconv(1000, "invcm", "invcm"), 1000), "deprecated") + expect_warning(expect_equal(wlconv(1000, "nm", "nm"), 1000), "deprecated") + expect_warning(expect_equal(wlconv(1000, "ev", "ev"), 1000), "deprecated") + expect_warning(expect_equal(wlconv(1000, "freq", "freq"), 1000), "deprecated") }) From c971a0474617a3e116fbec836c3ac389bb676bc3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sun, 11 Jul 2021 03:20:39 +0300 Subject: [PATCH 24/27] Update unit tests: suppress deprecation warnings --- hyperSpec/R/DEPRECATED-spc_loess.R | 2 +- hyperSpec/R/DEPRECATED-spc_na_approx.R | 16 +++++++++++++--- hyperSpec/R/DEPRECATED-spc_spline.R | 2 +- 3 files changed, 15 insertions(+), 5 deletions(-) diff --git a/hyperSpec/R/DEPRECATED-spc_loess.R b/hyperSpec/R/DEPRECATED-spc_loess.R index 02bea966..dbb09221 100644 --- a/hyperSpec/R/DEPRECATED-spc_loess.R +++ b/hyperSpec/R/DEPRECATED-spc_loess.R @@ -112,7 +112,7 @@ hySpc.testthat::test(spc.loess) <- function() { }) test_that("spc.loess() returns errors", { - expect_error(spc.loess()) + expect_warning(expect_error(spc.loess()), "deprecated") }) test_that("spc.loess() returns warnings", { diff --git a/hyperSpec/R/DEPRECATED-spc_na_approx.R b/hyperSpec/R/DEPRECATED-spc_na_approx.R index 3b81161e..cae0da35 100644 --- a/hyperSpec/R/DEPRECATED-spc_na_approx.R +++ b/hyperSpec/R/DEPRECATED-spc_na_approx.R @@ -136,7 +136,10 @@ hySpc.testthat::test(spc.NA.approx) <- function() { context("spc.NA.approx") test_that("linear interpolation", { - tmp <- spc.NA.approx(fluNA[-2, , min ~ 410]) + tmp <- expect_warning( + spc.NA.approx(fluNA[-2, , min ~ 410]), + "deprecated" + ) expect_equivalent( as.numeric(tmp[[, , 406]]), rowMeans(fluNA[[-2, , 405.5 ~ 406.5]], na.rm = TRUE) @@ -144,7 +147,10 @@ hySpc.testthat::test(spc.NA.approx) <- function() { }) test_that("spline interpolation", { - tmp <- spc.NA.approx(fluNA[-2, , min ~ 410], neighbours = 2) + tmp <- expect_warning( + spc.NA.approx(fluNA[-2, , min ~ 410], neighbours = 2), "deprecated" + ) + expect_true( all(abs(tmp[[, , 406]] - rowMeans(fluNA[[-2, , 405 ~ 407]], na.rm = TRUE)) <= 1e-5) @@ -157,7 +163,11 @@ hySpc.testthat::test(spc.NA.approx) <- function() { ranges <- list(405 ~ 407, 405.5 ~ 406.5, 405.6 ~ 406) for (d in 0:2) { for (r in ranges) { - tmp <- spc.NA.approx(fluNA[-2, , r], neighbours = 3, debuglevel = d) + tmp <- + expect_warning( + spc.NA.approx(fluNA[-2, , r], neighbours = 3, debuglevel = d), + "deprecated" + ) # expect_equal(round(as.numeric(tmp[[,, 406]]), 5), # round(rowMeans(fluNA[[-2,, r]], na.rm = TRUE), 5), # tolerance = 1e-5, diff --git a/hyperSpec/R/DEPRECATED-spc_spline.R b/hyperSpec/R/DEPRECATED-spc_spline.R index fded773d..f3a44e8f 100644 --- a/hyperSpec/R/DEPRECATED-spc_spline.R +++ b/hyperSpec/R/DEPRECATED-spc_spline.R @@ -76,7 +76,7 @@ hySpc.testthat::test(spc.smooth.spline) <- function() { # Perform tests test_that("spc.smooth.spline() returnts output silently", { - expect_error(spc.smooth.spline()) + expect_warning(expect_error(spc.smooth.spline()), "deprecated") expect_warning(hy <- spc.smooth.spline(flu), "deprecated") expect_is(hy, "hyperSpec") }) From 80f26e42fe7502ece98baa4b4cdf35dc1bd4df06 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sun, 11 Jul 2021 03:43:57 +0300 Subject: [PATCH 25/27] Deprecate .read.spe.xml --- hyperSpec/R/DEPRECATED-read.spe.R | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/hyperSpec/R/DEPRECATED-read.spe.R b/hyperSpec/R/DEPRECATED-read.spe.R index d3c99605..2b699a10 100644 --- a/hyperSpec/R/DEPRECATED-read.spe.R +++ b/hyperSpec/R/DEPRECATED-read.spe.R @@ -158,7 +158,23 @@ read.spe <- function(filename, xaxis = "file", acc2avg = F, cts_sec = F, .spc_io_postprocess_optional(spc, filename) } -#' Read XML footer from SPE file format version 3.0. + +#' @name DEPRECATED-read.spe.xml +#' @concept moved to hySpc.read.spe +#' +#' @title (DEPRECATED) +#' Read XML footer from SPE file format version 3.0 +#' +#' @description +#' +#' These data input functions are **deprecated** and they will be removed in +#' the next release of \pkg{hyperspec} package. +#' Now functions in package \pkg{hySpc.read.spe} +#' ([link](https://r-hyperspec.github.io/hySpc.read.spe/reference/index.html)) +#' should be used as the alternatives. +#' +#' +#' **Old description:** #' #' The new SPE file format, introduced in 2012, was designed to be backwards compatible with the #' previous format 2.5. The most prominent change is the new plain text XML footer holding vast @@ -176,6 +192,10 @@ read.spe <- function(filename, xaxis = "file", acc2avg = F, cts_sec = F, #' @importFrom xml2 as_list read_xml #' .read.spe.xml <- function(filename) { + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + deprecated_read_spe() + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + as_list(read_xml(.read.spe.xml_string(filename))) } From e08984381eb891f09bce4dc31511d8e6024d21c6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sun, 11 Jul 2021 03:44:18 +0300 Subject: [PATCH 26/27] Update contents of pkgdown website --- hyperSpec/_pkgdown.yml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/hyperSpec/_pkgdown.yml b/hyperSpec/_pkgdown.yml index 3b448e86..6492fdc3 100644 --- a/hyperSpec/_pkgdown.yml +++ b/hyperSpec/_pkgdown.yml @@ -226,8 +226,13 @@ reference: "wavelengths", "data generation", "stats", "moved to hySpc.ggplot2", - "moved to hySpc.read.txt", + "moved to hySpc.read.ENVI", + "moved to hySpc.read.jdx", "moved to hySpc.read.mat", + "moved to hySpc.read.spc", + "moved to hySpc.read.spe", + "moved to hySpc.read.txt", + "deprecated" )) From 922e1739bd7832a5afd2cd74040f736f19c1790d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Vilmantas=20G=C4=97g=C5=BEna?= Date: Sun, 11 Jul 2021 04:15:16 +0300 Subject: [PATCH 27/27] Updating from `develop` manually again ...in order not to lose changes due to error that occurred while updating from `develop` previously. --- hyperSpec/R/Arith.R | 12 +-- hyperSpec/R/Compare.R | 3 +- hyperSpec/R/Math.R | 10 +-- hyperSpec/R/Summary.R | 7 +- hyperSpec/R/aggregate.R | 10 ++- hyperSpec/R/all.equal.R | 12 +-- hyperSpec/R/apply.R | 12 +-- hyperSpec/R/as.data.frame.R | 40 ++++----- hyperSpec/R/as_hyperSpec.R | 14 ++-- hyperSpec/R/barbiturates.R | 2 +- hyperSpec/R/bind.R | 2 +- hyperSpec/R/colMeans.R | 7 +- hyperSpec/R/collapse.R | 80 +++++++++--------- hyperSpec/R/cov.R | 10 ++- hyperSpec/R/decomposition.R | 20 ++--- hyperSpec/R/dim.R | 4 +- hyperSpec/R/dimnames.R | 2 +- hyperSpec/R/droplevels.R | 6 +- hyperSpec/R/empty.R | 3 +- hyperSpec/R/expand.R | 2 +- hyperSpec/R/extract.R | 7 +- hyperSpec/R/extract_numbers.R | 2 +- hyperSpec/R/faux_cell.R | 7 +- hyperSpec/R/flu.R | 2 +- hyperSpec/R/generate-test-data.R | 4 +- hyperSpec/R/hy_attach.R | 24 +++--- hyperSpec/R/hy_auto_completion.R | 2 +- hyperSpec/R/hy_deprecation-messages.R | 18 ++-- .../R/hy_list_available_hySpc_packages.R | 1 - .../R/hy_list_installed_hySpc_packages.R | 2 - hyperSpec/R/hy_options.R | 6 +- hyperSpec/R/hyperspec-class.R | 1 - hyperSpec/R/hyperspec-package.R | 2 +- hyperSpec/R/initialize.R | 8 +- hyperSpec/R/labels.R | 8 +- hyperSpec/R/laser.R | 4 +- hyperSpec/R/levelplot.R | 5 +- hyperSpec/R/makeraster.R | 22 ++--- hyperSpec/R/map_identify.R | 12 +-- hyperSpec/R/map_sel_poly.R | 16 ++-- hyperSpec/R/mark_dendrogram.R | 24 +++--- hyperSpec/R/mark_peak.R | 2 +- hyperSpec/R/mean_sd.R | 3 +- hyperSpec/R/merge.R | 29 +++---- hyperSpec/R/mergeextra.R | 4 +- hyperSpec/R/mvtnorm.R | 6 +- hyperSpec/R/normalize01.R | 2 +- hyperSpec/R/palette_colorblind.R | 4 +- hyperSpec/R/palette_matlab.R | 14 ++-- hyperSpec/R/paracetamol.R | 3 +- hyperSpec/R/paste_row.R | 6 +- hyperSpec/R/pearson_dist.R | 6 +- hyperSpec/R/plot.R | 80 ++++++++---------- hyperSpec/R/plotc.R | 16 ++-- hyperSpec/R/plotmap.R | 5 +- hyperSpec/R/plotmat.R | 20 ++--- hyperSpec/R/plotspc.R | 84 +++++++++---------- hyperSpec/R/plotvoronoi.R | 15 ++-- hyperSpec/R/rbind.fill.R | 5 +- hyperSpec/R/read_txt_long.R | 4 +- hyperSpec/R/read_txt_wide.R | 8 +- hyperSpec/R/sample.R | 25 +++--- hyperSpec/R/scale.R | 2 +- hyperSpec/R/seq.R | 7 +- hyperSpec/R/show.R | 16 +--- hyperSpec/R/spc_bin.R | 10 +-- hyperSpec/R/spc_fit_poly.R | 22 +++-- hyperSpec/R/spc_fix_colnames.R | 5 +- hyperSpec/R/spc_identify.R | 2 +- hyperSpec/R/spc_loess.R | 3 +- hyperSpec/R/spc_na_approx.R | 41 +++++---- hyperSpec/R/spc_rubberband.R | 7 +- hyperSpec/R/spc_spline.R | 7 +- hyperSpec/R/split.R | 5 +- hyperSpec/R/subset.R | 2 +- hyperSpec/R/sweep.R | 11 +-- hyperSpec/R/trellis.factor.key.R | 4 +- hyperSpec/R/vandermonde.R | 10 +-- hyperSpec/R/wl.R | 6 +- hyperSpec/R/wl2i.R | 25 +++--- hyperSpec/R/wl_convert_units.R | 4 +- hyperSpec/R/wl_eval.R | 11 +-- hyperSpec/R/wl_sort.R | 3 +- hyperSpec/R/write_txt_long.R | 2 +- 84 files changed, 487 insertions(+), 494 deletions(-) diff --git a/hyperSpec/R/Arith.R b/hyperSpec/R/Arith.R index 3c20f6a3..b224fcfd 100644 --- a/hyperSpec/R/Arith.R +++ b/hyperSpec/R/Arith.R @@ -12,10 +12,10 @@ validObject(e2) if (length(e2[[]]) > length(e1[[]])) { - e1 <- .expand(e1, dim(e2) [c(1, 3)]) + e1 <- .expand(e1, dim(e2)[c(1, 3)]) } if (length(e1[[]]) > length(e2[[]])) { - e2 <- .expand(e2, dim(e1) [c(1, 3)]) + e2 <- .expand(e2, dim(e1)[c(1, 3)]) } e1[[]] <- callGeneric(e1[[]], e2[[]]) @@ -52,7 +52,9 @@ hySpc.testthat::test(.arith_hh) <- function() { }) } -#' @title Arithmetical Operators: `+`, `-`, `*`, `/`, `^`, `%%`, `%/%`, `%*%` for `hyperSpec` Objects +#' @title Arithmetical operators: `+`, `-`, `*`, `/`, `^`, `%%`, `%/%`, `%*%` +#' for `hyperSpec` objects +#' #' @description #' The arithmetical operators `+`, `-`, `*`, `/`, `^`, `%%`, `%/%`, and `%*%` #' `hyperSpec` objects. @@ -177,7 +179,7 @@ setMethod("Arith", signature(e1 = "hyperSpec", e2 = "missing"), .arith_h_) e1 <- .expand(e1, dim(e2)) } if (length(e1[[]]) > length(e2)) { - e2 <- .expand(e2, dim(e1) [c(1, 3)]) + e2 <- .expand(e2, dim(e1)[c(1, 3)]) } e1[[]] <- callGeneric(e1[[]], e2) @@ -278,7 +280,7 @@ setMethod("Arith", signature(e1 = "hyperSpec", e2 = "matrix"), .arith_hn) ## called /only/ with e2 hyperSpec but e1 numeric if (length(e2[[]]) > length(e1)) { - e1 <- .expand(e1, dim(e2) [c(1, 3)]) + e1 <- .expand(e1, dim(e2)[c(1, 3)]) } if (length(e1) > length(e2[[]])) { e2 <- .expand(e2, dim(e1)) diff --git a/hyperSpec/R/Compare.R b/hyperSpec/R/Compare.R index 09eb6324..19376ba8 100644 --- a/hyperSpec/R/Compare.R +++ b/hyperSpec/R/Compare.R @@ -1,4 +1,5 @@ -#' @title Comparison of `hyperSpec` Objects +#' @title comparison of `hyperSpec` objects +#' #' @description #' The comparison operators `>`, `<`, `>=`, `<=`, `==`, and `!=` for `hyperSpec` objects. #' diff --git a/hyperSpec/R/Math.R b/hyperSpec/R/Math.R index 86aaff53..cb375e48 100644 --- a/hyperSpec/R/Math.R +++ b/hyperSpec/R/Math.R @@ -1,5 +1,5 @@ # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.math2 <- function(x, digits) { +.math2 <- function(x, digits) { validObject(x) x[[]] <- callGeneric(x[[]], digits) @@ -7,7 +7,7 @@ x } -#' Mathematical Functions for `hyperSpec` Objects. +#' Mathematical functions for `hyperSpec` objects #' #' The functions `abs()`, `sign()`, `sqrt()`, `floor()`, `ceiling()`, `trunc()`, #' `round()`, `signif()`, `exp()`, `log()`, `expm1()`, `log1p()`, `cos()`, @@ -49,7 +49,8 @@ #' #' log(flu) setMethod( - "Math2", signature(x = "hyperSpec"), .math2) + "Math2", signature(x = "hyperSpec"), .math2 +) # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -94,7 +95,6 @@ setMethod("Math", signature(x = "hyperSpec"), .math) # Unit tests ----------------------------------------------------------------- hySpc.testthat::test(.math) <- function() { - context("math") # Perform tests @@ -104,7 +104,7 @@ hySpc.testthat::test(.math) <- function() { test_that("math works", { expect_silent(flu + flu) - expect_silent(flu ^ flu) + expect_silent(flu^flu) expect_silent(abs(flu)) expect_silent(sqrt(flu)) diff --git a/hyperSpec/R/Summary.R b/hyperSpec/R/Summary.R index 61dbdb85..4e04836a 100644 --- a/hyperSpec/R/Summary.R +++ b/hyperSpec/R/Summary.R @@ -1,4 +1,4 @@ -#' @title Statistical Summary and Other Functions for `hyperSpec` +#' @title Statistical summary and other functions for `hyperSpec` #' @description #' The functions #' @@ -57,7 +57,7 @@ setMethod( #' @export #' @examples #' -#' is.na(flu [, , 405 ~ 410]) +#' is.na(flu[, , 405 ~ 410]) setMethod( "is.na", signature(x = "hyperSpec"), function(x) { @@ -87,6 +87,7 @@ all_wl <- function(expression, na.rm = FALSE) { res } + # Unit tests ----------------------------------------------------------------- hySpc.testthat::test(all_wl) <- function() { @@ -146,6 +147,7 @@ any_wl <- function(expression, na.rm = FALSE) { # Unit tests ----------------------------------------------------------------- + hySpc.testthat::test(any_wl) <- function() { context("any_wl") @@ -192,6 +194,5 @@ hySpc.testthat::test(any_wl) <- function() { sum(flu), "Do you really want to use sum on a hyperSpec object?" ) - }) } diff --git a/hyperSpec/R/aggregate.R b/hyperSpec/R/aggregate.R index 61a0deea..4630ce55 100644 --- a/hyperSpec/R/aggregate.R +++ b/hyperSpec/R/aggregate.R @@ -12,7 +12,8 @@ # try a guess how many rows the result will have if (is.null(out.rows)) { - tmp <- .apply_workhorse(data = x@data[by[[1]], , drop = FALSE], MARGIN = 2, FUN = FUN, ...) + tmp <- .apply_workhorse(data = x@data[by[[1]], , drop = FALSE], MARGIN = 2, + FUN = FUN, ...) out.rows <- nrow(tmp) * length(by) } @@ -24,7 +25,8 @@ r <- 1 # keeping track of the actually filled rows for (i in seq(along = by)) { - tmp <- .apply_workhorse(data = x@data[by[[i]], , drop = FALSE], MARGIN = 2, FUN = FUN, ...) + tmp <- .apply_workhorse(data = x@data[by[[i]], , drop = FALSE], MARGIN = 2, + FUN = FUN, ...) prows <- nrow(tmp) - 1 @@ -61,7 +63,7 @@ } -#' Aggregate `hyperSpec` Objects +#' Aggregate `hyperSpec` objects #' #' Compute summary statistics for subsets of a `hyperSpec` object. #' @@ -152,7 +154,7 @@ #' } else if (length(x) == 2) { #' NULL #' } else { -#' x [1] +#' x[1] #' } #' } #' diff --git a/hyperSpec/R/all.equal.R b/hyperSpec/R/all.equal.R index aa6a4b16..d2091f19 100644 --- a/hyperSpec/R/all.equal.R +++ b/hyperSpec/R/all.equal.R @@ -23,8 +23,8 @@ ) } else { cmp <- all.equal( - target = target@data [order(colnames(target@data))], - current = current@data [order(colnames(current@data))], + target = target@data[order(colnames(target@data))], + current = current@data[order(colnames(current@data))], ..., tolerance = tolerance, check.attributes = check.attributes, check.names = check.names @@ -34,8 +34,8 @@ if (check.label) { cmp <- all.equal( - target = target@label [order(names(target@label))], - current = current@label [order(names(current@label))], + target = target@label[order(names(target@label))], + current = current@label[order(names(current@label))], ..., check.attributes = check.attributes, check.names = check.names ) @@ -77,8 +77,8 @@ hySpc.testthat::test(.all.equal) <- function() { test_that("column order", { expect_true(all.equal(flu, --flu, check.column.order = TRUE)) - expect_true(!isTRUE(all.equal(flu, flu [, rev(colnames(flu))], check.column.order = TRUE))) - expect_true(all.equal(flu, flu [, rev(colnames(flu))], check.column.order = FALSE)) + expect_true(!isTRUE(all.equal(flu, flu[, rev(colnames(flu))], check.column.order = TRUE))) + expect_true(all.equal(flu, flu[, rev(colnames(flu))], check.column.order = FALSE)) }) } diff --git a/hyperSpec/R/apply.R b/hyperSpec/R/apply.R index 27cf60b1..bd64e837 100644 --- a/hyperSpec/R/apply.R +++ b/hyperSpec/R/apply.R @@ -51,7 +51,7 @@ } # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .apply <- function(X, MARGIN, FUN, ..., label.wl = NULL, - label.spc = NULL, new.wavelength = NULL, simplify) { + label.spc = NULL, new.wavelength = NULL, simplify) { validObject(X) if (missing(MARGIN)) { # apply for functions that the complete spectra matrix @@ -119,14 +119,14 @@ X } -#' Compute Summary Statistics for the Spectra of a `hyperSpec` Object +#' Compute summary statistics for the spectra of a `hyperSpec` object #' #' `apply` gives the functionality of [base::apply()] for `hyperSpec` objects. #' -#' The generic functions of group [methods::Math()] are not definded +#' The generic functions of group [methods::Math()] are not defined #' for `hyperSpec` objects. Instead, `apply` can be used. For #' functions like `log()` that work on scalars, `MARGIN = 1 : 2` gives -#' the appropriate behaviour. +#' the appropriate behavior. #' #' `spcapply` does the same as `apply` with `MARGIN = 1`, but #' additionally allows to set a new wavelength axis and adjust the labels. @@ -183,10 +183,10 @@ #' apply(flu, 1:2, "*", -1)[[, , 405:407]] #' #' ## without MARGIN the whole matrix is handed to FUN -#' apply(flu [, , 405:407], , print)[[]] +#' apply(flu[, , 405:407], , print)[[]] #' #' ## whereas MARGIN = 1 : 2 leads to FUN being called for each element separately -#' apply(flu [, , 405:407], 1:2, print)[[]] +#' apply(flu[, , 405:407], 1:2, print)[[]] setMethod("apply", signature = signature(X = "hyperSpec"), .apply) diff --git a/hyperSpec/R/as.data.frame.R b/hyperSpec/R/as.data.frame.R index 1641e74e..80a78640 100644 --- a/hyperSpec/R/as.data.frame.R +++ b/hyperSpec/R/as.data.frame.R @@ -1,4 +1,4 @@ -#' Conversion of a `hyperSpec` Object into a Data Frame or Matrix +#' Conversion of a `hyperSpec` object into a data frame or matrix #' #' `as.data.frame()` returns `x@@data` (as data.frame), `as.matrix()` #' returns the spectra matrix `x@@data$spc` as matrix. @@ -22,9 +22,9 @@ #' #' @examples #' -#' as.data.frame(faux_cell [1:3, , 600 ~ 620]) -#' as.matrix(faux_cell [1:3, , 600 ~ 620]) -#' lm(c ~ spc, data = flu [, , 450]) +#' as.data.frame(faux_cell[1:3, , 600 ~ 620]) +#' as.matrix(faux_cell[1:3, , 600 ~ 620]) +#' lm(c ~ spc, data = flu[, , 450]) as.data.frame.hyperSpec <- function(x, row.names = TRUE, optional = NULL, ...) { validObject(x) @@ -80,8 +80,8 @@ as.matrix.hyperSpec <- function(x, ...) { #' expanded *in place*. #' @examples #' -#' as.wide.df(faux_cell [1:5, , 600 ~ 610]) -#' summary(as.wide.df(faux_cell [1:5, , 600 ~ 610])) +#' as.wide.df(faux_cell[1:5, , 600 ~ 610]) +#' summary(as.wide.df(faux_cell[1:5, , 600 ~ 610])) as.wide.df <- function(x, wl.prefix = "") { chk.hy(x) validObject(x) @@ -95,15 +95,15 @@ as.wide.df <- function(x, wl.prefix = "") { ## colnames should be preserved cols <- c( - colnames(x@data) [before], + colnames(x@data)[before], paste0(wl.prefix, colnames(x@data$spc)), - colnames(x@data) [after] + colnames(x@data)[after] ) x <- cbind( - x@data [, before], - as.data.frame(unclass(x@data [, ispc])), - x@data [, after] + x@data[, before], + as.data.frame(unclass(x@data[, ispc])), + x@data[, after] ) colnames(x) <- cols x @@ -114,8 +114,8 @@ hySpc.testthat::test(as.wide.df) <- function() { test_that("faux_cell", { expect_equal( - as.wide.df(faux_cell [1:5, , 600 ~ 610]), - cbind(faux_cell [1:5]$.., faux_cell[[1:5, , 600 ~ 610]]) + as.wide.df(faux_cell[1:5, , 600 ~ 610]), + cbind(faux_cell[1:5]$.., faux_cell[[1:5, , 600 ~ 610]]) ) }) @@ -166,10 +166,10 @@ hySpc.testthat::test(as.wide.df) <- function() { #' other functions producing long-format data.frames. #' @examples #' -#' as.long.df(flu [, , 405 ~ 410]) -#' summary(as.long.df(flu [, , 405 ~ 410])) -#' summary(as.long.df(flu [, , 405 ~ 410], rownames = TRUE)) -#' summary(as.long.df(flu [, , 405 ~ 410], wl.factor = TRUE)) +#' as.long.df(flu[, , 405 ~ 410]) +#' summary(as.long.df(flu[, , 405 ~ 410])) +#' summary(as.long.df(flu[, , 405 ~ 410], rownames = TRUE)) +#' summary(as.long.df(flu[, , 405 ~ 410], wl.factor = TRUE)) as.long.df <- function(x, rownames = FALSE, wl.factor = FALSE, na.rm = TRUE) { chk.hy(x) validObject(x) @@ -182,10 +182,10 @@ as.long.df <- function(x, rownames = FALSE, wl.factor = FALSE, na.rm = TRUE) { .wavelength = rep(NA, nrow(x)), spc = rep(NA, nrow(x)) ), - x@data [, -ispc, drop = FALSE] + x@data[, -ispc, drop = FALSE] ) } else { - tmp <- x@data [rep(row.seq(x), nwl(x)), -ispc, drop = FALSE] + tmp <- x@data[rep(row.seq(x), nwl(x)), -ispc, drop = FALSE] tmp <- cbind( data.frame( @@ -216,7 +216,7 @@ as.long.df <- function(x, rownames = FALSE, wl.factor = FALSE, na.rm = TRUE) { } if (na.rm) { - tmp <- tmp [!is.na(tmp$spc), ] + tmp <- tmp[!is.na(tmp$spc), ] } tmp diff --git a/hyperSpec/R/as_hyperSpec.R b/hyperSpec/R/as_hyperSpec.R index a0b8cb91..5e2a33af 100644 --- a/hyperSpec/R/as_hyperSpec.R +++ b/hyperSpec/R/as_hyperSpec.R @@ -1,5 +1,5 @@ -#' `as.hyperSpec`: Convenience Conversion Functions +#' `as.hyperSpec`: convenience conversion functions #' #' These functions are shortcuts to convert other objects into `hypeSpec` #' objects. @@ -19,9 +19,8 @@ #' @concept hyperSpec conversion #' setGeneric("as.hyperSpec", function(X, ...) { - stop("as.hyperSpec is not available for objects of class ", class(X)) - } -) + stop("as.hyperSpec is not available for objects of class ", class(X)) +}) #' @include extract_numbers.R .as.hyperSpec.matrix <- function(X, wl = NULL, ...) { @@ -44,8 +43,7 @@ setGeneric("as.hyperSpec", function(X, ...) { setMethod("as.hyperSpec", "matrix", .as.hyperSpec.matrix) .as.hyperSpec.data.frame <- function(X, spc = NULL, wl = NULL, - labels = attr(X, "labels"), ...) { - + labels = attr(X, "labels"), ...) { if (is.null(wl)) wl <- extract_numbers(X) # TODO: remove after 31.12.2020 if (!all(!is.na(extract_numbers(colnames(X))))) { @@ -110,8 +108,8 @@ hySpc.testthat::test(as.hyperSpec) <- function() { expect_equal(dim(tmp), c(nrow = 6L, ncol = 3L, nwl = 0L)) expect_equal(wl(tmp), numeric(0)) expect_equal( - labels(tmp) [order(names(labels(tmp)))], - lapply(labels(flu) [order(names(labels(flu)))], as.expression) + labels(tmp)[order(names(labels(tmp)))], + lapply(labels(flu)[order(names(labels(flu)))], as.expression) ) }) diff --git a/hyperSpec/R/barbiturates.R b/hyperSpec/R/barbiturates.R index 4c12e1ce..15e0df82 100644 --- a/hyperSpec/R/barbiturates.R +++ b/hyperSpec/R/barbiturates.R @@ -1,4 +1,4 @@ -#' Barbiturates Spectra from `.spc` Example Files +#' Barbiturates spectra from `.spc` example files #' #' A time series of mass spectra in a list of `hyperSpec` objects. #' diff --git a/hyperSpec/R/bind.R b/hyperSpec/R/bind.R index 8a9c12e1..a7bea2cd 100644 --- a/hyperSpec/R/bind.R +++ b/hyperSpec/R/bind.R @@ -1,4 +1,4 @@ -#' Binding `hyperSpec` Objects +#' Binding `hyperSpec` objects #' #' Functions to bind `hyperSpec` objects. #' diff --git a/hyperSpec/R/colMeans.R b/hyperSpec/R/colMeans.R index d0fc4820..a49d3221 100644 --- a/hyperSpec/R/colMeans.R +++ b/hyperSpec/R/colMeans.R @@ -1,4 +1,4 @@ -#' Functions `colSums()`, `colMeans()`, `rowSums()`, and `rowMeans()` for `hyperSpec` Objects +#' Functions `colSums()`, `colMeans()`, `rowSums()`, and `rowMeans()` for `hyperSpec` objects #' #' `hyperSpec` objects can use the base functions [base::colMeans()], #' [base::colSums()], [base::rowMeans()] and [base::rowSums()]. @@ -108,16 +108,14 @@ setMethod("rowSums", signature = signature(x = "hyperSpec"), .rowSums) # Unit tests ----------------------------------------------------------------- - hySpc.testthat::test(.colMeans) <- function() { - for (fun in c("colMeans", "colSums", "rowMeans", "rowSums")) { context(fun) f <- get(fun, mode = "function") test_that("basic operation", { expect_equal( as.numeric(f(flu)[[]]), - as.numeric(f(flu[[]], na.rm = TRUE)), + as.numeric(f(flu[[]], na.rm = TRUE)), label = fun ) }) @@ -137,4 +135,3 @@ hySpc.testthat::test(.colMeans) <- function() { }) } } - diff --git a/hyperSpec/R/collapse.R b/hyperSpec/R/collapse.R index 4dcfcb39..1a728581 100644 --- a/hyperSpec/R/collapse.R +++ b/hyperSpec/R/collapse.R @@ -1,4 +1,4 @@ -#' @title Collapse/Bind Several `hyperSpec` Objects into One Object +#' @title Collapse/bind several `hyperSpec` objects into one object #' @description #' The spectra from all objects will be put into one object. #' The resulting object has all wavelengths that occur in any of the input objects, @@ -42,8 +42,8 @@ #' @concept manipulation #' #' @examples -#' barbiturates [1:3] -#' collapse(barbiturates [1:3]) +#' barbiturates[1:3] +#' collapse(barbiturates[1:3]) #' #' a <- barbiturates[[1]] #' b <- barbiturates[[2]] @@ -54,7 +54,7 @@ #' c #' collapse(a, b, c) #' -#' collapse(barbiturates [1:3], collapse.equal = FALSE) +#' collapse(barbiturates[1:3], collapse.equal = FALSE) collapse <- function(..., wl.tolerance = hy.getOption("wl.tolerance"), collapse.equal = TRUE) { wl.tolerance <- .checkpos(wl.tolerance, "wl.tolerance") dots <- list(...) @@ -100,7 +100,7 @@ collapse <- function(..., wl.tolerance = hy.getOption("wl.tolerance"), collapse. ## prepare new labels labels <- unlist(lapply(dots, slot, "label")) - labels <- labels [unique(names(labels))] + labels <- labels[unique(names(labels))] labels <- lapply(labels, function(l) if (is.language(l)) l <- as.expression(l) else l) ## cluster wavelengths into groups of ± wl.tolerance from center @@ -109,7 +109,7 @@ collapse <- function(..., wl.tolerance = hy.getOption("wl.tolerance"), collapse. ## assign cluster number to columns # wl.df is ordered by wavelength, each object in dots is ordered by wavelength, so for (i in seq_along(dots)) { - colnames(dots[[i]]@data$spc) <- wl.df$wlcluster [wl.df$iobj == i] + colnames(dots[[i]]@data$spc) <- wl.df$wlcluster[wl.df$iobj == i] } ## now we're ready for the actual work of collapsing the objects @@ -118,13 +118,13 @@ collapse <- function(..., wl.tolerance = hy.getOption("wl.tolerance"), collapse. ## careful with constructing the wavelength vector: the columns in $spc are in no particular order, ## but the colnames indicate wavelength rank. ## so reorder $spc accor - dots$spc <- dots$spc [, order(as.numeric(colnames(dots$spc)))] + dots$spc <- dots$spc[, order(as.numeric(colnames(dots$spc)))] ## we now need summarized wl.df data: wl.df <- group_by(wl.df, .data$wlcluster) wl.df <- summarise(wl.df, wl = sum(.data$wl * .data$nspc) / sum(.data$nspc), # weighted average - old.wlnames = .data$old.wlnames [1L] + old.wlnames = .data$old.wlnames[1L] ) ## prepare wavelength vector & restore old names (as far as possible) @@ -142,11 +142,11 @@ hySpc.testthat::test(collapse) <- function() { context("collapse") test_that("correctly assembled", { - new <- do.call(collapse, barbiturates [1:3]) - wl <- unlist(lapply(barbiturates [1:3], slot, "wavelength")) + new <- do.call(collapse, barbiturates[1:3]) + wl <- unlist(lapply(barbiturates[1:3], slot, "wavelength")) expect_equal( wl(new), - sort(wl [!duplicated(wl)]) + sort(wl[!duplicated(wl)]) ) for (s in 1:3) { @@ -163,7 +163,7 @@ hySpc.testthat::test(collapse) <- function() { tmp <- collapse(flu, flu) expect_equal(labels(tmp, ".wavelength"), labels(flu, ".wavelength")) - tmp <- collapse(flu [, , min ~ 410], flu [, , 414 ~ 420]) + tmp <- collapse(flu[, , min ~ 410], flu[, , 414 ~ 420]) expect_equal(labels(tmp, ".wavelength"), labels(flu, ".wavelength")) }) @@ -172,14 +172,14 @@ hySpc.testthat::test(collapse) <- function() { expect_true(is.expression(labels(tmp)$.wavelength)) expect_true(is.expression(labels(tmp)$spc)) - tmp <- collapse(flu [, , min ~ 405], flu [, , 414 ~ 420]) + tmp <- collapse(flu[, , min ~ 405], flu[, , 414 ~ 420]) expect_true(is.expression(labels(tmp)$.wavelength)) expect_true(is.expression(labels(tmp)$spc)) }) test_that("collapse does not mess up labels if a named list is collapsed", { expect_equal( - labels(tmp) [names(labels(flu))], + labels(tmp)[names(labels(flu))], labels(flu) ) }) @@ -214,7 +214,7 @@ hySpc.testthat::test(collapse) <- function() { }) test_that("result has orded wavelengths", { - tmp <- collapse(barbiturates [1:3]) + tmp <- collapse(barbiturates[1:3]) expect_true(all(diff(wl(tmp)) >= 0)) }) @@ -258,9 +258,9 @@ hySpc.testthat::test(collapse) <- function() { test_that("factor behaviour of collapse", { - a <- faux_cell [faux_cell$region == "nucleus"] + a <- faux_cell[faux_cell$region == "nucleus"] a$region <- droplevels(a$region) - b <- faux_cell [faux_cell$region != "nucleus"] + b <- faux_cell[faux_cell$region != "nucleus"] b$region <- droplevels(b$region) tmp <- collapse(a, b) @@ -273,44 +273,44 @@ hySpc.testthat::test(collapse) <- function() { }) test_that("hyperSpec objects with 1 wavelength", { - expect_equivalent(collapse(flu [, , 450], flu [, , 450]), - flu [rep(1:nrow(flu), 2), , 450], + expect_equivalent(collapse(flu[, , 450], flu[, , 450]), + flu[rep(1:nrow(flu), 2), , 450], check.labels = TRUE ) - tmp <- flu [rep(1:nrow(flu), 2)] + tmp <- flu[rep(1:nrow(flu), 2)] tmp[[7:12]] <- NA tmp[[7:12, , 450]] <- flu[[, , 450]] - expect_equivalent(collapse(flu [, , 450], flu), + expect_equivalent(collapse(flu[, , 450], flu), tmp, check.labels = TRUE ) }) test_that("hyperSpec objects with 0 wavelengths", { - expect_equivalent(collapse(flu [, , FALSE], flu [, , FALSE]), - flu [rep(1:nrow(flu), 2), , FALSE], + expect_equivalent(collapse(flu[, , FALSE], flu[, , FALSE]), + flu[rep(1:nrow(flu), 2), , FALSE], check.labels = TRUE ) - tmp <- collapse(flu [, , FALSE], flu [, "spc", 405 ~ 406]) + tmp <- collapse(flu[, , FALSE], flu[, "spc", 405 ~ 406]) expect_equal(tmp$c, c(flu$c, rep(NA, nrow(flu)))) expect_equal(tmp$spc, rbind(flu[[, , 405 ~ 406]] + NA, flu[[, , 405 ~ 406]])) expect_equal(labels(tmp), lapply(labels(flu), as.expression)) }) test_that("hyperSpec objects with wavelength being/containing NA", { - expect_warning(collapse(flu [, , 0])) + expect_warning(collapse(flu[, , 0])) expect_equal( - suppressWarnings(collapse(flu [, , 0], flu)), - collapse(flu [, , FALSE], flu) + suppressWarnings(collapse(flu[, , 0], flu)), + collapse(flu[, , FALSE], flu) ) expect_equal( - suppressWarnings(collapse(flu [, , c(0, 405)], flu)), - collapse(flu [, , 405], flu) + suppressWarnings(collapse(flu[, , c(0, 405)], flu)), + collapse(flu[, , 405], flu) ) }) } @@ -324,7 +324,7 @@ hySpc.testthat::test(collapse) <- function() { if (any(isTRUE(i.warn))) { warning(sprintf( "object %i: wl.tolerance (%g) too large compared to smallest wavelength difference within object (%f). Columns will be lost.", - which(i.warn), wl.tolerance, wl.diff [i.warn] + which(i.warn), wl.tolerance, wl.diff[i.warn] )) } } @@ -337,7 +337,7 @@ hySpc.testthat::test(collapse) <- function() { "object %i: wavelength vector contains NAs: these columns will be dropped", which(i.NA) )) - dots [i.NA] <- lapply(dots [i.NA], function(x) x [, , !is.na(wl(x))]) + dots[i.NA] <- lapply(dots[i.NA], function(x) x[, , !is.na(wl(x))]) } dots @@ -379,15 +379,15 @@ hySpc.testthat::test(collapse) <- function() { } wl <- wl / n - dots[[i]]@data <- rbind.fill(lapply(dots [c(i, i + bind_directly)], slot, "data")) + dots[[i]]@data <- rbind.fill(lapply(dots[c(i, i + bind_directly)], slot, "data")) .wl(dots[[i]]) <- structure(wl, names = names(wl(dots[[i]]))) - labels <- unlist(lapply(dots [c(i, i + bind_directly)], labels)) + labels <- unlist(lapply(dots[c(i, i + bind_directly)], labels)) labels <- lapply(labels, function(l) if (is.language(l)) l <- as.expression(l) else l) - labels(dots[[i]]) <- labels [!duplicated(names(labels))] + labels(dots[[i]]) <- labels[!duplicated(names(labels))] - dots <- dots [-(i + bind_directly)] + dots <- dots[-(i + bind_directly)] } i <- i + 1 @@ -429,10 +429,10 @@ hySpc.testthat::test(collapse) <- function() { for (i in seq_along(dots)) { wln <- names(dots[[i]]@wavelength) - if (!is.null(wln)) wl.df$old.wlnames [wl.df$iobj == i] <- wln + if (!is.null(wln)) wl.df$old.wlnames[wl.df$iobj == i] <- wln } - wl.df <- wl.df [order(wl.df$wl), ] + wl.df <- wl.df[order(wl.df$wl), ] ## computational shortcut: ## wavelengths that are > 2 * wl.tolerance apart must be in different clusters, @@ -447,7 +447,7 @@ hySpc.testthat::test(collapse) <- function() { ## preliminary clusters may need to be split further for (i in seq_len(tail(wl.df$wlcluster, 1))) { - tmp <- wl.df [wl.df$wlcluster == i, ] + tmp <- wl.df[wl.df$wlcluster == i, ] ## only 1 wavelength in cluster => nothing to do if (length(tmp) <= 1L) { @@ -455,7 +455,7 @@ hySpc.testthat::test(collapse) <- function() { } ## all wavelengths within 2 * wl.tolerance => nothing to do - if (tail(tmp$wl, 1) - tmp$wl [1] <= 2 * wl.tolerance) { + if (tail(tmp$wl, 1) - tmp$wl[1] <= 2 * wl.tolerance) { next } @@ -476,7 +476,7 @@ hySpc.testthat::test(collapse) <- function() { tmp <- merge(tmp, u, by = "wl", suffixes = c(".prelim", "")) tmp$wlcluster.prelim <- NULL - wl.df$wlcluster [wl.df$wlcluster == i] <- tmp$wlcluster + wl.df$wlcluster[wl.df$wlcluster == i] <- tmp$wlcluster } ## cluster numbers so far are in no particular order => rename them so they correspond to increasing wavelengths diff --git a/hyperSpec/R/cov.R b/hyperSpec/R/cov.R index 29aa1f70..6bcaed57 100644 --- a/hyperSpec/R/cov.R +++ b/hyperSpec/R/cov.R @@ -1,4 +1,4 @@ -#' Covariance Matrices for `hyperSpec` Objects +#' Covariance matrices for `hyperSpec` objects #' #' #' @param x `hyperSpec` object @@ -15,12 +15,14 @@ #' #' @examples #' image(cov(faux_cell)) -setMethod("cov", signature = signature(x = "hyperSpec", y = "missing"), +setMethod("cov", + signature = signature(x = "hyperSpec", y = "missing"), function(x, y, use, method) { validObject(x) cov(x@data$spc, use = use, method = method) - }) + } +) #' @param ... ignored @@ -42,7 +44,7 @@ pooled.cov <- function(x, groups, ..., regularize = 1e-5 * max(abs(COV))) { stop("groups must be a factor") } - x <- x[!is.na(groups)] + x <- x[!is.na(groups)] groups <- groups[!is.na(groups)] means <- aggregate(x, groups, "mean") # TODO: speed up? diff --git a/hyperSpec/R/decomposition.R b/hyperSpec/R/decomposition.R index faaa026b..da59f2dd 100644 --- a/hyperSpec/R/decomposition.R +++ b/hyperSpec/R/decomposition.R @@ -1,4 +1,4 @@ -#' Convert Principal Component Decomposition or the Like into a `hyperSpec` Object +#' Convert principal component decomposition or the like into a `hyperSpec` object #' #' Decomposition of the spectra matrix is a common procedure in chemometric #' data analysis. `scores` and `loadings` convert the result matrices @@ -110,16 +110,16 @@ decomposition <- function(object, x, wavelength = seq_len(ncol(x)), cols <- rep(TRUE, ncol(object@data)) # columns to keep - for (i in seq_len(ncol(object@data)) [-spc]) { + for (i in seq_len(ncol(object@data))[-spc]) { tmp <- as.data.frame(lapply(object@data[, i, drop = FALSE], .na.if.different)) - object@data [1, i] <- tmp + object@data[1, i] <- tmp if (all(is.na(tmp))) { - cols [i] <- FALSE + cols[i] <- FALSE } } if (!retain.columns) { - object@label [colnames(object@data) [!cols]] <- NULL + object@label[colnames(object@data)[!cols]] <- NULL object@data <- object@data[, cols, drop = FALSE] } @@ -154,7 +154,7 @@ hySpc.testthat::test(decomposition) <- function() { flu$matrix <- cbind(flu$c, flu$c) expect_true(is.matrix(flu$matrix)) - tmp <- flu [, , 405 ~ 410] + tmp <- flu[, , 405 ~ 410] tmp@wavelength <- seq_len(nwl(tmp)) colnames(tmp@data$spc) <- seq_len(nwl(tmp)) @@ -173,7 +173,7 @@ hySpc.testthat::test(decomposition) <- function() { }) test_that("check loadings-like", { - tmp <- flu [1, c("spc"), ] + tmp <- flu[1, c("spc"), ] loadings <- decomposition(flu, flu[[1, , ]]) expect_equal(loadings, tmp) }) @@ -202,13 +202,13 @@ hySpc.testthat::test(decomposition) <- function() { # FIXME: these unit test below must be reviewed spc_empty <- new("hyperSpec", - wavelength = 1:5, - spc = matrix(NA, ncol = 5, nrow = 0)) + wavelength = 1:5, + spc = matrix(NA, ncol = 5, nrow = 0) + ) loading_matrix <- matrix(5:1, ncol = 5, nrow = 1) expect_error(decomposition(spc_empty, scores = TRUE)) expect_error(decomposition(spc_empty, scores = FALSE)) - }) } diff --git a/hyperSpec/R/dim.R b/hyperSpec/R/dim.R index dffd85b8..4128fbb8 100644 --- a/hyperSpec/R/dim.R +++ b/hyperSpec/R/dim.R @@ -1,5 +1,5 @@ -#' The Number of Rows (Spectra), Columns, and Data Points per Spectrum of a -#' `hyperSpec` Object +#' Number of rows (spectra), columns, and data points per spectrum of a +#' `hyperSpec` object #' #' These functions return the number of rows (spectra), columns, and/or #' data points per spectrum of a `hyperSpec` object. diff --git a/hyperSpec/R/dimnames.R b/hyperSpec/R/dimnames.R index a3970ccb..7fe5b6a3 100644 --- a/hyperSpec/R/dimnames.R +++ b/hyperSpec/R/dimnames.R @@ -1,4 +1,4 @@ -#' Dimnames for `hyperSpec` Objects +#' Dimnames for `hyperSpec` objects #' #' `hyperSpec` objects can have row- and column names like data.frames. #' The "names" of the wavelengths are treated separately: see [wl()]. diff --git a/hyperSpec/R/droplevels.R b/hyperSpec/R/droplevels.R index 43489fd7..9d318bb4 100644 --- a/hyperSpec/R/droplevels.R +++ b/hyperSpec/R/droplevels.R @@ -4,7 +4,7 @@ x } -#' Droplevels for `hyperSpec` Objects +#' Droplevels for `hyperSpec` objects #' #' Calls [base::droplevels()] on the data.frame in `spc@data`. #' @@ -20,7 +20,7 @@ #' #' @examples #' faux_cell[1:3]$region -#' droplevels(faux_cell [1:3])$region +#' droplevels(faux_cell[1:3])$region setMethod("droplevels", signature = "hyperSpec", definition = .droplevels) hySpc.testthat::test(.droplevels) <- function() { @@ -35,7 +35,7 @@ hySpc.testthat::test(.droplevels) <- function() { expect_equal(tmp@data, droplevels(faux_cell@data[1:3, ])) expect_equal( - tmp[, c("x", "y", "spc")], + tmp[, c("x", "y", "spc")], faux_cell[1:3, c("x", "y", "spc")] ) diff --git a/hyperSpec/R/empty.R b/hyperSpec/R/empty.R index 1fd93260..7d34cc70 100644 --- a/hyperSpec/R/empty.R +++ b/hyperSpec/R/empty.R @@ -1,4 +1,4 @@ -#' Empty `hyperSpec` Object +#' Empty `hyperSpec` object #' #' Empty produces an `hyperSpec` object with the same columns and wavelengths #' as `x`. The new object will either contain no rows at all (default), or the @@ -36,7 +36,6 @@ empty <- function(x, nrow = 0, spc = NA, extra = NA) { # Unit tests ----------------------------------------------------------------- hySpc.testthat::test(empty) <- function() { - context("empty") # Perform tests diff --git a/hyperSpec/R/expand.R b/hyperSpec/R/expand.R index 869865cf..6e1caecd 100644 --- a/hyperSpec/R/expand.R +++ b/hyperSpec/R/expand.R @@ -1,4 +1,4 @@ -#' Expand Scalar, Vector, Matrix or Similarly Shaped `hyperSpec` Objec to Matrix +#' Expand scalar, vector, matrix or similarly shaped `hyperSpec` object to matrix #' #' Helper function for `hyperSpec` arithmetics. #' diff --git a/hyperSpec/R/extract.R b/hyperSpec/R/extract.R index 5a572fa2..d4baa92f 100644 --- a/hyperSpec/R/extract.R +++ b/hyperSpec/R/extract.R @@ -168,7 +168,7 @@ #' ##### Access wavelengths using "l" (3rd index) #' #' dim(flu[[]]) -#' fluA <- flu[[, , 420~450]] # matches the wavelength values +#' fluA <- flu[[, , 420 ~ 450]] # matches the wavelength values #' dim(fluA) #' fluB <- flu[[, , 31:91, wl.index = TRUE]] #' identical(fluA, fluB) @@ -210,7 +210,6 @@ #' #' # indexing via a logical matrix (applied to spectra matrix) #' summary(flu[[flu < 125]]) -#' #' @export #' #' @concept manipulation @@ -272,11 +271,11 @@ setMethod("[[", } if (is.numeric(i) && !wl.index) { - i [, 2] <- .getindex(x, i [, 2], extrapolate = FALSE) + i[, 2] <- .getindex(x, i[, 2], extrapolate = FALSE) } x@data$spc[i] # return value - } else {# index by row and columns + } else { # index by row and columns x <- .extract(x, i, j, l, wl.index = wl.index) if (missing(j)) { unclass(x@data$spc[, , drop = drop]) diff --git a/hyperSpec/R/extract_numbers.R b/hyperSpec/R/extract_numbers.R index ace6b776..1886dacc 100644 --- a/hyperSpec/R/extract_numbers.R +++ b/hyperSpec/R/extract_numbers.R @@ -1,4 +1,4 @@ -#' Guess Wavelengths from Character Vector +#' Guess wavelengths from character vector #' #' character vectors used for names (e.g. colnames for matrices or data.frames) #' are often treated by [base::make.names()] or similar functions that diff --git a/hyperSpec/R/faux_cell.R b/hyperSpec/R/faux_cell.R index 72b64ecd..10070882 100644 --- a/hyperSpec/R/faux_cell.R +++ b/hyperSpec/R/faux_cell.R @@ -5,12 +5,12 @@ #' @aliases faux_cell generate_faux_cell #' @docType data #' -#' @title Faux Cell Data Set for Testing & Demonstration +#' @title Faux cell dataset for testing & demonstration #' #' @description #' This is a synthetic data set intended for testing and demonstration. #' Function `generate_faux_cell()` simulates the faux cell data (*note:* in -#' the future, it is planned to parameterize thefuncion) and object `faux_cell` +#' the future, it is planned to parameterize the funcion) and object `faux_cell` #' is an instance of this dataset generated first time it is used. #' #' The data set resembles the @@ -64,7 +64,6 @@ #' xlab = "PC 1", ylab = "PC 2", #' bg = mapcols[faux_cell$region], col = "black", pch = 21 #' ) - generate_faux_cell <- function() { # Check for points inside ellipse @@ -175,7 +174,6 @@ delayedAssign("faux_cell", generate_faux_cell()) # Unit tests ----------------------------------------------------------------- hySpc.testthat::test(generate_faux_cell) <- function() { - context("generate_faux_cell") # Perform tests @@ -189,4 +187,3 @@ hySpc.testthat::test(generate_faux_cell) <- function() { expect_identical(faux_cell_data, faux_cell_data_2) }) } - diff --git a/hyperSpec/R/flu.R b/hyperSpec/R/flu.R index 89b10a3c..accda55c 100644 --- a/hyperSpec/R/flu.R +++ b/hyperSpec/R/flu.R @@ -1,4 +1,4 @@ -#' Quinine Fluorescence Spectra +#' Quinine fluorescence spectra #' #' Fluorescence spectra of different dilutions of quinine forming a #' calibration set. diff --git a/hyperSpec/R/generate-test-data.R b/hyperSpec/R/generate-test-data.R index b2fe2bfe..eb7b5c43 100644 --- a/hyperSpec/R/generate-test-data.R +++ b/hyperSpec/R/generate-test-data.R @@ -2,7 +2,9 @@ # Generate spectroscopic data for testing and exploration -------------------- #' @name generate_test_data -#' @title Generate Spectroscopic Data +#' +#' @title Generate spectroscopic data +#' #' @description #' These functions generate hyper-spectral datasets that are mainly used for #' exploring and testing functionality of \pkg{hyperSpec}. diff --git a/hyperSpec/R/hy_attach.R b/hyperSpec/R/hy_attach.R index ac17b629..4918ad43 100644 --- a/hyperSpec/R/hy_attach.R +++ b/hyperSpec/R/hy_attach.R @@ -35,14 +35,12 @@ #' #' hyperSpec::hy_attach(quiet = TRUE) #' } - +#' hy_attach <- function(exclude = "hySpc.testthat", ..., quiet = NA) { - hySpc_installed <- hy_list_installed_hySpc_packages() hySpc_to_attach <- setdiff(hySpc_installed, unique(c(exclude, .packages()))) if (is.na(quiet) || isFALSE(quiet)) { - if (length(hySpc_to_attach) > 0) { message( "\n------------------------------------\n", @@ -68,8 +66,9 @@ hy_attach <- function(exclude = "hySpc.testthat", ..., quiet = NA) { out <- if (is.na(quiet) || isTRUE(quiet)) { - suppressPackageStartupMessages({attach_pkgs()}) - + suppressPackageStartupMessages({ + attach_pkgs() + }) } else { attach_pkgs() } @@ -86,25 +85,30 @@ hySpc.testthat::test(hy_attach) <- function() { # Check with hyperSpec package only installed_pkgs <- row.names(installed.packages()) - exclude_pkgs <- grep("^hySpc[.]", installed_pkgs, value = TRUE) + exclude_pkgs <- grep("^hySpc[.]", installed_pkgs, value = TRUE) # First check expect_silent(hyperSpec::hy_attach(exclude_pkgs, quiet = TRUE)) # quiet = NA - suppressWarnings({detach("package:hyperSpec", force = TRUE)}) + suppressWarnings({ + detach("package:hyperSpec", force = TRUE) + }) expect_message(hyperSpec::hy_attach(exclude_pkgs, quiet = NA), "hyperSpec") expect_message(hyperSpec::hy_attach(exclude_pkgs, quiet = NA), "are already attached") # quiet = TRUE - suppressWarnings({detach("package:hyperSpec", force = TRUE)}) + suppressWarnings({ + detach("package:hyperSpec", force = TRUE) + }) expect_silent(hyperSpec::hy_attach(exclude_pkgs, quiet = TRUE)) expect_silent(hyperSpec::hy_attach(exclude_pkgs, quiet = TRUE)) # quiet = FALSE - suppressWarnings({detach("package:hyperSpec", force = TRUE)}) + suppressWarnings({ + detach("package:hyperSpec", force = TRUE) + }) expect_message(hyperSpec::hy_attach(exclude_pkgs, quiet = FALSE), "To get started, try:") expect_message(hyperSpec::hy_attach(exclude_pkgs, quiet = FALSE), "are already attached") }) } - diff --git a/hyperSpec/R/hy_auto_completion.R b/hyperSpec/R/hy_auto_completion.R index 3fd848b0..9fb9e90e 100644 --- a/hyperSpec/R/hy_auto_completion.R +++ b/hyperSpec/R/hy_auto_completion.R @@ -1,4 +1,4 @@ -#' @title Command Line Completion for `$` +#' @title Command line completion for `$` #' @description #' Command line completion for `$`. #' This function is not intended to be used directly by users but provides diff --git a/hyperSpec/R/hy_deprecation-messages.R b/hyperSpec/R/hy_deprecation-messages.R index a3708901..b6c70d30 100644 --- a/hyperSpec/R/hy_deprecation-messages.R +++ b/hyperSpec/R/hy_deprecation-messages.R @@ -88,15 +88,15 @@ hySpc.testthat::test(deprecated_ggplot2) <- function() { context("Deprecation messages") test_that("Deprecation message is a warning", { - expect_warning(hySpc_deprecated(), "is deprecated") - expect_warning(deprecated_ggplot2(), "is deprecated") - expect_warning(deprecated_ggplot2(), "ggplot2") + expect_warning(hySpc_deprecated(), "is deprecated") + expect_warning(deprecated_ggplot2(), "is deprecated") + expect_warning(deprecated_ggplot2(), "ggplot2") expect_warning(deprecated_ggplot2("a"), "ggplot2") - expect_warning(deprecated_read_envi(), "ENVI") - expect_warning(deprecated_read_jdx(), "jdx") - expect_warning(deprecated_read_spc(), "spc") - expect_warning(deprecated_read_spe(), "spe") - expect_warning(deprecated_read_mat(), "mat") - expect_warning(deprecated_read_txt(), "txt") + expect_warning(deprecated_read_envi(), "ENVI") + expect_warning(deprecated_read_jdx(), "jdx") + expect_warning(deprecated_read_spc(), "spc") + expect_warning(deprecated_read_spe(), "spe") + expect_warning(deprecated_read_mat(), "mat") + expect_warning(deprecated_read_txt(), "txt") }) } diff --git a/hyperSpec/R/hy_list_available_hySpc_packages.R b/hyperSpec/R/hy_list_available_hySpc_packages.R index d9f0bb37..53cc203d 100644 --- a/hyperSpec/R/hy_list_available_hySpc_packages.R +++ b/hyperSpec/R/hy_list_available_hySpc_packages.R @@ -59,7 +59,6 @@ hySpc.testthat::test(hy_list_available_hySpc_packages) <- function() { context("hy_list_available_hySpc_packages") test_that("hy_list_available_hySpc_packages() works", { - testthat::skip_if_offline() # FIXME: The lines below should be fixed in the future diff --git a/hyperSpec/R/hy_list_installed_hySpc_packages.R b/hyperSpec/R/hy_list_installed_hySpc_packages.R index 24ae29ab..993daadf 100644 --- a/hyperSpec/R/hy_list_installed_hySpc_packages.R +++ b/hyperSpec/R/hy_list_installed_hySpc_packages.R @@ -16,7 +16,6 @@ #' #' @examples #' hy_list_installed_hySpc_packages() - hy_list_installed_hySpc_packages <- function() { installed_pkgs <- row.names(installed.packages()) c("hyperSpec", grep("^hySpc[.]", installed_pkgs, value = TRUE)) @@ -34,4 +33,3 @@ hySpc.testthat::test(hy_list_installed_hySpc_packages) <- function() { expect_true(all(c("hyperSpec", "hySpc.testthat") %in% pkgs)) }) } - diff --git a/hyperSpec/R/hy_options.R b/hyperSpec/R/hy_options.R index 56ace5e8..7917156b 100644 --- a/hyperSpec/R/hy_options.R +++ b/hyperSpec/R/hy_options.R @@ -11,7 +11,7 @@ ggplot.spc.nmax = 10 ) -#' Options for package \pkg{hyperSpec}. +#' Options for package \pkg{hyperSpec} #' #' Functions to access and set \pkg{hyperSpec}'s options. #' @@ -57,7 +57,7 @@ hy.getOptions <- function(...) { if (length(dots) == 0L) { .options } else { - .options [dots] + .options[dots] } } @@ -109,7 +109,7 @@ hy.setOptions <- function(...) { warning("options without name are discarded: ", which(!names)) } - opts <- modifyList(.options, new [names]) + opts <- modifyList(.options, new[names]) opts$tolerance <- .checkpos(opts$tolerance, "tolerance") opts$wl.tolerance <- .checkpos(opts$wl.tolerance, "wl.tolerance") diff --git a/hyperSpec/R/hyperspec-class.R b/hyperSpec/R/hyperspec-class.R index 5d4b84be..385e6ffd 100644 --- a/hyperSpec/R/hyperspec-class.R +++ b/hyperSpec/R/hyperspec-class.R @@ -33,7 +33,6 @@ #' #' @examples #' showClass("hyperSpec") -#' #' \dontrun{ #' vignette("hyperSpec") #' } diff --git a/hyperSpec/R/hyperspec-package.R b/hyperSpec/R/hyperspec-package.R index 9f056369..e006f325 100644 --- a/hyperSpec/R/hyperspec-package.R +++ b/hyperSpec/R/hyperspec-package.R @@ -1,5 +1,5 @@ #' @name hyperSpec-package -#' @title Package "hyperSpec": Interface for Hyperspectral Data Sets +#' @title Package "hyperSpec": interface for hyperspectral datasets #' @description #' This package gives an interface to handle hyperspectral data sets in R. #' Hyperspectral data are spatially or time-resolved spectra, or spectra with diff --git a/hyperSpec/R/initialize.R b/hyperSpec/R/initialize.R index 58fdfd49..f541d250 100644 --- a/hyperSpec/R/initialize.R +++ b/hyperSpec/R/initialize.R @@ -32,8 +32,7 @@ } if (is.null(spc) && is.null(data) && !is.null(wavelength) && - is.numeric(wavelength) && is.vector(wavelength)) { - + is.numeric(wavelength) && is.vector(wavelength)) { spc <- matrix(NA_real_, ncol = length(wavelength), nrow = 0) } @@ -147,7 +146,7 @@ .Object } -#' Create a `hyperSpec` Object +#' Create a `hyperSpec` object #' #' Like other S4 objects, a `hyperSpec` object can be created by [new()]. #' The `hyperSpec` object is then `initialize`d using the given parameters. @@ -356,9 +355,8 @@ hySpc.testthat::test(.initialize) <- function() { expect_equal(new_hyperSpec(), new("hyperSpec")) expect_equal(new_hyperSpec(spc = 1:4), new("hyperSpec", spc = 1:4)) expect_equal( - new_hyperSpec( spc = spc, data = data.frame(x = 11:13)), + new_hyperSpec(spc = spc, data = data.frame(x = 11:13)), new("hyperSpec", spc = spc, data = data.frame(x = 11:13)) ) }) } - diff --git a/hyperSpec/R/labels.R b/hyperSpec/R/labels.R index f9d08b5d..b49a8f60 100644 --- a/hyperSpec/R/labels.R +++ b/hyperSpec/R/labels.R @@ -16,9 +16,9 @@ ) label <- modifyList(label, object@label[!sapply(object@label, is.null)]) - label <- label [which] + label <- label[which] } else { - label <- object@label [which] + label <- object@label[which] } if (drop && length(label) == 1L) { @@ -33,7 +33,7 @@ hySpc.testthat::test(.labels) <- function() { context(".labels") .sort <- function(x) { - x [order(names(x))] + x[order(names(x))] } test_that( @@ -108,7 +108,7 @@ hySpc.testthat::test(.labels) <- function() { } -#' Get and Set Labels of a `hyperSpec` Object +#' Get and set labels of a `hyperSpec` object #' #' `value` may be a list or vector of labels giving the new label for #' each of the entries specified by `which`. diff --git a/hyperSpec/R/laser.R b/hyperSpec/R/laser.R index 2d09bb7b..e22773b2 100644 --- a/hyperSpec/R/laser.R +++ b/hyperSpec/R/laser.R @@ -1,4 +1,4 @@ -#' Laser Emission Dataset +#' Laser emission dataset #' #' A time series of an unstable laser emission. #' @@ -24,7 +24,7 @@ #' abline(v = wl[i], col = cols[i], lwd = 2, lty = 2) #' } #' -#' plotc(laser [, , wl], spc ~ t, +#' plotc(laser[, , wl], spc ~ t, #' groups = .wavelength, type = "b", #' col = cols #' ) diff --git a/hyperSpec/R/levelplot.R b/hyperSpec/R/levelplot.R index 52806527..1a93fc39 100644 --- a/hyperSpec/R/levelplot.R +++ b/hyperSpec/R/levelplot.R @@ -9,6 +9,7 @@ setGeneric("levelplot", package = "lattice") ### ### the workhorse function + #' @importFrom utils modifyList .levelplot <- function(x, data, transform.factor = TRUE, ..., contour = FALSE, useRaster = !contour) { @@ -19,7 +20,7 @@ setGeneric("levelplot", package = "lattice") ## parse formula to find the columns to be plotted ## they may include also "wavelength" parsed.formula <- latticeParseFormula(x, - as.long.df(data [1, , 1, wl.index = TRUE], rownames = TRUE), + as.long.df(data[1, , 1, wl.index = TRUE], rownames = TRUE), dimension = 3 ) use.x <- parsed.formula$right.x.name @@ -35,7 +36,7 @@ setGeneric("levelplot", package = "lattice") as.character(dots$groups), as.character(dots$subset) )))) { - data <- data [, , 1, wl.index = TRUE] + data <- data[, , 1, wl.index = TRUE] warning("Only first wavelength is used for plotting") } diff --git a/hyperSpec/R/makeraster.R b/hyperSpec/R/makeraster.R index 8307beb1..07df369f 100644 --- a/hyperSpec/R/makeraster.R +++ b/hyperSpec/R/makeraster.R @@ -1,4 +1,4 @@ -#' @title Find an evenly spaced grid for x. +#' @title Find an evenly spaced grid for x #' @description #' `makeraster()` fits the data to the specified raster. #' @@ -25,7 +25,7 @@ #' @author Claudia Beleites #' @examples #' x <- c(sample(1:20, 10), (0:5) + 0.5) -#' raster <- makeraster(x, x [1], 2) +#' raster <- makeraster(x, x[1], 2) #' raster #' plot(x) #' abline(h = raster$levels, col = "#00000040") @@ -36,13 +36,13 @@ #' #' ## points acutally on the raster #' onraster <- raster$x %in% raster$levels -#' points(which(onraster), raster$x [onraster], col = "blue", pch = 20) +#' points(which(onraster), raster$x[onraster], col = "blue", pch = 20) #' @importFrom utils tail makeraster <- function(x, startx, d, newlevels, tol = 0.1) { if (missing(newlevels)) { ## make sure to cover the whole data range + 1 point newlevels <- c( - rev(seq(startx, min(x, na.rm = TRUE) - d, by = -d) [-1]), + rev(seq(startx, min(x, na.rm = TRUE) - d, by = -d)[-1]), seq(startx, max(x, na.rm = TRUE) + d, by = d) ) } @@ -54,14 +54,14 @@ makeraster <- function(x, startx, d, newlevels, tol = 0.1) { wholenum <- abs(inew - rinew) < tol xnew <- x - xnew [wholenum] <- newlevels [rinew [wholenum]] + xnew[wholenum] <- newlevels[rinew[wholenum]] list( x = xnew, ## usually: drop outside levels 1 and length (newlevels) - levels = newlevels [min(rinew [wholenum]):max(rinew [wholenum])] + levels = newlevels[min(rinew[wholenum]):max(rinew[wholenum])] ) } @@ -83,7 +83,7 @@ makeraster <- function(x, startx, d, newlevels, tol = 0.1) { #' #' ## points acutally on the raster #' onraster <- raster$x %in% raster$levels -#' points(which(onraster), raster$x [onraster], col = "blue", pch = 20) +#' points(which(onraster), raster$x[onraster], col = "blue", pch = 20) #' #' x <- c(sample(1:20, 10), (0:5) + 0.45) #' raster <- fitraster(x) @@ -97,7 +97,7 @@ makeraster <- function(x, startx, d, newlevels, tol = 0.1) { #' #' ## points acutally on the raster #' onraster <- raster$x %in% raster$levels -#' points(which(onraster), raster$x [onraster], col = "blue", pch = 20) +#' points(which(onraster), raster$x[onraster], col = "blue", pch = 20) fitraster <- function(x, tol = 0.1) { levels <- sort(unique(x)) @@ -108,7 +108,7 @@ fitraster <- function(x, tol = 0.1) { dx <- sort(unique(diff(levels))) ## reduce by rounding? - dx <- c(dx [!diff(dx) < tol], tail(dx, 1)) + dx <- c(dx[!diff(dx) < tol], tail(dx, 1)) dx <- rev(dx) @@ -118,7 +118,7 @@ fitraster <- function(x, tol = 0.1) { totry <- order(x) while (length(totry) > 0L) { ## cat ("totry: ", totry, "\n") - startx <- x [totry [1]] + startx <- x[totry[1]] ## cat ("startx: ", startx, "\n") ## cat ("fit: ", c (startx, d), "\n") @@ -134,7 +134,7 @@ fitraster <- function(x, tol = 0.1) { break } - totry <- totry [!raster$x [totry] %in% raster$levels] + totry <- totry[!raster$x[totry] %in% raster$levels] } } diff --git a/hyperSpec/R/map_identify.R b/hyperSpec/R/map_identify.R index f5fc2895..615c58a5 100644 --- a/hyperSpec/R/map_identify.R +++ b/hyperSpec/R/map_identify.R @@ -36,7 +36,7 @@ map.identify <- function(object, model = spc ~ x * y, voronoi = FALSE, ..., ## complete rectangular maps. mix keeps track of the reordering. dots$mix <- FALSE mix <- sample(nrow(object)) - dots$object <- object [mix] + dots$object <- object[mix] lattice <- do.call(plotvoronoi, dots) mix <- order(mix) } else { @@ -48,8 +48,8 @@ map.identify <- function(object, model = spc ~ x * y, voronoi = FALSE, ..., trellis.focus() tol <- tol^2 - xn <- lattice$panel.args.common$x [mix] - yn <- lattice$panel.args.common$y [mix] + xn <- lattice$panel.args.common$x[mix] + yn <- lattice$panel.args.common$y[mix] x <- as.numeric(convertX(unit(xn, "native"), "npc")) y <- as.numeric(convertY(unit(yn, "native"), "npc")) @@ -67,12 +67,12 @@ map.identify <- function(object, model = spc ~ x * y, voronoi = FALSE, ..., } tmp <- as.numeric(tmp) - d2 <- (x - tmp [1])^2 + (y - tmp [2])^2 + d2 <- (x - tmp[1])^2 + (y - tmp[2])^2 pt <- which.min(d2) - if (d2 [pt] <= tol) { + if (d2[pt] <= tol) { res <- c(res, pt) if (debuglevel >= 1L) { - ltext(xn [pt], yn [pt], label = pt) + ltext(xn[pt], yn[pt], label = pt) } } else { if (warn) { diff --git a/hyperSpec/R/map_sel_poly.R b/hyperSpec/R/map_sel_poly.R index 33f45701..579d4f77 100644 --- a/hyperSpec/R/map_sel_poly.R +++ b/hyperSpec/R/map_sel_poly.R @@ -1,4 +1,4 @@ -#' Interactively select a polygon (grid graphics) and highlight points. +#' Interactively select a polygon (grid graphics) and highlight points #' #' Click the points that should be connected as polygon. Input ends with right click (see #' [grid::grid.locator()]). Polygon will be drawn closed. @@ -76,7 +76,7 @@ map.sel.poly <- function(data, pch = 19, size = 0.3, ...) { poly <- sel.poly(pch = pch, size = size, ...) - pts <- sp::point.in.polygon(x, y, poly [, 1], poly [, 2]) + pts <- sp::point.in.polygon(x, y, poly[, 1], poly[, 2]) ind <- pts > 0 @@ -116,24 +116,24 @@ sel.poly <- function(pch = 19, size = 0.3, ...) { pts <- rbind(pts, as.numeric(pt)) # comparably few executions: low performance doesn't matter ## display the clicked point - grid.points(unit(tail(pts [, 1], 1), "native"), - unit(tail(pts [, 2], 1), "native"), + grid.points(unit(tail(pts[, 1], 1), "native"), + unit(tail(pts[, 2], 1), "native"), pch = pch, size = unit(size, "char"), gp = gpar(...) ) ## connect last 2 points by line if (nrow(pts) > 1L) { - grid.lines(unit(tail(pts [, 1L], 2L), "native"), - unit(tail(pts [, 2L], 2L), "native"), + grid.lines(unit(tail(pts[, 1L], 2L), "native"), + unit(tail(pts[, 2L], 2L), "native"), gp = gpar(...) ) } } else { ## visually close polygon (if at least 3 pts) if (nrow(pts) > 2L) { - grid.lines(unit(c(tail(pts [, 1L], 1L), pts [1L, 1L]), "native"), - unit(c(tail(pts [, 2L], 1L), pts [1L, 2L]), "native"), + grid.lines(unit(c(tail(pts[, 1L], 1L), pts[1L, 1L]), "native"), + unit(c(tail(pts[, 2L], 1L), pts[1L, 2L]), "native"), gp = gpar(...) ) } diff --git a/hyperSpec/R/mark_dendrogram.R b/hyperSpec/R/mark_dendrogram.R index 255741e8..ee8080a3 100644 --- a/hyperSpec/R/mark_dendrogram.R +++ b/hyperSpec/R/mark_dendrogram.R @@ -1,4 +1,4 @@ -#' Groups are marked by colored rectangles as well as by their levels. +#' Groups are marked by colored rectangles as well as by their levels #' #' The dendrogram should be plotted separately, see the example. #' @title Mark groups in [stats::hclust()] dendrograms @@ -28,18 +28,18 @@ #' #' ## mark clusters #' clusters <- as.factor(cutree(dend, k = 4)) -#' levels(clusters) <- LETTERS [1:4] +#' levels(clusters) <- LETTERS[1:4] #' mark.dendrogram(dend, clusters, label = "cluster") #' #' ## mark independent factor -#' mark.dendrogram(dend, as.factor(laser [, , 405.36] > 11000), +#' mark.dendrogram(dend, as.factor(laser[, , 405.36] > 11000), #' pos.marker = -0.02, pos.text = -0.03 #' ) #' #' ## mark continuous variable: convert it to a factor and omit labels #' mark.dendrogram(dend, cut(laser[[, , 405.36]], 100), palette_alois(100), #' pos.marker = -.015, text.col = NA, -#' label = expression(I [lambda == 405.36 ~ nm]), label.right = FALSE +#' label = expression(I[lambda == 405.36 ~ nm]), label.right = FALSE #' ) #' @importFrom utils head tail mark.dendrogram <- function(dendrogram, groups, col = seq_along(unique(groups)), @@ -52,7 +52,7 @@ mark.dendrogram <- function(dendrogram, groups, col = seq_along(unique(groups)), groups <- as.factor(groups) } - groups.x <- groups [dendrogram$order] # clusters in order on x axis + groups.x <- groups[dendrogram$order] # clusters in order on x axis rle.groups <- rle(as.integer(groups.x)) # run-length encoding gives borders @@ -64,15 +64,15 @@ mark.dendrogram <- function(dendrogram, groups, col = seq_along(unique(groups)), for (g in seq_along(rle.groups$lengths)) { rect( - xleft = start [g], ybottom = pos.marker - height, - xright = end [g], ytop = pos.marker, - col = col [rle.groups$values[g]], border = border, ... + xleft = start[g], ybottom = pos.marker - height, + xright = end[g], ytop = pos.marker, + col = col[rle.groups$values[g]], border = border, ... ) - if (!is.na(text.col [g])) { + if (!is.na(text.col[g])) { text( - x = text [g], y = pos.text, - levels(groups) [rle.groups$values [g]], - col = text.col [rle.groups$values [g]], ... + x = text[g], y = pos.text, + levels(groups)[rle.groups$values[g]], + col = text.col[rle.groups$values[g]], ... ) } } diff --git a/hyperSpec/R/mark_peak.R b/hyperSpec/R/mark_peak.R index aaf368ed..bfbaba81 100644 --- a/hyperSpec/R/mark_peak.R +++ b/hyperSpec/R/mark_peak.R @@ -1,4 +1,4 @@ -#' Mark peak. +#' Mark peak #' #' Marks location of the *first* spectrum at the data point closest to the #' specified position on the current plot. diff --git a/hyperSpec/R/mean_sd.R b/hyperSpec/R/mean_sd.R index 95b820bf..cadb5731 100644 --- a/hyperSpec/R/mean_sd.R +++ b/hyperSpec/R/mean_sd.R @@ -1,10 +1,11 @@ ## make generic functions without default + #' @noRd setGeneric("mean_sd", function(x, na.rm = TRUE, ...) standardGeneric("mean_sd")) #' @noRd setGeneric("mean_pm_sd", function(x, na.rm = TRUE, ...) standardGeneric("mean_pm_sd")) -#' Mean and Standard Deviation. +#' Mean and standard deviation #' #' Calculate mean and standard deviation, and mean, mean \eqn{\pm}{+-} one #' standard deviation, respectively. diff --git a/hyperSpec/R/merge.R b/hyperSpec/R/merge.R index 2e77550d..a5fa30a9 100644 --- a/hyperSpec/R/merge.R +++ b/hyperSpec/R/merge.R @@ -1,4 +1,4 @@ -#' Merge `hyperSpec` objects. +#' Merge `hyperSpec` objects #' #' Merges two `hyperSpec` objects and [base::cbind()]s their spectra #' matrices, or merges additional extra data into a `hyperSpec` object. @@ -8,7 +8,8 @@ #' #' If the wavelength axis should be ordered, use [wl_sort()]. #' -#' If a `hyperSpec` object and a `data.frame` are merged, the result is of the class of the first (`x`) object. +#' If a `hyperSpec` object and a `data.frame` are merged, the result is of the +#' class of the first (`x`) object. #' #' @aliases merge,hyperSpec,hyperSpec-method merge #' @param x a `hyperSpec` object or data.frame @@ -30,8 +31,8 @@ #' @keywords manip #' @examples #' -#' merge(faux_cell [1:10, , 600], faux_cell [5:15, , 600], by = c("x", "y"))$. -#' tmp <- merge(faux_cell [1:10, , 610], faux_cell [5:15, , 610], +#' merge(faux_cell[1:10, , 600], faux_cell[5:15, , 600], by = c("x", "y"))$. +#' tmp <- merge(faux_cell[1:10, , 610], faux_cell[5:15, , 610], #' by = c("x", "y"), all = TRUE #' ) #' tmp$. @@ -45,7 +46,7 @@ #' )$y #' } #' -#' merged <- merge(faux_cell [1:7, , 610 ~ 620], faux_cell [5:10, , 615 ~ 625], all = TRUE) +#' merged <- merge(faux_cell[1:7, , 610 ~ 620], faux_cell[5:10, , 615 ~ 625], all = TRUE) #' merged$. #' merged <- apply(merged, 1, approxfun, #' wl = wl(merged), new.wl = unique(wl(merged)), @@ -102,13 +103,13 @@ setMethod("merge", x.spc <- match("spc", colnames(x)) y.spc <- match("spc", colnames(y)) - tmp <- merge(x@data [, -x.spc], y@data [, -y.spc], by.x = by.x, by.y = by.y, ...) + tmp <- merge(x@data[, -x.spc], y@data[, -y.spc], by.x = by.x, by.y = by.y, ...) spc.x <- matrix(NA, nrow = nrow(tmp), ncol = nwl(x)) - spc.x [!is.na(tmp$.nx), ] <- x@data [tmp$.nx[!is.na(tmp$.nx)], x.spc] + spc.x[!is.na(tmp$.nx), ] <- x@data[tmp$.nx[!is.na(tmp$.nx)], x.spc] spc.y <- matrix(NA, nrow = nrow(tmp), ncol = nwl(y)) - spc.y [!is.na(tmp$.ny), ] <- y@data [tmp$.ny[!is.na(tmp$.ny)], y.spc] + spc.y[!is.na(tmp$.ny), ] <- y@data[tmp$.ny[!is.na(tmp$.ny)], y.spc] tmp$spc <- cbind(spc.x, spc.y) # omit I () @@ -154,8 +155,8 @@ hySpc.testthat::test(.merge) <- function() { context("merge") test_that("correct number of rows", { - expect_equivalent(nrow(merge(faux_cell [1:10], faux_cell [5:15], all = TRUE)), 15) - expect_equivalent(nrow(merge(faux_cell [1:10], faux_cell [5:15])), 6) + expect_equivalent(nrow(merge(faux_cell[1:10], faux_cell[5:15], all = TRUE)), 15) + expect_equivalent(nrow(merge(faux_cell[1:10], faux_cell[5:15])), 6) }) test_that("merging hyperSpec object with data.frame", { @@ -170,20 +171,20 @@ hySpc.testthat::test(.merge) <- function() { expect_equivalent(sort(unique(c(colnames(flu), colnames(y)))), sort(colnames(tmp))) ## y has rows x does not have - tmp <- merge(flu [1:2], y) + tmp <- merge(flu[1:2], y) expect_equivalent(nrow(tmp), 4L) ## all.y = TRUE - tmp <- merge(flu [1:2], y, all.y = TRUE) + tmp <- merge(flu[1:2], y, all.y = TRUE) expect_equivalent(nrow(tmp), 12L) expect_equivalent(sum(is.na(tmp$c)), 8) ## x has rows y does not have - tmp <- merge(flu, y [1:2, ]) + tmp <- merge(flu, y[1:2, ]) expect_equivalent(nrow(tmp), 2L) ## all.x = TRUE - tmp <- merge(flu, y [c(1, 7), ], all.x = TRUE) + tmp <- merge(flu, y[c(1, 7), ], all.x = TRUE) expect_equivalent(nrow(tmp), 7L) expect_equivalent(sum(is.na(tmp$cpred)), 5) }) diff --git a/hyperSpec/R/mergeextra.R b/hyperSpec/R/mergeextra.R index 1962b186..2fc1ae85 100644 --- a/hyperSpec/R/mergeextra.R +++ b/hyperSpec/R/mergeextra.R @@ -18,7 +18,7 @@ #' @concept manipulation #' #' @examples -#' tmp <- flu [, FALSE, ] +#' tmp <- flu[, FALSE, ] #' tmp$prediction <- 1:6 #' tmp #' @@ -56,7 +56,7 @@ merge_data <- function(x, y) { } else if (colname %in% colnames(x)) { # y column needs to be renamed - colnames(y)[col] <- paste0(colnames(y) [col], ".y") + colnames(y)[col] <- paste0(colnames(y)[col], ".y") names(ylabels)[names(ylabels) == colname] <- paste0(names(ylabels)[names(ylabels) == colname], ".y") } diff --git a/hyperSpec/R/mvtnorm.R b/hyperSpec/R/mvtnorm.R index e5e79f8b..a0a74dcf 100644 --- a/hyperSpec/R/mvtnorm.R +++ b/hyperSpec/R/mvtnorm.R @@ -7,7 +7,7 @@ ## make indices so that pooled or individual covariance matrices can be used. if (length(dim(sigma)) == 3L) { - isigma <- seq_len(dim(sigma) [3]) + isigma <- seq_len(dim(sigma)[3]) } else { isigma <- rep(1L, nrow(mean)) dim(sigma) <- c(dim(sigma), 1L) @@ -15,7 +15,7 @@ tmp <- matrix(NA_real_, sum(n), ncol(mean)) for (i in seq_along(n)) { - tmp[.group == i, ] <- mvtnorm::rmvnorm(n [i], mean [i, ], sigma [, , isigma [i]]) + tmp[.group == i, ] <- mvtnorm::rmvnorm(n[i], mean[i, ], sigma[, , isigma[i]]) } attr(tmp, "group") <- .group @@ -28,7 +28,7 @@ setGeneric("rmmvnorm", .rmmvnorm) -#' Multivariate normal random numbers. +#' Multivariate normal random numbers #' #' Interface functions to use [mvtnorm::rmvnorm()] for #' [hyperSpec::hyperSpec-class()] objects. diff --git a/hyperSpec/R/normalize01.R b/hyperSpec/R/normalize01.R index 565a7535..467c6e8e 100644 --- a/hyperSpec/R/normalize01.R +++ b/hyperSpec/R/normalize01.R @@ -1,6 +1,6 @@ # @title normalization for mixed colors -#' Normalize numbers to interval \[0, 1\]. +#' Normalize numbers to interval \[0, 1\] #' #' The input `x` is mapped to \[0, 1\] by subtracting the minimum and #' subsequently dividing by the maximum. If all elements of `x` are equal, diff --git a/hyperSpec/R/palette_colorblind.R b/hyperSpec/R/palette_colorblind.R index 4222c08a..4a69234d 100644 --- a/hyperSpec/R/palette_colorblind.R +++ b/hyperSpec/R/palette_colorblind.R @@ -1,7 +1,7 @@ #' @name palette_colorblind #' @aliases palette_colorblind colors,palette_colorblind #' -#' @title Color Suggestions for `hyperSpec` Users +#' @title Color suggestions for `hyperSpec` users #' #' @description #' In \pkg{hyperSpec} the user may use any color name/format known to `R`. @@ -13,7 +13,7 @@ #' discussion of color issues can be found in the \pkg{colorspace} package. #' The [\pkg{Polychrome}](https://CRAN.R-project.org/package=Polychrome) #' package has further discussion and utilities for choosing qualitative -#' colorschemes, including those for color-blind individuals. +#' color schemes, including those for color-blind individuals. #' #' `palette_colorblind` is a selection of seven colors suitable for use on #' screens by people diff --git a/hyperSpec/R/palette_matlab.R b/hyperSpec/R/palette_matlab.R index 8bf9b929..800740e3 100644 --- a/hyperSpec/R/palette_matlab.R +++ b/hyperSpec/R/palette_matlab.R @@ -1,7 +1,7 @@ #' @rdname palettes #' @aliases palette_matlab colors,palette_matlab #' -#' @title Matlab-Like Color Palettes +#' @title Matlab-like color palettes #' #' @description #' Two palettes going from blue over green to red, approximately as the @@ -36,7 +36,6 @@ #' plot(flu, col = palette_matlab(nrow(flu))) #' #' plotmap(faux_cell[, , 1200], col.regions = palette_matlab()) -#' palette_matlab <- function(n = 100, ...) { rev(rainbow(n, start = 0, end = 4 / 6, ...)) } @@ -60,7 +59,6 @@ palette_matlab <- function(n = 100, ...) { #' plot(flu, col = palette_matlab_dark(nrow(flu))) #' #' plotmap(faux_cell[, , 1200], col.regions = palette_matlab_dark()) -#' palette_matlab_dark <- function(n = 100, ...) { pal <- rev(rainbow(n, start = 0, end = 4 / 6, ...)) pal <- col2rgb(pal) @@ -88,7 +86,6 @@ palette_matlab_dark <- function(n = 100, ...) { #' plot(flu, col = palette_alois(nrow(flu))) #' #' plotmap(faux_cell[, , 1200], col.regions = palette_alois()) -#' palette_alois <- function(n = 100, ...) { colorRampPalette(c("black", "blue", "cyan", "green", "yellow", "red"), ...)(n) } @@ -100,7 +97,8 @@ hySpc.testthat::test(palette_matlab) <- function() { test_that("palette_matlab() works", { pal <- palette_matlab() expect_true(pal[1] == "#0000FF" | pal[1] == "#0000FFFF") - expect_true(pal[2] == "#000AFF" | pal[2] == "#000AFFFF")}) + expect_true(pal[2] == "#000AFF" | pal[2] == "#000AFFFF") + }) } hySpc.testthat::test(palette_matlab_dark) <- function() { @@ -108,7 +106,8 @@ hySpc.testthat::test(palette_matlab_dark) <- function() { test_that("palette_matlab_dark() generates correct colors", { dark <- palette_matlab_dark() expect_equal(dark[1], "#0000FF") - expect_equal(dark[2], "#0005FF")}) + expect_equal(dark[2], "#0005FF") + }) } hySpc.testthat::test(palette_alois) <- function() { @@ -116,5 +115,6 @@ hySpc.testthat::test(palette_alois) <- function() { test_that("palette_alois() works", { alois <- palette_alois() expect_equal(alois[1], "#000000") - expect_equal(alois[2], "#00000C")}) + expect_equal(alois[2], "#00000C") + }) } diff --git a/hyperSpec/R/paracetamol.R b/hyperSpec/R/paracetamol.R index 9c4ad5ca..3ffdabd4 100644 --- a/hyperSpec/R/paracetamol.R +++ b/hyperSpec/R/paracetamol.R @@ -1,8 +1,7 @@ -#' Paracetamol Spectrum. +#' Paracetamol spectrum #' #' A Raman spectrum of a paracetamol tablet. #' -#' #' @name paracetamol #' @docType data #' @format The spectrum was acquired with a Renishaw InVia spectrometer from diff --git a/hyperSpec/R/paste_row.R b/hyperSpec/R/paste_row.R index 4a8b076a..93fa57aa 100644 --- a/hyperSpec/R/paste_row.R +++ b/hyperSpec/R/paste_row.R @@ -29,8 +29,8 @@ } if (length(x) > max.print) { - from <- format(head(x, shorten.to [1]), digits = digits, trim = TRUE) - to <- format(tail(x, shorten.to [2]), digits = digits, trim = TRUE) + from <- format(head(x, shorten.to[1]), digits = digits, trim = TRUE) + to <- format(tail(x, shorten.to[2]), digits = digits, trim = TRUE) text <- paste(paste(from, collapse = " "), "...", paste(to, collapse = " "), text, @@ -65,7 +65,7 @@ if (is.array(x) & all(class(x) != "array") & all(class(x) != "matrix")) { " array x " }, - paste(dim(x) [-1], collapse = " x "), + paste(dim(x)[-1], collapse = " x "), sep = "" ) }, diff --git a/hyperSpec/R/pearson_dist.R b/hyperSpec/R/pearson_dist.R index 2325de28..8632ab99 100644 --- a/hyperSpec/R/pearson_dist.R +++ b/hyperSpec/R/pearson_dist.R @@ -1,10 +1,10 @@ -#' Distance based on Pearson's \eqn{R^2}{R squared}. +#' Distance based on Pearson's \eqn{R^2}{R squared} #' #' The calculated distance is #' \eqn{D^2 = \frac{1 - COR (`x`')}{2}}{D^2 = (1 - COR (x')) / 2} #' #' The distance between the rows of `x` is calculated. The possible -#' values range from 0 (prefectly correlated) over 0.5 (uncorrelated) to 1 +#' values range from 0 (perfectly correlated) over 0.5 (uncorrelated) to 1 #' (perfectly anti-correlated). #' #' @param x a matrix @@ -56,7 +56,7 @@ hySpc.testthat::test(pearson.dist) <- function() { ## benchmark # function (){ # m <- sample (faux_cell, 10000)[[]] -# microbenchmark ( +# microbenchmark( # cor = as.dist (0.5 - cor (t (as.matrix (m))) / 2), # tcross = pearson.dist (m), # times = 10L diff --git a/hyperSpec/R/plot.R b/hyperSpec/R/plot.R index 66b2298a..ca4de0e2 100644 --- a/hyperSpec/R/plot.R +++ b/hyperSpec/R/plot.R @@ -28,9 +28,7 @@ } switch(tolower(y), - spc = plotspc(x, ...), - spcmeansd = { dots <- modifyList( list(object = mean_pm_sd(x), fill = c(1, NA, 1)), @@ -39,7 +37,6 @@ do.call(plotspc, dots) }, - spcprctile = { dots <- modifyList( list(object = quantile(x, probs = c(0.16, 0.5, 0.84)), fill = c(1, NA, 1)), @@ -48,29 +45,23 @@ do.call(plotspc, dots) }, - spcprctl5 = { dots <- modifyList( - list(object = quantile(x, probs = c(0.05, 0.16, 0.5, 0.84, 0.95)), - fill = c(1, 2, 3, 2, 1), fill.col = c("#00000040")), + list( + object = quantile(x, probs = c(0.05, 0.16, 0.5, 0.84, 0.95)), + fill = c(1, 2, 3, 2, 1), fill.col = c("#00000040") + ), dots ) do.call(plotspc, dots) }, - map = plotmap(x, ...), - voronoi = plotvoronoi(x, ...), - mat = plotmat(x, ...), - c = plotc(x, ...), - ts = plotc(x, spc ~ t, ...), - depth = plotc(x, spc ~ z, ...), - stop(paste("y = ", y, "unknown.", collapse = " ")) ) } @@ -188,19 +179,19 @@ hySpc.testthat::test(.plot) <- function() { # Data ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ expect_silent(hy_spectra <- generate_hy_spectra()) expect_silent(hy_profile <- generate_hy_profile()) - expect_silent(hy_map <- generate_hy_map()) + expect_silent(hy_map <- generate_hy_map()) # Regular tests: warnings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ expect_warning(plot(hy_spectra, "ts"), "Intensity at first wavelengh only is used.") - expect_warning(plot(hy_spectra, "c"), "Intensity at first wavelengh only is used.") + expect_warning(plot(hy_spectra, "c"), "Intensity at first wavelengh only is used.") # Regular tests: errors ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ expect_error(plot(hy_spectra, "depth"), "object 'z' not found") - expect_error(plot(hy_spectra[0, ]), "No spectra.") + expect_error(plot(hy_spectra[0, ]), "No spectra.") expect_error(plot(hy_spectra, xoffset = "a"), "xoffset must be a numeric") expect_error(plot(hy_spectra, func = "a"), "func needs to be a function") - expect_error(plot(hy_spectra, "???"), '??? unknown') + expect_error(plot(hy_spectra, "???"), "??? unknown") expect_error(plot(hy_spectra, contour = TRUE)) }) @@ -211,14 +202,14 @@ hySpc.testthat::test(.plot) <- function() { # Data ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ expect_silent(hy_spectra <- generate_hy_spectra()) expect_silent(hy_profile <- generate_hy_profile()) - expect_silent(hy_map <- generate_hy_map()) + expect_silent(hy_map <- generate_hy_map()) # Preparation ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - plot_c <- plot(hy_profile, "c") - plot_ts <- plot(hy_profile, "ts") - plot_depth <- plot(hy_profile, "depth") + plot_c <- plot(hy_profile, "c") + plot_ts <- plot(hy_profile, "ts") + plot_depth <- plot(hy_profile, "depth") - plot_map <- plot(hy_map, "map") + plot_map <- plot(hy_map, "map") plot_voronoi <- plot(hy_map, "voronoi") # Perform tests ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -232,9 +223,9 @@ hySpc.testthat::test(.plot) <- function() { expect_silent(plot_voronoi) # Visual tests - vdiffr::expect_doppelganger("plot-c", plot_c) - vdiffr::expect_doppelganger("plot-ts", plot_ts) - vdiffr::expect_doppelganger("plot-depth", plot_depth) + vdiffr::expect_doppelganger("plot-c", plot_c) + vdiffr::expect_doppelganger("plot-ts", plot_ts) + vdiffr::expect_doppelganger("plot-depth", plot_depth) # Skip if R < 4.0.0 (due to different defaults) @@ -244,7 +235,7 @@ hySpc.testthat::test(.plot) <- function() { skip_if(r_version < "4.0.0", "R version is < 4.0.0") - vdiffr::expect_doppelganger("plot-map", plot_map) + vdiffr::expect_doppelganger("plot-map", plot_map) vdiffr::expect_doppelganger("plot-voronoi", plot_voronoi) }) @@ -255,20 +246,20 @@ hySpc.testthat::test(.plot) <- function() { # Data ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ expect_silent(hy_spectra <- generate_hy_spectra()) expect_silent(hy_profile <- generate_hy_profile()) - expect_silent(hy_map <- generate_hy_map()) + expect_silent(hy_map <- generate_hy_map()) # Preparation ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - plot_1 <- function() plot(hy_spectra) - plot_spc <- function() plot(hy_spectra, "spc") - plot_spcmeansd <- function() plot(hy_spectra, "spcmeansd") - plot_spcprctile <- function() plot(hy_spectra, "spcprctile") - plot_spcprctl5 <- function() plot(hy_spectra, "spcprctl5") - plot_mat <- function() plot(hy_spectra, "mat") + plot_1 <- function() plot(hy_spectra) + plot_spc <- function() plot(hy_spectra, "spc") + plot_spcmeansd <- function() plot(hy_spectra, "spcmeansd") + plot_spcprctile <- function() plot(hy_spectra, "spcprctile") + plot_spcprctl5 <- function() plot(hy_spectra, "spcprctl5") + plot_mat <- function() plot(hy_spectra, "mat") plot_mat_contour <- function() plot(hy_spectra, "mat", contour = TRUE) - plot_1_rev <- function() plot(hy_spectra, wl.reverse = TRUE) - plot_1_fill <- function() plot(hy_spectra, fill = TRUE) + plot_1_rev <- function() plot(hy_spectra, wl.reverse = TRUE) + plot_1_fill <- function() plot(hy_spectra, fill = TRUE) # Perform tests ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -285,13 +276,13 @@ hySpc.testthat::test(.plot) <- function() { expect_silent(plot_mat_contour()) # Visual tests - vdiffr::expect_doppelganger("plot", plot_1) - vdiffr::expect_doppelganger("plot-spc", plot_spc) - vdiffr::expect_doppelganger("plot-spcmeansd", plot_spcmeansd) - vdiffr::expect_doppelganger("plot-spcprctile", plot_spcprctile) - vdiffr::expect_doppelganger("plot-spcprctl5", plot_spcprctl5) - vdiffr::expect_doppelganger("plot_1_rev", plot_1_rev) - vdiffr::expect_doppelganger("plot_1_fill", plot_1_fill) + vdiffr::expect_doppelganger("plot", plot_1) + vdiffr::expect_doppelganger("plot-spc", plot_spc) + vdiffr::expect_doppelganger("plot-spcmeansd", plot_spcmeansd) + vdiffr::expect_doppelganger("plot-spcprctile", plot_spcprctile) + vdiffr::expect_doppelganger("plot-spcprctl5", plot_spcprctl5) + vdiffr::expect_doppelganger("plot_1_rev", plot_1_rev) + vdiffr::expect_doppelganger("plot_1_fill", plot_1_fill) # These tests are skipped on CI systems, as they fail on R devel. @@ -300,10 +291,7 @@ hySpc.testthat::test(.plot) <- function() { "Failures on devel version of R" ) - vdiffr::expect_doppelganger("plot-mat", plot_mat) + vdiffr::expect_doppelganger("plot-mat", plot_mat) vdiffr::expect_doppelganger("plot-mat-contour", plot_mat_contour) - }) } - - diff --git a/hyperSpec/R/plotc.R b/hyperSpec/R/plotc.R index 7a0276a2..5e0987dd 100644 --- a/hyperSpec/R/plotc.R +++ b/hyperSpec/R/plotc.R @@ -6,7 +6,7 @@ -#' Calibration Plots, Timeseries Plots, and Depth-Profiles. +#' Calibration plots, timeseries plots, and depth-profiles #' #' Calibration- and timeseries plots, depth-profiles and the like #' `plotc` plots intensities of a `hyperSpec` object over another @@ -54,12 +54,12 @@ #' plotc(flu, func = mean) #' plotc(flu, func = range, groups = .wavelength) #' -#' plotc(flu[, , 450], ylab = expression(I ["450 nm"] / a.u.)) +#' plotc(flu[, , 450], ylab = expression(I["450 nm"] / a.u.)) #' #' #' calibration <- lm(spc ~ c, data = flu[, , 450]$.) #' summary(calibration) -#' plotc(flu [, , 450], type = c("p", "r")) +#' plotc(flu[, , 450], type = c("p", "r")) #' #' conc <- list(c = seq(from = 0.04, to = 0.31, by = 0.01)) #' ci <- predict(calibration, newdata = conc, interval = "confidence", level = 0.999) @@ -72,9 +72,9 @@ #' panel.lines(conc, ci.upr, col = ci.col) #' } #' -#' plotc(flu [, , 450], +#' plotc(flu[, , 450], #' panel = panel.ci, -#' conc = conc$c, ci.lwr = ci [, 2], ci.upr = ci [, 3] +#' conc = conc$c, ci.lwr = ci[, 2], ci.upr = ci[, 3] #' ) #' #' ## example 2: time-trace of laser emission modes @@ -86,7 +86,7 @@ #' abline(v = wl[i], col = cols[i], lwd = 2) #' } #' -#' plotc(laser [, , wl], spc ~ t, +#' plotc(laser[, , wl], spc ~ t, #' groups = .wavelength, type = "b", #' col = cols #' ) @@ -110,7 +110,7 @@ plotc <- function(object, model = spc ~ c, groups = NULL, ## find out whether the wavelengths are needed individually, ## if not, use only the first wavelength and issue a warning parsed.formula <- latticeParseFormula(model, - as.long.df(object [1, , 1, wl.index = TRUE], rownames = TRUE), + as.long.df(object[1, , 1, wl.index = TRUE], rownames = TRUE), groups = groups, dimension = 2 ) @@ -123,7 +123,7 @@ plotc <- function(object, model = spc ~ c, groups = NULL, as.character(groups), as.character(dots$subset) )))) { - object <- object [, , 1, wl.index = TRUE] + object <- object[, , 1, wl.index = TRUE] warning("Intensity at first wavelengh only is used.") } diff --git a/hyperSpec/R/plotmap.R b/hyperSpec/R/plotmap.R index 379cc3ab..d0d32fa3 100644 --- a/hyperSpec/R/plotmap.R +++ b/hyperSpec/R/plotmap.R @@ -4,11 +4,11 @@ ### ### plots intensity or extra data column over 2 extra data columns -## TODO: check wheter func should be applied or not +## TODO: check whether function should be applied or not -#' Plot a Map and Identify/Select Spectra in the Map. +#' Plot a map and identify/select spectra in the map #' #' [lattice::levelplot()] functions for hyperSpec objects. An image or map of a summary #' value of each spectrum is plotted. Spectra may be identified by mouse click. @@ -80,7 +80,6 @@ #' @concept plot generation #' #' @examples -#' #' \dontrun{ #' vignette(plotting) #' vignette(hyperSpec) diff --git a/hyperSpec/R/plotmat.R b/hyperSpec/R/plotmat.R index 7aa3e4b3..ab084b5b 100644 --- a/hyperSpec/R/plotmat.R +++ b/hyperSpec/R/plotmat.R @@ -1,4 +1,4 @@ -#' Plot spectra matrix. +#' Plot spectra matrix #' #' Plots the spectra matrix. #' @@ -72,9 +72,9 @@ plotmat <- function(object, y = ".row", ylab, col = palette_alois(20), ..., do.call("contour", dots) } else { ## leave at least 4 lines right margin - mar <- par()$ mar - if (mar [4] < 5) { - par(mar = c(mar [1:3], 5)) + mar <- par()$mar + if (mar[4] < 5) { + par(mar = c(mar[1:3], 5)) } do.call("image", dots) @@ -84,12 +84,12 @@ plotmat <- function(object, y = ".row", ylab, col = palette_alois(20), ..., if (requireNamespace("plotrix", quietly = TRUE)) { usr <- par()$usr - dx <- diff(usr [1:2]) + dx <- diff(usr[1:2]) - plotrix::color.legend(usr [2] + 0.05 * dx, - usr [3], - usr [2] + 0.10 * dx, - usr [4], + plotrix::color.legend(usr[2] + 0.05 * dx, + usr[3], + usr[2] + 0.10 * dx, + usr[4], pretty(range(object, na.rm = TRUE)), col, align = "rb", gradient = "y" @@ -112,5 +112,5 @@ hySpc.testthat::test(plotmat) <- function() { expect_silent(plotmat(tmp)) }) - ## TODO vdiffr + ## TODO: vdiffr } diff --git a/hyperSpec/R/plotspc.R b/hyperSpec/R/plotspc.R index 7440ec5f..8bad89b6 100644 --- a/hyperSpec/R/plotspc.R +++ b/hyperSpec/R/plotspc.R @@ -7,7 +7,7 @@ -#' Plotting Spectra. +#' Plotting spectra #' #' Plot the spectra of a `hyperSpec` object, i.e. intensity over #' wavelength. Instead of the intensity values of the spectra matrix summary @@ -133,18 +133,18 @@ #' plotspc(flu) #' #' ## artificial example to show wavelength axis cutting -#' plotspc(faux_cell [sample(nrow(faux_cell), 50)], +#' plotspc(faux_cell[sample(nrow(faux_cell), 50)], #' wl.range = list(600 ~ 650, 1000 ~ 1100, 1600 ~ 1700), #' xoffset = c(0, 300, 450) #' ) #' -#' plotspc(faux_cell [sample(nrow(faux_cell), 50)], +#' plotspc(faux_cell[sample(nrow(faux_cell), 50)], #' wl.range = list(600 ~ 650, 1000 ~ 1100, 1600 ~ 1700), #' xoffset = c(300, 450) #' ) #' #' ## some journals publish Raman spectra backwards -#' plotspc(faux_cell [sample(nrow(faux_cell), 50)], wl.reverse = TRUE) +#' plotspc(faux_cell[sample(nrow(faux_cell), 50)], wl.reverse = TRUE) #' #' plotspc(laser[(0:4) * 20 + 1, , ], stacked = TRUE) #' @@ -207,7 +207,7 @@ plotspc <- function(object, if (!wl.index) { wl.range <- wl2i(object, wl.range, unlist = FALSE) - wl.range <- lapply(wl.range, function(r) r [!is.na(r)]) + wl.range <- lapply(wl.range, function(r) r[!is.na(r)]) } ## xoffset ........................................................................................ @@ -232,7 +232,7 @@ plotspc <- function(object, u.wl.range <- unlist(wl.range) ## wavelengths are the numbers to print at the x axis - wavelengths <- relist(object@wavelength [u.wl.range], wl.range) + wavelengths <- relist(object@wavelength[u.wl.range], wl.range) ## x are the actual x coordinates x <- wavelengths @@ -271,7 +271,7 @@ plotspc <- function(object, message("Number of spectra exceeds spc.nmax. Only the first", spc.nmax, "are plotted.") } - spc <- spc [seq_len(spc.nmax), , drop = FALSE] + spc <- spc[seq_len(spc.nmax), , drop = FALSE] } ## stacked plot @@ -287,9 +287,9 @@ plotspc <- function(object, stacked <- do.call(stacked.offsets, stacked.args) if (all(yoffset == 0)) { - yoffset <- stacked$offsets [stacked$groups] + yoffset <- stacked$offsets[stacked$groups] } else if (length(yoffset) == length(unique(stacked$groups))) { - yoffset <- yoffset [stacked$groups] + yoffset <- yoffset[stacked$groups] } } @@ -300,7 +300,7 @@ plotspc <- function(object, if (length(yoffset) == 1) { yoffset <- rep(yoffset, nrow(spc)) } else if (length(yoffset) > nrow(spc)) { - yoffset <- yoffset [seq_len(nrow(spc))] + yoffset <- yoffset[seq_len(nrow(spc))] } else { stop("yoffset must be single number or one number for each spectrum (or stacking group).") } @@ -355,7 +355,7 @@ plotspc <- function(object, cuts <- .cut.ticks(sapply(wavelengths, min), sapply(wavelengths, max), xoffset, nxticks) axis.args$x <- modifyList( - axis.args [!names(axis.args) %in% c("x", "y")], + axis.args[!names(axis.args) %in% c("x", "y")], axis.args$x ) if (is.null(axis.args$x$labels) & !is.null(axis.args$x$at)) { @@ -390,7 +390,7 @@ plotspc <- function(object, ## y-axis labels & ticks if (bty %in% c("o", "l", "c", "u", "y")) { axis.args$y <- modifyList( - axis.args [!names(axis.args) %in% c("x", "y", "main", "sub")], + axis.args[!names(axis.args) %in% c("x", "y", "main", "sub")], axis.args$y ) @@ -405,7 +405,7 @@ plotspc <- function(object, axis.args$y <- modifyList( list( at = stacked$offsets, - labels = stacked$levels [!duplicated(stacked$levels)] + labels = stacked$levels[!duplicated(stacked$levels)] ), axis.args$y ) @@ -418,21 +418,21 @@ plotspc <- function(object, ## Title: axis labels --------------------------------------------------------------------------- - tmp <- title.args [!names(title.args) %in% c("x", "y", "ylab", "main", "sub")] + tmp <- title.args[!names(title.args) %in% c("x", "y", "ylab", "main", "sub")] tmp <- modifyList(tmp, as.list(title.args$x)) tmp <- modifyList(list(xlab = object@label$.wavelength, line = 2.5), tmp) do.call(title, tmp) tmp$xlab <- NULL - tmp <- title.args [!names(title.args) %in% c("x", "y", "xlab", "main", "sub")] + tmp <- title.args[!names(title.args) %in% c("x", "y", "xlab", "main", "sub")] tmp <- modifyList(tmp, as.list(title.args$y)) tmp <- modifyList(list(ylab = object@label$spc), tmp) do.call(title, tmp) tmp$ylab <- NULL - tmp <- title.args [!names(title.args) %in% c("x", "y", "xlab", "ylab")] - tmp <- modifyList(tmp, as.list(title.args [c("main", "sub")])) + tmp <- title.args[!names(title.args) %in% c("x", "y", "xlab", "ylab")] + tmp <- modifyList(tmp, as.list(title.args[c("main", "sub")])) do.call(title, tmp) } @@ -473,7 +473,7 @@ plotspc <- function(object, } groups <- unique(fill) - groups <- groups [!is.na(groups)] + groups <- groups[!is.na(groups)] polygon.args <- modifyList( @@ -486,8 +486,8 @@ plotspc <- function(object, fill.col <- character(length(groups)) for (j in seq_along(groups)) { - tmp <- which(fill == groups [j]) - fill.col [j] <- rgb(t(col2rgb(col [tmp[1]]) / 255) / 3 + 2 / 3) + tmp <- which(fill == groups[j]) + fill.col[j] <- rgb(t(col2rgb(col[tmp[1]]) / 255) / 3 + 2 / 3) } } else { fill.col <- rep(fill.col, length.out = length(groups)) @@ -498,10 +498,10 @@ plotspc <- function(object, polygon.args$x <- c(x[[i]], rev(x[[i]])) for (j in seq_along(groups)) { - tmp <- which(fill == groups [j]) - polygon.args$y <- c(spc[head(tmp, 1), ispc[[i]]], rev(spc [tail(tmp, 1), ispc[[i]]])) - polygon.args$col <- fill.col [groups [j]] - polygon.args$border <- border [groups [j]] + tmp <- which(fill == groups[j]) + polygon.args$y <- c(spc[head(tmp, 1), ispc[[i]]], rev(spc[tail(tmp, 1), ispc[[i]]])) + polygon.args$col <- fill.col[groups[j]] + polygon.args$border <- border[groups[j]] do.call(polygon, polygon.args) } @@ -514,26 +514,26 @@ plotspc <- function(object, if (lines.args$type == "h" && is.list(stacked)) { ## specialty: lines from the stacked zero line on! for (j in seq_len(nrow(spc))) { - keep <- !is.na(spc [j, ispc[[i]]]) - lines.args$x <- rep(x[[i]] [keep], each = 3) + keep <- !is.na(spc[j, ispc[[i]]]) + lines.args$x <- rep(x[[i]][keep], each = 3) lines.args$y <- as.numeric(matrix(c( - rep(yoffset [j], sum(keep)), - spc [j, ispc[[i]]] [keep], + rep(yoffset[j], sum(keep)), + spc[j, ispc[[i]]][keep], rep(NA, sum(keep)) ), byrow = TRUE, nrow = 3 )) lines.args$type <- "l" - lines.args$col <- col [j] + lines.args$col <- col[j] do.call(lines, lines.args) } } else { for (j in seq_len(nrow(spc))) { - keep <- !is.na(spc [j, ispc[[i]]]) + keep <- !is.na(spc[j, ispc[[i]]]) lines.args$x <- x[[i]][keep] - lines.args$y <- spc [j, ispc[[i]]] [keep] - lines.args$col <- col [j] + lines.args$y <- spc[j, ispc[[i]]][keep] + lines.args$col <- col[j] do.call(lines, lines.args) } @@ -591,7 +591,7 @@ plotspc <- function(object, #' lines.args = list(lty = 2, lwd = 2), add = TRUE #' ) #' -#' barb <- do.call(collapse, barbiturates [1:3]) +#' barb <- do.call(collapse, barbiturates[1:3]) #' plot(barb, #' lines.args = list(type = "h"), stacked = TRUE, #' stacked.args = list(add.factor = .2) @@ -633,23 +633,23 @@ stacked.offsets <- function(x, stacked = TRUE, offset <- matrix(nrow = 2, ncol = length(groups)) for (i in groups) { - offset[, i] <- range(.spc [stacked == groups [i], ], na.rm = TRUE) + offset[, i] <- range(.spc[stacked == groups[i], ], na.rm = TRUE) } ## should the minimum be at zero (or less)? if (min.zero) { - offset [1, ] <- sapply(offset [1, ], min, 0, na.rm = TRUE) + offset[1, ] <- sapply(offset[1, ], min, 0, na.rm = TRUE) } - offset [2, ] <- offset[2, ] - offset [1, ] + offset[2, ] <- offset[2, ] - offset[1, ] ## add some extra space - offset [2, ] <- offset [2, ] * (1 + add.factor) + add.sum + offset[2, ] <- offset[2, ] * (1 + add.factor) + add.sum offset <- c(-offset[1, ], 0) + c(0, cumsum(offset[2, ])) list( - offsets = offset [seq_along(groups)], + offsets = offset[seq_along(groups)], groups = stacked, levels = if (is.null(lvl)) stacked else lvl ) @@ -660,7 +660,7 @@ hySpc.testthat::test(stacked.offsets) <- function() { context("stacked.offsets") test_that("ranges do not overlap", { - spc <- do.call(collapse, barbiturates [1:3]) + spc <- do.call(collapse, barbiturates[1:3]) ofs <- stacked.offsets(spc) spc <- spc + ofs$offsets rngs <- apply(spc[[]], 1, range, na.rm = TRUE) @@ -726,12 +726,12 @@ hySpc.testthat::test(stacked.offsets) <- function() { ## make sure that the ticks are not too close for (i in seq_along(delta)) { - keep <- at[[i]] < end.ranges[i] + delta [i] / 4 - at[[i]] <- at[[i]][keep] + keep <- at[[i]] < end.ranges[i] + delta[i] / 4 + at[[i]] <- at[[i]][keep] labels[[i]] <- labels[[i]][keep] keep <- at[[i + 1]] > start.ranges[i + 1] - delta[i] / 4 - at[[i + 1]] <- at[[i + 1]][keep] + at[[i + 1]] <- at[[i + 1]][keep] labels[[i + 1]] <- labels[[i + 1]][keep] } diff --git a/hyperSpec/R/plotvoronoi.R b/hyperSpec/R/plotvoronoi.R index 4159dc42..f419a184 100644 --- a/hyperSpec/R/plotvoronoi.R +++ b/hyperSpec/R/plotvoronoi.R @@ -4,12 +4,13 @@ ### ### plots intensity or extra data column over 2 extra data columns -#' @param use.tripack Whether package tripack should be used for calculating -#' the voronoi polygons. If `FALSE`, package deldir is used instead. -#' See details. -#' @param mix For Voronoi plots using package tripack, I experienced errors if -#' the data was spatially ordered. Randomly rearrangig the rows of the -#' hyperSpec object circumvents this problem. +#' @param use.tripack Whether package \pkg{tripack} should be used for +#' calculating the voronoi polygons. If `FALSE`, package \pkg{deldir} +#' is used instead. +#' See details. +#' @param mix For Voronoi plots using package \pkg{tripack}, I experienced +#' errors if the data was spatially ordered. Randomly rearranging the +#' rows of the hyperSpec object circumvents this problem. #' @rdname levelplot #' @include levelplot.R #' @@ -38,7 +39,7 @@ plotvoronoi <- function(object, model = spc ~ x * y, } if (use.tripack && mix) { - object@data <- object@data [sample(nrow(object)), ] + object@data <- object@data[sample(nrow(object)), ] } dots <- modifyList( diff --git a/hyperSpec/R/rbind.fill.R b/hyperSpec/R/rbind.fill.R index 1c3b0d29..a37d9100 100644 --- a/hyperSpec/R/rbind.fill.R +++ b/hyperSpec/R/rbind.fill.R @@ -2,7 +2,7 @@ ### dependency, but do not export it anymore. -#' Quick data frame. +#' Quick data frame #' #' Experimental version of [as.data.frame()] that converts a list to a data #' frame, but doesn't do any checks to make sure it's a valid format. @@ -132,7 +132,6 @@ rbind.fill.matrix <- function(...) { #' @rdname rbind.fill #' @examples #' # rbind.fill(mtcars[c("mpg", "wt")], mtcars[c("wt", "cyl")]) -#' rbind.fill <- function(...) { dfs <- list(...) if (length(dfs) == 0) { @@ -161,7 +160,7 @@ rbind.fill <- function(...) { ## find which cols contain matrices matrixcols <- unique(unlist(lapply(dfs, function(x) { - names(x) [sapply(x, is.matrix)] + names(x)[sapply(x, is.matrix)] }))) seen[matrixcols] <- TRUE # class<- will fail if the matrix is not protected by I # because 2 dims are needed diff --git a/hyperSpec/R/read_txt_long.R b/hyperSpec/R/read_txt_long.R index f8e921d0..a8e5dca5 100644 --- a/hyperSpec/R/read_txt_long.R +++ b/hyperSpec/R/read_txt_long.R @@ -6,7 +6,7 @@ ### (y x) wl int ### -#' Import and Export of `hyperSpec` objects. +#' Import and Export of `hyperSpec` objects #' #' Besides [base::save()] and [base::load()], two general ways to import and #' export data into `hyperSpec` objects exist. @@ -66,7 +66,6 @@ #' @export #' @importFrom utils read.table unstack #' @examples -#' #' \dontrun{ #' vignette("file-io") #' } @@ -130,7 +129,6 @@ #' ), #' header = TRUE #' ) - read_txt_long <- function(file = stop("file is required"), cols = list( .wavelength = expression(lambda / nm), diff --git a/hyperSpec/R/read_txt_wide.R b/hyperSpec/R/read_txt_wide.R index 5fd8a003..9ac65410 100644 --- a/hyperSpec/R/read_txt_wide.R +++ b/hyperSpec/R/read_txt_wide.R @@ -6,7 +6,7 @@ ### x y ... int (wl1) int (wl2) ... int (wl p) z ... ### -#' Import/export of `hyperSpec` objects to/from ASCII files. +#' Import/export of `hyperSpec` objects to/from ASCII files #' #' @details #' A detailed discussion of \pkg{hyperSpec}'s file import and export @@ -64,7 +64,7 @@ read_txt_wide <- function(file = stop("file is required"), cols <- as.list(c(cols, .wavelength = expression(lambda / nm))) } else if (.wavelength != length(cols)) { # .wavelength should be at the end of cols - cols <- cols [c(seq_along(cols)[-.wavelength], .wavelength)] + cols <- cols[c(seq_along(cols)[-.wavelength], .wavelength)] } ## columns containing the spectra @@ -81,10 +81,10 @@ read_txt_wide <- function(file = stop("file is required"), ispc <- 0:(ncol(txtfile) - length(cols) + 1) + spc spc.data <- as.matrix(txtfile[, ispc]) - txtfile <- txtfile [, -ispc, drop = FALSE] + txtfile <- txtfile[, -ispc, drop = FALSE] ## enforce colnames given by cols - colnames(txtfile) <- head(names(cols) [-spc], -1) + colnames(txtfile) <- head(names(cols)[-spc], -1) spc <- new("hyperSpec", spc = spc.data, data = txtfile, labels = cols) diff --git a/hyperSpec/R/sample.R b/hyperSpec/R/sample.R index 3538ec0f..9fcfa72f 100644 --- a/hyperSpec/R/sample.R +++ b/hyperSpec/R/sample.R @@ -5,7 +5,7 @@ s <- sample.int(nrow(x@data), size = size, replace = replace, prob = prob) - x [s] + x[s] } hySpc.testthat::test(.sample) <- function() { @@ -13,7 +13,7 @@ hySpc.testthat::test(.sample) <- function() { test_that("defaults", { tmp <- sample(flu) - expect_equal(tmp [order(tmp$c)], flu) + expect_equal(tmp[order(tmp$c)], flu) set.seed(101) expect_equal(sample(flu)$c, c(0.05, 0.3, 0.1, 0.15, 0.25, 0.2)) @@ -35,7 +35,7 @@ hySpc.testthat::test(.sample) <- function() { -#' Random Samples and Permutations. +#' Random samples and permutations #' #' Take a sample of the specified size from the elements of x with or without #' replacement. @@ -47,8 +47,9 @@ hySpc.testthat::test(.sample) <- function() { #' @param replace Should sampling be with replacement? #' @param prob A vector of probability weights for obtaining the elements of #' the vector being sampled. -#' @return a hyperSpec object, data.frame or matrix with `size` rows for `sample`, and an -#' integer vector for `isample` that is suitable for indexing (into the spectra) of x. +#' @return a hyperSpec object, data.frame or matrix with `size` rows for +#' `sample`, and an integer vector for `isample` that is suitable for +#' indexing (into the spectra) of x. #' @author C. Beleites #' @seealso [base::sample()] #' @@ -71,7 +72,7 @@ hySpc.testthat::test(.sample) <- function() { #' ) setMethod("sample", signature = signature(x = "hyperSpec"), .sample) -#' `isample` returns an vector of indices, `sample` returns the +#' `isample()` returns an vector of indices, `sample()` returns the #' corresponding hyperSpec object. #' #' @rdname sample @@ -106,17 +107,17 @@ hySpc.testthat::test(isample) <- function() { }) test_that("prob", { - expect_equal(sample(flu, size = 1, prob = c(1, rep(0, 5))), flu [1L]) + expect_equal(sample(flu, size = 1, prob = c(1, rep(0, 5))), flu[1L]) }) test_that("replace", { - expect_equal(sample(flu, size = 3, replace = TRUE, prob = c(1, rep(0, 5))), flu [rep(1L, 3)]) + expect_equal(sample(flu, size = 3, replace = TRUE, prob = c(1, rep(0, 5))), flu[rep(1L, 3)]) }) } .sample.data.frame <- function(x, size, replace = FALSE, prob = NULL, drop = FALSE) { if (missing(size)) size <- nrow(x) - x [sample.int(nrow(x), size = size, replace = replace, prob = prob), , drop = drop] + x[sample.int(nrow(x), size = size, replace = replace, prob = prob), , drop = drop] } #' @rdname sample @@ -152,7 +153,7 @@ hySpc.testthat::test(.sample.data.frame) <- function() { "36", "78", "107", "76", "104", "71", "49", "53", "124" )) expect_equal(dim(tmp), dim(iris)) - expect_equal(tmp, iris [as.numeric(rownames(tmp)), ]) + expect_equal(tmp, iris[as.numeric(rownames(tmp)), ]) }) } @@ -160,7 +161,7 @@ hySpc.testthat::test(.sample.data.frame) <- function() { .sample.matrix <- function(x, size, replace = FALSE, prob = NULL, drop = FALSE) { if (missing(size)) size <- nrow(x) - x [sample.int(nrow(x), size = size, replace = replace, prob = prob), , drop = drop] + x[sample.int(nrow(x), size = size, replace = replace, prob = prob), , drop = drop] } #' @rdname sample @@ -178,6 +179,6 @@ hySpc.testthat::test(.sample.matrix) <- function() { set.seed(101) tmp <- sample(flu[[]]) expect_equal(dim(tmp), dim(flu[[]])) - expect_equal(tmp [c(1L, 3L, 4L, 6L, 5L, 2L), ], flu[[]]) + expect_equal(tmp[c(1L, 3L, 4L, 6L, 5L, 2L), ], flu[[]]) }) } diff --git a/hyperSpec/R/scale.R b/hyperSpec/R/scale.R index 8d9009f6..284f128e 100644 --- a/hyperSpec/R/scale.R +++ b/hyperSpec/R/scale.R @@ -9,7 +9,7 @@ x } -#' Center and scale `hyperSpec` object. +#' Center and scale `hyperSpec` object #' #' Scales the spectra matrix. `scale(x, scale = FALSE)` centers the data. #' diff --git a/hyperSpec/R/seq.R b/hyperSpec/R/seq.R index e32e1e1e..1aa9e012 100644 --- a/hyperSpec/R/seq.R +++ b/hyperSpec/R/seq.R @@ -1,5 +1,5 @@ -#' Sequence generation along spectra or wavelengths. +#' Sequence generation along spectra or wavelengths #' #' This function generates sequences along the spectra (rows) or wavelengths of #' `hyperSpec` objects. @@ -81,10 +81,10 @@ wl.seq <- function(x, from = 1, to = ncol(x@data$spc), ...) { } } + # Unit tests ----------------------------------------------------------------- hySpc.testthat::test(seq.hyperSpec) <- function() { - context("seq.hyperSpec") # Perform tests @@ -93,7 +93,7 @@ hySpc.testthat::test(seq.hyperSpec) <- function() { expect_equal(seq(sp, index = TRUE), 1:nrow(sp)) - expect_is(seq(sp), "hyperSpec") + expect_is(seq(sp), "hyperSpec") expect_is(seq_along(sp), "integer") expect_equal(seq_along(sp), seq(sp, index = TRUE)) @@ -139,5 +139,4 @@ hySpc.testthat::test(seq.hyperSpec) <- function() { expect_length(w, 0) expect_is(w, "integer") }) - } diff --git a/hyperSpec/R/show.R b/hyperSpec/R/show.R index 8c3f3002..fbc8c129 100644 --- a/hyperSpec/R/show.R +++ b/hyperSpec/R/show.R @@ -8,7 +8,7 @@ #' @rdname show #' @aliases show show,hyperSpec-method #' -#' @title Show Brief Summary of `hyperSpec` Object +#' @title Show brief summary of `hyperSpec` object #' #' @description #' Functions `show()`, `print()`, `summary()`, and `as.character()` calculate @@ -69,7 +69,6 @@ #' summary(faux_cell) #' #' summary(faux_cell, include = c("wl", "data")) - setMethod("show", signature = signature(object = "hyperSpec"), .show) @@ -104,7 +103,7 @@ setMethod("summary", signature = signature(object = "hyperSpec"), .summary) # Fun: as.character ---------------------------------------------------------- .as.character <- function(x, digits = getOption("digits"), range = FALSE, - max.print = 5, shorten.to = c(2, 1), include = c("all", "main", "wl", "data")) { + max.print = 5, shorten.to = c(2, 1), include = c("all", "main", "wl", "data")) { # Input checking --------------------------------------------------------- validObject(x) @@ -132,9 +131,8 @@ setMethod("summary", signature = signature(object = "hyperSpec"), .summary) "hyperSpec object", paste(" ", nrow(x), "spectra"), paste(" ", ncol(x), "data columns"), - paste(" ", nwl(x), "data points / spectrum") + paste(" ", nwl(x), "data points / spectrum") ) - } else { NULL } @@ -155,7 +153,6 @@ setMethod("summary", signature = signature(object = "hyperSpec"), .summary) if (all(include %in% "wl")) { return(chr_wl) - } else if (all(include %in% c("main", "wl"))) { return(c(chr_main, chr_wl)) } @@ -172,11 +169,9 @@ setMethod("summary", signature = signature(object = "hyperSpec"), .summary) chr_data <- c(chr_data, .paste.row(x@data[[n]], x@label[[n]], n, ins = 3, i = match(n, names(x@data)), val = TRUE, range = range, shorten.to = shorten.to, max.print = max.print - ) - ) + )) } } - } else { chr_data <- NULL } @@ -222,7 +217,6 @@ setMethod("summary", signature = signature(object = "hyperSpec"), .summary) #' as.character(faux_cell) #' #' as.character(faux_cell, include = c("wl", "data")) - setMethod("as.character", signature = signature(x = "hyperSpec"), .as.character) @@ -279,7 +273,6 @@ hySpc.testthat::test(.print) <- function() { expect_output(print(hs, range = TRUE, include = "data"), " range ") expect_output(print(hs, include = "wl"), "^wavelength: ") - }) test_that("print() does not give certain output", { @@ -317,7 +310,6 @@ hySpc.testthat::test(.summary) <- function() { expect_output(summary(hs, include = "data"), " range ") }) - } diff --git a/hyperSpec/R/spc_bin.R b/hyperSpec/R/spc_bin.R index 94b438f4..ce8c1b1c 100644 --- a/hyperSpec/R/spc_bin.R +++ b/hyperSpec/R/spc_bin.R @@ -1,5 +1,5 @@ -#' @rdname spc-bin -#' @title Wavelength Binning +#' @name spc-bin +#' @title Wavelength binning #' #' @description #' In order to reduce the spectral resolution and thus gain signal to noise @@ -62,7 +62,6 @@ spc_bin <- function(spc, by = stop("reduction factor needed"), na.rm = TRUE, ... if (na.rm == 1) { na <- apply(!na, 1, tapply, bin, sum, na.rm = FALSE) spc@data$spc <- t(apply(spc@data$spc, 1, tapply, bin, sum, na.rm = TRUE) / na) - } else { # faster for small numbers of NA tmp <- t(apply(spc@data$spc, 1, tapply, bin, sum, na.rm = FALSE)) @@ -77,7 +76,6 @@ spc_bin <- function(spc, by = stop("reduction factor needed"), na.rm = TRUE, ... } spc@data$spc <- tmp } - } else { # considerably faster spc@data$spc <- t(apply(spc@data$spc, 1, tapply, bin, sum, na.rm = FALSE)) @@ -135,12 +133,12 @@ hySpc.testthat::test(spc_bin) <- function() { # Wavelengths should be identical expect_silent(wl_regular <- wl(sp)) - expect_silent(wl_binned <- wl(sp_binned)) + expect_silent(wl_binned <- wl(sp_binned)) expect_equal(wl_regular, wl_binned) # Column names in wide-format dataset should be identical too (issue #237) expect_silent(names_regular <- colnames(as.wide.df(sp))) - expect_silent(names_binned <- colnames(as.wide.df(sp_binned))) + expect_silent(names_binned <- colnames(as.wide.df(sp_binned))) expect_equal(names_regular, names_binned) }) diff --git a/hyperSpec/R/spc_fit_poly.R b/hyperSpec/R/spc_fit_poly.R index ed04f20e..51c04343 100644 --- a/hyperSpec/R/spc_fit_poly.R +++ b/hyperSpec/R/spc_fit_poly.R @@ -1,6 +1,6 @@ -#' Polynomial Baseline Fitting. +#' Polynomial baseline fitting #' -#' These functions fit polynomal baselines. +#' These functions fit polynomial baselines. #' #' @details #' Both functions fit polynomials to be used as baselines. If `apply.to` @@ -34,7 +34,6 @@ #' @concept baseline #' #' @examples -#' #' \dontrun{ #' vignette("baseline", package = "hyperSpec") #' } @@ -92,6 +91,9 @@ spc_fit_poly <- function(fit.to, apply.to = NULL, poly.order = 1, } } + +# Unit tests ----------------------------------------------------------------- + hySpc.testthat::test(spc_fit_poly) <- function() { context("spc_fit_poly") @@ -130,17 +132,20 @@ hySpc.testthat::test(spc_fit_poly) <- function() { }) } + +# ... ------------------------------------------------------------------------ + #' @details #' `spc_fit_poly_below()` tries to fit the baseline on appropriate spectral -#' ranges of the spectra in `fit.to`. For details, see the -#' `vignette("baseline")`. +#' ranges of the spectra in `fit.to`. +#' For details, see the `vignette("baseline")`. #' @rdname baselines #' @param npts.min minimal number of points used for fitting the polynomial #' @param noise noise level to be considered during the fit. It may be given as #' one value for all the spectra, or for each spectrum separately. #' @param max.iter stop at the latest after so many iterations. #' @param stop.on.increase additional stopping rule: stop if the number of -#' support points would increase, regardless whether npts.min was reached or +#' support points would increase, regardless whether `npts.min` was reached or #' not. #' @param debuglevel additional output: `1` shows `npts.min`, #' `2` plots support points for the final baseline of 1st spectrum, @@ -213,7 +218,7 @@ spc_fit_poly_below <- function(fit.to, apply.to = fit.to, poly.order = 1, use.old <- logical(nwl(fit.to)) use <- !is.na(y[, i]) - if (debuglevel %in% c(2L, 3L) && i == 1L || debuglevel >= 4L) { + if (debuglevel %in% c(2L, 3L) && i == 1L || debuglevel >= 4L) { plot(fit.to[i], title.args = list(main = paste("spectrum", i))) message("start: ", sum(use, na.rm = TRUE), " support points") } @@ -315,6 +320,9 @@ spc_fit_poly_below <- function(fit.to, apply.to = fit.to, poly.order = 1, } } + +# Unit tests ----------------------------------------------------------------- + hySpc.testthat::test(spc_fit_poly_below) <- function() { context("spc_fit_poly_below") diff --git a/hyperSpec/R/spc_fix_colnames.R b/hyperSpec/R/spc_fix_colnames.R index cc737a91..02622a78 100644 --- a/hyperSpec/R/spc_fix_colnames.R +++ b/hyperSpec/R/spc_fix_colnames.R @@ -1,4 +1,4 @@ -#' Ensure That the Spectra Matrix Has the Wavelengths in Column Names +#' Ensure that the spectra matrix has the wavelengths in column names #' #' @param spc `hyperSpec` object. #' @@ -14,6 +14,9 @@ spc } + +# Unit tests ----------------------------------------------------------------- + hySpc.testthat::test(.spc_fix_colnames) <- function() { context(".spc_fix_colnames") diff --git a/hyperSpec/R/spc_identify.R b/hyperSpec/R/spc_identify.R index 7eb30588..de79da4b 100644 --- a/hyperSpec/R/spc_identify.R +++ b/hyperSpec/R/spc_identify.R @@ -1,4 +1,4 @@ -#' Identifying Spectra and Spectral Data Points. +#' Identifying spectra and spectral data points #' #' This function allows to identify the spectrum and the wavelength of a point #' in a plot produced by [plotspc()]. diff --git a/hyperSpec/R/spc_loess.R b/hyperSpec/R/spc_loess.R index 8eb98197..92c83a5a 100644 --- a/hyperSpec/R/spc_loess.R +++ b/hyperSpec/R/spc_loess.R @@ -1,6 +1,6 @@ #' @rdname spc-loess #' -#' @title LOESS Smoothing Interpolation for Spectra +#' @title LOESS smoothing interpolation for spectra #' #' @description #' Spectra smoothing and interpolation on a new wavelength axis using @@ -50,7 +50,6 @@ #' plot(flu_na_smoothed, add = TRUE, col = "blue") spc_loess <- function(spc, newx, enp.target = nwl(spc) / 4, surface = "direct", ...) { - .loess <- function(y, x) { if (all(is.na(y))) { NA diff --git a/hyperSpec/R/spc_na_approx.R b/hyperSpec/R/spc_na_approx.R index 974f9e70..24aa031b 100644 --- a/hyperSpec/R/spc_na_approx.R +++ b/hyperSpec/R/spc_na_approx.R @@ -1,15 +1,15 @@ -#' Impute Missing Data Points +#' Impute missing data points #' #' Replace `NA`s in the spectra matrix by interpolation. With -#' less than 4 points available linear interpolation of the 2 neighbour points -#' is used. For larger numbers of neighbour points, smoothing interpolation is +#' less than 4 points available linear interpolation of the 2 neighbor points +#' is used. For larger numbers of neighbor points, smoothing interpolation is #' performed by [stats::smooth.spline()]. #' #' @param spc hyperSpec object with spectra matrix containing `NA`s -#' @param neighbours how many neighbour data points should be used to fit the +#' @param neighbours how many neighbor data points should be used to fit the #' line #' @param w,df,spar see [stats::smooth.spline()] -#' @param debuglevel see [hyperSpec::options()] +#' @param debuglevel see [hyperSpec::options()] #' @return hyperSpec object #' #' @export @@ -20,12 +20,12 @@ #' @author Claudia Beleites #' @examples #' fluNA <- hyperSpec:::fluNA -#' spc_na_approx(fluNA [, , min ~ 410], debuglevel = 1) -#' spc_na_approx(fluNA [1, , min ~ 410], debuglevel = 2) -#' spc_na_approx(fluNA [4, , min ~ 410], neighbours = 3, df = 4, debuglevel = 2) +#' spc_na_approx(fluNA[, , min ~ 410], debuglevel = 1) +#' spc_na_approx(fluNA[1, , min ~ 410], debuglevel = 2) +#' spc_na_approx(fluNA[4, , min ~ 410], neighbours = 3, df = 4, debuglevel = 2) spc_na_approx <- function(spc, neighbours = 1, w = rep(1, 2 * neighbours), - df = 1 + .Machine$double.eps, spar = NULL, - debuglevel = hy.getOption("debuglevel")) { + df = 1 + .Machine$double.eps, spar = NULL, + debuglevel = hy.getOption("debuglevel")) { chk.hy(spc) validObject(spc) @@ -58,7 +58,7 @@ spc_na_approx <- function(spc, neighbours = 1, w = rep(1, 2 * neighbours), xneighbours <- c( -(1:neighbours) + nas[start[j]], - (1:neighbours) + nas[end[j]] + (1:neighbours) + nas[end[j]] ) mask <- xneighbours > 0 & xneighbours <= nwl(spc) xneighbours <- xneighbours[mask] @@ -71,7 +71,7 @@ spc_na_approx <- function(spc, neighbours = 1, w = rep(1, 2 * neighbours), if (debuglevel == 2L) { points(x = spc@wavelength[xneighbours], y = spc@data$spc[i, xneighbours]) } - } else if (sum(mask) < 4) {# old behaviour using linear interpolation + } else if (sum(mask) < 4) { # old behaviour using linear interpolation spc@data$spc[i, pts] <- approx( x = spc@wavelength[xneighbours], y = spc@data$spc[i, xneighbours], @@ -82,7 +82,7 @@ spc_na_approx <- function(spc, neighbours = 1, w = rep(1, 2 * neighbours), if (debuglevel == 2L) { lines(x = spc@wavelength[xneighbours], y = spc@data$spc[i, xneighbours]) } - } else {# more neighbours: interpolation spline + } else { # more neighbours: interpolation spline spline <- smooth.spline( x = spc@wavelength[xneighbours], y = spc@data$spc[i, xneighbours], @@ -102,12 +102,16 @@ spc_na_approx <- function(spc, neighbours = 1, w = rep(1, 2 * neighbours), } if (debuglevel == 2L) { - plot(spc[i, , xneighbours, wl.index = TRUE], add = TRUE, - lines.args = list(type = "p", pch = 20), col = 1) + plot(spc[i, , xneighbours, wl.index = TRUE], + add = TRUE, + lines.args = list(type = "p", pch = 20), col = 1 + ) } if (debuglevel >= 1L) { - plot(spc[i, , pts, wl.index = TRUE], add = TRUE, - lines.args = list(type = "p", pch = 20), col = 2) + plot(spc[i, , pts, wl.index = TRUE], + add = TRUE, + lines.args = list(type = "p", pch = 20), col = 2 + ) } } } @@ -133,7 +137,8 @@ hySpc.testthat::test(spc_na_approx) <- function() { tmp <- spc_na_approx(fluNA[-2, , min ~ 410], neighbours = 2) expect_true( all(abs(tmp[[, , 406]] - rowMeans(fluNA[[-2, , 405 ~ 407]], - na.rm = TRUE)) <= 1e-5) + na.rm = TRUE + )) <= 1e-5) ) # version on CRAN throws error on `expect_equal(tolerance = 1e-5)` # TODO => change back ASAP diff --git a/hyperSpec/R/spc_rubberband.R b/hyperSpec/R/spc_rubberband.R index 1e831e46..1d8104a0 100644 --- a/hyperSpec/R/spc_rubberband.R +++ b/hyperSpec/R/spc_rubberband.R @@ -1,4 +1,5 @@ -#' @title Rubberband baseline correction. +#' @title Rubberband baseline correction +#' #' @description #' Baseline with support points determined from a convex hull of the spectrum. #' @@ -9,7 +10,7 @@ #' @param upper logical indicating whether the lower or upper part of the hull should be used #' @param noise noise level to be taken into account #' @param spline logical indicating whether the baseline should be an interpolating spline through -#' the support points or piecewise linear. +#' the support points or piece wise linear. #' @return `hyperSpec` object containing the baselines #' @rdname spc-rubberband #' @author Claudia Beleites @@ -103,6 +104,7 @@ spc_rubberband <- function(spc, ..., upper = FALSE, noise = 0, spline = TRUE) { y } + # Unit tests ----------------------------------------------------------------- hySpc.testthat::test(spc_rubberband) <- function() { @@ -148,4 +150,3 @@ hySpc.testthat::test(spc_rubberband) <- function() { ) }) } - diff --git a/hyperSpec/R/spc_spline.R b/hyperSpec/R/spc_spline.R index c637ea40..0af566c1 100644 --- a/hyperSpec/R/spc_spline.R +++ b/hyperSpec/R/spc_spline.R @@ -1,8 +1,9 @@ -#' @title Spectral smoothing by splines. +#' @title Spectral smoothing by splines +#' #' @description #' Spectral smoothing by splines. #' @param spc `hyperSpec` object -#' @param newx wavelengh axis to interpolate on +#' @param newx wavelength axis to interpolate on #' @param ... further parameters handed to [stats::smooth.spline()] #' @return `hyperSpec` object containing smoothed spectra #' @rdname spc-spline @@ -55,7 +56,9 @@ spc_smooth_spline <- function(spc, newx = wl(spc), ...) { spc } + # Unit tests ----------------------------------------------------------------- + hySpc.testthat::test(spc_smooth_spline) <- function() { context("spc_smooth_spline") diff --git a/hyperSpec/R/split.R b/hyperSpec/R/split.R index cd447d93..47998244 100644 --- a/hyperSpec/R/split.R +++ b/hyperSpec/R/split.R @@ -10,7 +10,7 @@ hyperlist } -#' Split a `hyperSpec` object according to groups. +#' Split a `hyperSpec` object according to groups #' #' `split()` divides the `hyperSpec` object into a list of #' `hyperSpec` objects according to the groups given by `f`. @@ -51,8 +51,8 @@ setMethod("split", signature = signature(x = "hyperSpec"), .split) # Unit tests ----------------------------------------------------------------- -hySpc.testthat::test(.split) <- function() { +hySpc.testthat::test(.split) <- function() { context("split") # Perform tests @@ -73,6 +73,5 @@ hySpc.testthat::test(.split) <- function() { expect_is(obj$`2`, "hyperSpec") expect_equal(obj$`1`, flu[c(1, 3, 6), , ]) expect_equal(obj$`2`, flu[c(2, 4, 5), , ]) - }) } diff --git a/hyperSpec/R/subset.R b/hyperSpec/R/subset.R index 4579ffc6..81d547db 100644 --- a/hyperSpec/R/subset.R +++ b/hyperSpec/R/subset.R @@ -8,7 +8,7 @@ } -#' Subset for `hyperSpec` object. +#' Subset `hyperSpec` object #' #' @name subset #' @param x `hyperSpec` object diff --git a/hyperSpec/R/sweep.R b/hyperSpec/R/sweep.R index cbe0f1c0..e3dc0df2 100644 --- a/hyperSpec/R/sweep.R +++ b/hyperSpec/R/sweep.R @@ -17,14 +17,14 @@ x } -#' Sweep Summary Statistic out of an hyperSpec Object. +#' Sweep summary statistic out of an `hyperSpec` object #' #' [base::sweep()] for `hyperSpec` objects. #' #' Calls [base::sweep()] for the spectra matrix. #' -#' `sweep` is useful for some spectra preprocessing, like offset -#' correction, substraction of background spectra, and normalization of the +#' `sweep` is useful for some spectra pre-processing, like offset +#' correction, subtraction of background spectra, and normalization of the #' spectra. #' #' @name sweep @@ -60,9 +60,9 @@ #' #' @examples #' -#' ## Substract the background / slide / blank spectrum +#' ## Subtract the background / slide / blank spectrum #' # the example data does not have spectra of the empty slide, -#' # so instead the overall composition of the sample is substracted +#' # so instead the overall composition of the sample is subtracted #' background <- apply(faux_cell, 2, quantile, probs = 0.05) #' corrected <- sweep(faux_cell, 2, background, "-") #' plot(corrected, "spcprctl5") @@ -88,6 +88,7 @@ setMethod("sweep", signature = signature(x = "hyperSpec"), .sweep) # Unit tests ----------------------------------------------------------------- + hySpc.testthat::test(.sweep) <- function() { context("sweep") diff --git a/hyperSpec/R/trellis.factor.key.R b/hyperSpec/R/trellis.factor.key.R index 525f1d6c..7725250c 100644 --- a/hyperSpec/R/trellis.factor.key.R +++ b/hyperSpec/R/trellis.factor.key.R @@ -1,4 +1,4 @@ -#' Color coding legend for factors. +#' Color coding legend for factors #' #' Modifies a list of lattice arguments (as for [lattice::levelplot()], etc.) according to #' the factor levels. The colorkey will shows all levels (including unused), and the drawing colors @@ -24,7 +24,7 @@ #' faux_cell$z <- factor(rep(c("a", "a", "d", "c"), #' length.out = nrow(faux_cell) #' ), -#' levels = letters [1:4] +#' levels = letters[1:4] #' ) #' #' str(trellis.factor.key(faux_cell$z)) diff --git a/hyperSpec/R/vandermonde.R b/hyperSpec/R/vandermonde.R index 7e35c39d..ef16e42d 100644 --- a/hyperSpec/R/vandermonde.R +++ b/hyperSpec/R/vandermonde.R @@ -1,10 +1,10 @@ -#' Function evaluation on `hyperSpec` objects. +#' Function evaluation on `hyperSpec` objects #' #' `vandermonde()` generates Vandermonde matrices, the `hyperSpec` method -#' generates a `hyperSpec` object containing the van der Monde matrix of the +#' generates a `hyperSpec` object containing the Vandermonde matrix of the #' wavelengths of a `hyperSpec` object. #' -#' It is often numerically preferrable to map `wl(x)` to \[0, 1\], see the +#' It is often numerically preferable to map `wl(x)` to \[0, 1\], see the #' example. #' #' @param x object to evaluate the polynomial on @@ -30,11 +30,11 @@ vanderMonde <- function(x, order, ...) { #' @noRd setGeneric("vanderMonde") -#' @param normalize.wl function to transorm the wavelengths before evaluating the polynomial (or +#' @param normalize.wl function to transform the wavelengths before evaluating the polynomial (or #' other function). [hyperSpec::normalize01()] maps the wavelength range to the interval #' \[0, 1\]. Use [base::I()] to turn off. #' @param ... hyperSpec method: further arguments to [hyperSpec::decomposition()] -#' @return hyperSpec method: hyperSpec object containing van der Monde matrix as spectra and an additional column `$.vdm.order$ giving the order of each spectrum (term). +#' @return hyperSpec method: hyperSpec object containing Vandermonde matrix as spectra and an additional column `$.vdm.order$ giving the order of each spectrum (term). #' @rdname vanderMonde #' @seealso [hyperSpec::wl_eval()] for calculating arbitrary functions of the wavelength, #' diff --git a/hyperSpec/R/wl.R b/hyperSpec/R/wl.R index 480af2d8..62fa47f5 100644 --- a/hyperSpec/R/wl.R +++ b/hyperSpec/R/wl.R @@ -1,4 +1,4 @@ -#' Getting and Setting the Wavelength Axis +#' Getting and setting the wavelength axis #' #' `wl()` returns the wavelength axis, `wl<-` sets it. #' @@ -80,12 +80,12 @@ wl <- function(x) { #' #' # convert from Raman shift to wavelength #' # excitation was at 785 nm -#' plot(faux_cell [1]) +#' plot(faux_cell[1]) #' wl(faux_cell) <- list( #' wl = 1e7 / (1e7 / 785 - wl(faux_cell)), #' label = expression(lambda / nm) #' ) -#' plot(faux_cell [1]) +#' plot(faux_cell[1]) "wl<-" <- function(x, label = NULL, digits = 6, value) { chk.hy(x) validObject(x) diff --git a/hyperSpec/R/wl2i.R b/hyperSpec/R/wl2i.R index f4a1e330..a499895c 100644 --- a/hyperSpec/R/wl2i.R +++ b/hyperSpec/R/wl2i.R @@ -3,23 +3,24 @@ ### .getindex ### ### -## does the acual work of looking up the index for wl2i, .extract and .replace -## extrapolate = TRUE returns first resp. last index for wavelength outside hyperSpec@wavelength. +## does the actual work of looking up the index for wl2i, .extract and .replace +## extrapolate = TRUE returns first resp. last index for wavelength outside +## hyperSpec@wavelength. ## extrapolate = FALSE returns NA in this case .getindex <- function(x, wavelength, extrapolate = TRUE) { if (!extrapolate) { - wavelength [wavelength < min(x@wavelength)] <- -Inf - wavelength [wavelength > max(x@wavelength)] <- +Inf + wavelength[wavelength < min(x@wavelength)] <- -Inf + wavelength[wavelength > max(x@wavelength)] <- +Inf } - tmp <- wavelength [is.finite(wavelength)] + tmp <- wavelength[is.finite(wavelength)] if (length(tmp) > 0) { tmp <- sapply( tmp, function(x, y) which.min(abs(x - y)), x@wavelength ) - wavelength [is.finite(wavelength)] <- tmp + wavelength[is.finite(wavelength)] <- tmp } wavelength } @@ -36,11 +37,11 @@ #' #' index corresponding to start : index corresponding to end #' -#' is returned. If the wavelengths are not ordered, that may lead to chaos. In this case, call -#' [hyperSpec::wl_sort()] first. +#' is returned. If the wavelengths are not ordered, that may lead to chaos. +#' In this case, call [hyperSpec::wl_sort()] first. #' -#' Two special variables can be used: `min` and `max`, corresponding to the lowest and -#' highest wavelength of `x`, respectively. +#' Two special variables can be used: `min` and `max`, corresponding to the +#' lowest and highest wavelength of `x`, respectively. #' #' start and end may be complex numbers. The resulting index for a complex x is then #' @@ -130,7 +131,7 @@ wl2i <- function(x, wavelength = stop("wavelengths are required."), unlist = TRU ## conversion to indices if (is.logical(to)) { - to <- seq_len(nwl(x)) [to] + to <- seq_len(nwl(x))[to] } else { to <- .getindex(x, Re(to), extrapolate = FALSE) + Im(to) } @@ -242,7 +243,7 @@ i2wl <- function(x, i) { chk.hy(x) validObject(x) - x@wavelength [i] + x@wavelength[i] } ## check for wrong complex invocation diff --git a/hyperSpec/R/wl_convert_units.R b/hyperSpec/R/wl_convert_units.R index a88b4630..243b1613 100644 --- a/hyperSpec/R/wl_convert_units.R +++ b/hyperSpec/R/wl_convert_units.R @@ -1,8 +1,8 @@ -#' Convert between Different Wavelength Units +#' Convert between different wavelength units #' #' The following units can be converted into each other: -#' *nm*, \emph{\eqn{cm^{-1}}{inverse cm}}, *eV*, *THz* and *Raman shift* +#' *nm*, \emph{\eqn{cm^{-1}}{inverse cm}}, *eV*, *THz* and *Raman shift*. #' #' @param x data for conversion #' @param from source unit diff --git a/hyperSpec/R/wl_eval.R b/hyperSpec/R/wl_eval.R index 4e84fa5a..e82119ae 100644 --- a/hyperSpec/R/wl_eval.R +++ b/hyperSpec/R/wl_eval.R @@ -4,7 +4,7 @@ #' #' @param x either `hyperSpec` object or numeric vector. #' @param ... expressions to be evaluated. -#' @param normalize.wl function to transorm the wavelengths before evaluating +#' @param normalize.wl function to transform the wavelengths before evaluating #' the polynomial (or other function). Use [hyperSpec::normalize01()] to map #' the wavelength range to the interval \[0, 1\]. #' @return `hyperSpec` object containing one spectrum for each expression. @@ -24,11 +24,9 @@ #' @examples #' plot(wl_eval(laser, exp = function(x) exp(-x))) #' -#' plot(wl_eval(1000:4000, y = function(x) 1/log(x))) +#' plot(wl_eval(1000:4000, y = function(x) 1 / log(x))) #' -#' plot(wl_eval(300:550, y2 = function(x) x*2, y3 = function(x) x*3)) -#' -#' @include normalize01.R +#' plot(wl_eval(300:550, y2 = function(x) x * 2, y3 = function(x) x * 3)) wl_eval <- function(x, ..., normalize.wl = I) { UseMethod("wl_eval") } @@ -124,7 +122,6 @@ hySpc.testthat::test(wl_eval.hyperSpec) <- function() { }) test_that("wl_eval() works", { - expect_equal( as.vector(wl_eval(1:10, f = function(x) x)$spc), 1:10 @@ -137,7 +134,7 @@ hySpc.testthat::test(wl_eval.hyperSpec) <- function() { expect_equal( wl_eval(wl(flu), f = function(x) x)$.f, - wl_eval( flu, f = function(x) x)$.f + wl_eval(flu, f = function(x) x)$.f ) expect_silent( diff --git a/hyperSpec/R/wl_sort.R b/hyperSpec/R/wl_sort.R index 43bbbc17..b772400f 100644 --- a/hyperSpec/R/wl_sort.R +++ b/hyperSpec/R/wl_sort.R @@ -1,6 +1,7 @@ -#' Sorting the Wavelengths of a `hyperSpec` Object +#' Sorting the wavelengths of a `hyperSpec` object #' +#' @description #' Rearranges the `hyperSpec` object so that the wavelength vector is in #' increasing (or decreasing) order. #' diff --git a/hyperSpec/R/write_txt_long.R b/hyperSpec/R/write_txt_long.R index 2034fa94..b9340e5c 100644 --- a/hyperSpec/R/write_txt_long.R +++ b/hyperSpec/R/write_txt_long.R @@ -1,7 +1,7 @@ ### --------------------------------------------------------------------------- # FIXME: update examples -#' Export `hyperSpec` Objects to ASCII (text) Files +#' Export `hyperSpec` objects to ASCII (text) files #' #' These functions write `hyperSpec` objects to text files. #'