diff --git a/hyperSpec/DESCRIPTION b/hyperSpec/DESCRIPTION index d22429ab..edeb21e7 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"), @@ -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' 'DEPRECATED-read.ENVI.R' @@ -113,14 +114,18 @@ 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' 'DEPRECATED-spc_na_approx.R' + 'spc_rubberband.R' 'DEPRECATED-spc_rubberband.R' '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' 'DEPRECATED-write_txt_long.R' @@ -131,7 +136,6 @@ Collate: 'all.equal.R' 'apply.R' 'as.data.frame.R' - 'extract_numbers.R' 'as_hyperSpec.R' 'barbiturates.R' 'bind.R' @@ -173,7 +177,6 @@ Collate: 'merge.R' 'mergeextra.R' 'mvtnorm.R' - 'normalize01.R' 'palette_colorblind.R' 'palette_matlab.R' 'pearson_dist.R' @@ -193,12 +196,10 @@ Collate: 'seq.R' 'show.R' 'spc_bin.R' - 'spc_fit_poly.R' 'spc_fix_colnames.R' 'spc_identify.R' 'spc_loess.R' 'spc_na_approx.R' - 'spc_rubberband.R' 'spc_spline.R' 'split.R' 'subset.R' @@ -207,7 +208,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-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 20f5bfc3..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 @@ -16,7 +17,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 @@ -35,22 +36,12 @@ #' 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) - - if (is.null(wl) || length(wl) == 0L || any(is.na(wl))) { - if (hy.getOption("debuglevel") >= 1L) { - message("could not guess wavelengths") - } - wl <- NULL - } - - wl + extract_numbers(X) } #' @include constants-regexps.R @@ -58,17 +49,10 @@ 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." + ) }) } diff --git a/hyperSpec/R/DEPRECATED-ggplot2.R b/hyperSpec/R/DEPRECATED-ggplot2.R index ab8e5651..1ad3637f 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 #' @@ -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") + }) +} diff --git a/hyperSpec/R/DEPRECATED-read.asc.Andor.R b/hyperSpec/R/DEPRECATED-read.asc.Andor.R index 890dec4a..60d727d2 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.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))) } 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 e5bd3d7a..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 #' @@ -38,7 +39,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 +51,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 +98,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 +108,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 +119,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 +153,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 +164,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 +172,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 +222,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 ------------------------ 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..8287f351 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 @@ -122,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", { @@ -146,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)) @@ -166,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))) diff --git a/hyperSpec/R/DEPRECATED-spc_fit_poly.R b/hyperSpec/R/DEPRECATED-spc_fit_poly.R index afb0b2b7..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 @@ -13,7 +14,7 @@ #' #' `_____________` #' -#' These functions fit polynomal baselines. +#' These functions fit polynomial baselines. #' #' @details #' Both functions fit polynomials to be used as baselines. If `apply.to` @@ -25,123 +26,36 @@ #' `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. -#' @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` +#' @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) - } - ) - - # 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)[[]] + "deprecated", + expect_warning( + spc.fit.poly(flu), + "Function 'spc.fit.poly' is deprecated." ) - - ## bug was: all coefficients were silently 0 - expect_true(all(abs(coefs) > sqrt(.Machine$double.eps))) - }) + ) } #' @rdname DEPRECATED-baselines @@ -151,265 +65,26 @@ 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 <- palette_matlab_dark(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]) - - 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]) + spc_fit_poly_below(...) - 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 - ) - } - ) - - # 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." - ) + "deprecated", 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)[[]] + spc.fit.poly.below(flu), + "Function 'spc.fit.poly.below' is deprecated." ) - - ## bug was: all coefficients were silently 0 - expect_true(all(abs(coefs) > sqrt(.Machine$double.eps))) - }) + ) } diff --git a/hyperSpec/R/DEPRECATED-spc_fix_colnames.R b/hyperSpec/R/DEPRECATED-spc_fix_colnames.R index f8f226e1..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 @@ -32,11 +33,19 @@ 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))) }) } diff --git a/hyperSpec/R/DEPRECATED-spc_loess.R b/hyperSpec/R/DEPRECATED-spc_loess.R index e15c9288..dbb09221 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 @@ -111,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 5ce97efa..cae0da35 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 @@ -135,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) @@ -143,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) @@ -156,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_rubberband.R b/hyperSpec/R/DEPRECATED-spc_rubberband.R index ca39f4ae..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 @@ -16,106 +17,33 @@ #' #' 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 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 ... 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. +#' #' @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 -} - -#' @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 = palette_matlab_dark(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 = palette_matlab_dark(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 + spc_rubberband(...) + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ } # Unit tests ----------------------------------------------------------------- @@ -123,44 +51,11 @@ spc.rubberband <- function(spc, ..., upper = FALSE, noise = 0, spline = TRUE) { hySpc.testthat::test(spc.rubberband) <- function() { context("spc.rubberband") - ## use data that yields fairly stable baseline solution - paracetamol <- paracetamol[, , 300 ~ 550] - - - 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)])[[]] + test_that( + "deprecated", + expect_warning( + spc.rubberband(paracetamol), + "Function 'spc.rubberband' is deprecated." ) - - ## 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)])[[]] - ) - }) + ) } - diff --git a/hyperSpec/R/DEPRECATED-spc_spline.R b/hyperSpec/R/DEPRECATED-spc_spline.R index 5679c446..f3a44e8f 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 #' @@ -75,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") }) 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..e4ea1371 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 @@ -323,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") }) diff --git a/hyperSpec/R/DEPRECATED-wl_eval.R b/hyperSpec/R/DEPRECATED-wl_eval.R index 86db7b7d..e6c1b33e 100644 --- a/hyperSpec/R/DEPRECATED-wl_eval.R +++ b/hyperSpec/R/DEPRECATED-wl_eval.R @@ -17,64 +17,50 @@ #' #' @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. #' #' @export +#' @include wl_eval.R #' #' @seealso #' -#' - [hyperSpec::vanderMonde()] for polynomials, +#' - [hyperSpec::vanderMonde()] for polynomials, #' - [hyperSpec::normalize01()] to normalize the wavenumbers before evaluating #' the function. #' #' @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 = normalize.wl) } #' @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 = normalize.wl) + } @@ -84,84 +70,14 @@ 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("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 + test_that("deprecated", { + expect_warning( + wl.eval.hyperSpec(flu, function(x) x), + "Function 'wl.eval.hyperSpec' is deprecated." ) - expect_warning( - tmp <- wl.eval(300:500, f = function(x) x, g = function(x) exp(-x)), - "deprecated" + wl.eval.numeric(1:5, function(x) x), + "Function 'wl.eval.numeric' is 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)) }) } 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 fc9a7366..ec7f4245 100644 --- a/hyperSpec/R/read.jdx.R +++ b/hyperSpec/R/read.jdx.R @@ -1,22 +1,43 @@ -#' @title JCAMP-DX Import for Shimadzu Library Spectra. +# TODO: rename this file to "DEPRECATED-read.jdx.R" in a separate pull request. + +#' @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 +#' 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 | @@ -24,25 +45,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 io -#' #' @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) { + 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. + # ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + + ## 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) @@ -73,7 +103,7 @@ read.jdx <- function(filename = stop("filename is needed"), 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.") @@ -81,18 +111,18 @@ read.jdx <- function(filename = stop("filename is needed"), 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) ) @@ -116,16 +146,16 @@ read.jdx <- function(filename = stop("filename is needed"), 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)) @@ -135,7 +165,7 @@ read.jdx <- function(filename = stop("filename is needed"), 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 @@ -143,8 +173,8 @@ read.jdx <- function(filename = stop("filename is needed"), 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 (", @@ -197,9 +227,9 @@ read.jdx <- function(filename = stop("filename is needed"), 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) @@ -208,8 +238,7 @@ read.jdx <- function(filename = stop("filename is needed"), encoding = "", spc } -### DATA FORMATS ------------------------------------------------------------------------------------ - +### DATA FORMATS -------------------------------------------------------------- .jdx.TABULAR.PAC <- function(hdr, data, ..., xtol = hdr$xfactor) { ## regexp for numbers including scientific notation @@ -239,7 +268,7 @@ read.jdx <- function(filename = stop("filename is needed"), 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. ", @@ -260,7 +289,7 @@ read.jdx <- function(filename = stop("filename is needed"), 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 ------------------------------------------------------------------------------------------- @@ -297,30 +326,30 @@ read.jdx <- function(filename = stop("filename is needed"), 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) @@ -339,85 +368,9 @@ 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 + test_that( + "deprecated", + expect_warning(read.jdx(), "deprecated.*hySpc.read.jdx") ) - ## these files need special parameters: - files <- setdiff(files, c("fileio/jcamp-dx/shimadzu.jdx", "fileio/jcamp-dx/virgilio.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]) - } - }) } 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" ))