gsignal/0000755000176200001440000000000014670417477011717 5ustar liggesusersgsignal/tests/0000755000176200001440000000000014420222025013031 5ustar liggesusersgsignal/tests/testthat/0000755000176200001440000000000014670417477014721 5ustar liggesusersgsignal/tests/testthat/Rplots.pdf0000644000176200001440000001110114665612407016663 0ustar liggesusers%PDF-1.4 %ρ\r 1 0 obj << /CreationDate (D:20240903155408) /ModDate (D:20240903155408) /Title (R Graphics Output) /Producer (R 4.1.3) /Creator (R) >> endobj 2 0 obj << /Type /Catalog /Pages 3 0 R >> endobj 7 0 obj << /Type /Page /Parent 3 0 R /Contents 8 0 R /Resources 4 0 R >> endobj 8 0 obj << /Length 765 /Filter /FlateDecode >> stream xUMO1ﯘ#9x{ *JpHI(A>T;ޥAICVyf3<@ RH)!}㷥?H'+ Ӣ$A2=D'籔SqV""NR)b2 B\^cŪMoxUI Q0})wŗi%駣kCdtXJH [< 7ef3B{xJx_Pǧ3)Ei$}k<ٰۧdnOJ`5<:qs)mzGLD޲|>lvoO>ك"E:NJ|~+.{.*w<{{Jc\ygl'ɵйttk%=%:3|3ޗ񩺍~;X*Ų'NpWC!V*7 Kîz^@3zgxDQﷳz? Qf. *.Jl}vx?6%)W!u9[0OL 6 'iendstream endobj 3 0 obj << /Type /Pages /Kids [ 7 0 R ] /Count 1 /MediaBox [0 0 504 504] >> endobj 4 0 obj << /ProcSet [/PDF /Text] /Font <> /ExtGState << >> /ColorSpace << /sRGB 5 0 R >> >> endobj 5 0 obj [/ICCBased 6 0 R] endobj 6 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~endstream endobj 9 0 obj << /Type /Encoding /BaseEncoding /WinAnsiEncoding /Differences [ 45/minus ] >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /Name /F2 /BaseFont /Helvetica /Encoding 9 0 R >> endobj 11 0 obj << /Type /Font /Subtype /Type1 /Name /F3 /BaseFont /Helvetica-Bold /Encoding 9 0 R >> endobj xref 0 12 0000000000 65535 f 0000000021 00000 n 0000000163 00000 n 0000001128 00000 n 0000001211 00000 n 0000001334 00000 n 0000001367 00000 n 0000000212 00000 n 0000000292 00000 n 0000004062 00000 n 0000004156 00000 n 0000004253 00000 n trailer << /Size 12 /Info 1 0 R /Root 2 0 R >> startxref 4355 %%EOF gsignal/tests/testthat/test_Filtering_Functions.R0000644000176200001440000002441614420222025022035 0ustar liggesusers# gsignal filtering functions library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # filter() test_that("parameters to filter() are correct", { expect_error(filter()) expect_error(filter(0, 0, 1:10)) expect_error(filter(1, 1, c('invalid', 'invalid'))) }) test_that("filter() tests are correct", { expect_equal(filter(1, 1, 1:2), c(1,2)) expect_equal(filter(1, 2, 1:2), c(0.50, 1.00)) expect_equal(filter(2, 1, 1:2), c(2, 4)) x <- runif(100) y <- filter(1, 1, x) expect_equal(length(y), length(x)) x <- matrix(runif(200), 100, 2) colnames(x) <- c("one", "two") y <- filter(1, 1, x) expect_equal(ncol(y), ncol(x)) expect_equal(nrow(y), nrow(x)) expect_equal(colnames(y), colnames(x)) # Octave tests - shared a, b, x, r a <- c(1, 1) b <- c(1, 1) x <- rep(0, 10); x[1] <- 1 expect_equal(filter(b, 1, x), c(1, 1, 0, 0, 0, 0, 0, 0, 0, 0)) expect_equal(filter(1, a, x), c(+1, -1, +1, -1, +1, -1, +1, -1, +1, -1)) expect_equal(filter(b, a, x), x) # complex variables r <- sqrt (1 / 2) * (1 + 1i) expect_equal(filter(b, 1, r * x), r * c(1, 1, 0, 0, 0, 0, 0, 0, 0, 0)) expect_equal(filter(1, b, r * x), r * c(+1, -1, +1, -1, +1, -1, +1, -1, +1, -1)) expect_equal(filter(b, a, r * x), r * x) a <- a * r b <- b * r expect_equal(filter(b, 1, x), r * c(1, 1, 0, 0, 0, 0, 0, 0, 0, 0)) expect_equal(filter(b, 1, r * x), r * r * c(1, 1, 0, 0, 0, 0, 0, 0, 0, 0)) expect_equal(filter(b, a, x), c(1, 0, 0, 0, 0, 0, 0, 0, 0, 0)) expect_equal(filter(b, a, r * x), r * c(1, 0, 0, 0, 0, 0, 0, 0, 0, 0)) a <- c(1, 1) b <- c(1, 1) x <- rep(0, 10); x[1] <- 1 l <- filter(b, 1, x, -1) expect_equal(l$y, c(0, 1, 0, 0, 0, 0, 0, 0, 0, 0)) expect_equal(l$zf, 0) x <- matrix(0, 10, 3); x[1, 1] <- -1; x[1, 2] <- 1 y0 <- matrix(0, 10, 3); y0[1:2, 1] = -1; y0[1:2, 2] = 1 y <- filter (b, 1, x) expect_equal(y, y0) # Test using initial conditions expect_equal(filter(c(1, 1, 1), c(1, 1), c(1, 2), c(1, 1))$y, c(2, 2)) expect_equal(filter(c(1, 3), 1, matrix(1:6, 3, byrow = TRUE), matrix(c(4, 5), 1))$y, matrix(c(5, 6, 14, 7, 10, 18), 3)) expect_error(filter(c(1, 3), 1, matrix(1:6, 3, byrow = TRUE), c(4, 5))) }) # ----------------------------------------------------------------------- # filtfilt() test_that("parameters to filtfilt() are correct", { expect_error(filtfilt()) expect_error(filtfile(0, 0)) expect_error(filtfilt(0, 0, 1:10)) expect_error(filtfilt(1, 2, array(1:8, c(2, 2, 2)))) expect_error(filtfilt(1, 1, c('invalid', 'invalid'))) }) test_that("filtfilt() tests are correct", { expect_equal(filtfilt(1, 1, 1:2), c(1,2)) expect_equal(filtfilt(1, 2, 1:2), c(0.25, 0.50)) expect_equal(filtfilt(2, 1, 1:2), c(4, 8)) x <- runif(100) y <- filtfilt(1, 1, x) expect_equal(length(y), length(x)) x <- matrix(runif(200), 100, 2) colnames(x) <- c("one", "two") y <- filtfilt(1, 1, x) expect_equal(ncol(y), ncol(x)) expect_equal(nrow(y), nrow(x)) expect_equal(colnames(y), colnames(x)) # bug 20220328 expect_equal(filtfilt(1:4, 1:4, 1:10), 1:10) }) # ----------------------------------------------------------------------- # filtic() test_that("parameters to filtic() are correct", { expect_error(filtic()) expect_error(filtic(1)) expect_error(filtic(1, 2)) expect_error(filtic(1, 2, 3, 4, 5)) expect_error(filtic(0, 0, 'invalid')) }) test_that("filtic() tests are correct", { # Simple low pass filter b <- c(0.25, 0.25) a <- c(1.0, -0.5) expect_equal(filtic(b, a, 1, 1), 0.75) # Simple high pass filter b <- c(0.25, -0.25) a <- c(1.0, 0.5) expect_equal(filtic(b, a, 0, 1), -0.25) # Second order cases # bs <- butter(2, 0.4) b <- c(0.2065721, 0.4131442, 0.2065721) a <- c(1.0000000, -0.3695274, 0.1958157) x <- y <- c(1, 1) expect_equal(filtic(b, a, y, x), c(0.7934280, 0.0107564), tolerance = tol) N <- 1000 xx <- cos(2 * pi * seq(0, N-1, length.out = N)/8) yy <- filter(b, a, xx) x <- xx[seq(N, N - 1, -1)] y <- yy[seq(N, N - 1, -1)] zf <- filtic(b, a, y, x) expect_equal(filtic(b, a, y, x), c( 0.4039015, 0.1625113), tolerance = tol) }) # ----------------------------------------------------------------------- # medfilt1() test_that("parameters to medfilt1() are correct", { expect_error(medfilt1()) expect_error(medfilt1(1, 2)) expect_error(medfilt1(1, -1)) expect_error(medfilt1(cbind(1:10, 1:10), 3, 3)) expect_error(medfilt1('invalid')) expect_error(medfilt1(1:10, endrule = 'invalid')) expect_error(medfilt1(1:10, algorithm = 'invalid')) expect_error(medfilt1(1:10, printy.level = 'invalid')) }) test_that("medfilt1() tests are correct", { expect_equal(medfilt1(1:10), 1:10) expect_equal(medfilt1(c(1, 1, 2, 3, 3, 4, 4, 4, 5)), c(1, 1, 2, 3, 3, 4, 4, 4, 4)) expect_equal(medfilt1(c(1, 1, 2, 3, NA, 4, 4, 4, 5)), c(1, 1, 2, 3, 3.676871, 4, 4, 4, 4), tolerance = tol) expect_equal(medfilt1(c(1, 1, 2, 3, NA, 4, 4, 4, 5), na.omit = TRUE), c(1, 1, 2, 3, 4, 4, 4, 4)) expect_equal(medfilt1(cbind(1:5, 1:5)), cbind(1:5, 1:5)) expect_equal(medfilt1(cbind(1:5, 1:5), n = 1, MARGIN = 1), rbind(1:5, 1:5)) }) # ----------------------------------------------------------------------- # movingrms() test_that("parameters to movingrms() are correct", { expect_error(movingrms()) expect_error(movingrms(1, -1)) expect_error(movingrms(1, 1, -1)) expect_error(movingrms(1, 1, 1, -1)) expect_error(movingrms('invalid')) expect_error(movingrms(1, 2, 3, 4, 5)) }) test_that("movingrms() tests are correct", { r <- movingrms(1, 1) expect_equal(r$rmsx, Inf) expect_equal(r$w, 1) r <- movingrms(matrix(1:100, 50), 1) expect_equal(ncol(r$rmsx), 2) expect_equal(nrow(r$rmsx), 50) expect_equal(r$w, c(rep(0, 23), 0.5, 1, 0.5, rep(0, 24))) }) # tests for sgolayfilt are in test_FIR_Filter_design_functions.R # together with the sgolay() function # ----------------------------------------------------------------------- # sosfilt() test_that("parameters to sosfilt() are correct", { expect_error(sosfilt()) expect_error(sosfilt(1, -1)) expect_error(sosfilt(rep(1, 6), 'invalid')) expect_error(sosfilt(1, 1, 1)) expect_error(sosfilt(c(0,0,0,0,0,0), 1)) expect_error(sosfilt(rep(1, 6), 1, 'invalid')) }) test_that("sosfilt() tests are correct", { expect_equal(sosfilt(c(0, 0, 0, 1, 0, 0), 1), 0) expect_equal(sosfilt(c(0, 0, 0, 1, 0, 0), c(1, 1)), c(0, 0)) sos <- rbind(c(0,1,0,1,-1,0),c(1,2,1,1,-2,1)) x <- 1:10 y <- sosfilt(sos,x) expect_equal(y, c(0, 1, 7, 26, 70, 155, 301, 532, 876, 1365)) # complex input r <- sqrt (1 / 2) * (1 + 1i) sos <- rbind(c(0,1,0,1,-1,0),c(1,2,1,1,-2,1)) x <- 1:10 y <- sosfilt(sos, r * x) expect_equal(y, r * c(0, 1, 7, 26, 70, 155, 301, 532, 876, 1365)) # initial conditions sos <- rbind(c(0,1,0,1,-1,0), c(1,2,1,1,-2,1)) x1 <- 1:10 y1 <- sosfilt(sos, x1, "zf") expect_equal(y1$y, c(0, 1, 7, 26, 70, 155, 301, 532, 876, 1365)) expect_equal(y1$zf, matrix(c(55, 1980, 0, -1320), ncol = 2)) x2 <- 11:20 y2 <- sosfilt(sos, x2, y1$zf) expect_equal(y2$y, c(2035,2926,4082,5551,7385,9640,12376,15657,19551,24130)) expect_equal(y2$zf, matrix(c(210, 29260, 0, -23940), ncol = 2)) x <- 1:20 y <- sosfilt(sos, x) expect_equal(y, c(y1$y, y2$y)) # multidimensional sos <- rbind(c(0,1,0,1,-1,0), c(1,2,1,1,-2,1)) x <- cbind(1:10, 11:20) colnames(x) <- c("one", "two") y <- sosfilt(sos, x, "zf") expect_equal(y$y, cbind(one = c(0,1,7,26,70,155,301,532,876,1365), two = c(0,11,67,216,510,1005,1761,2842,4316,6255))) expect_equal(y$zf, array(c(55,1980,0,-1320,155,8580,0,-6120), c(2,2,2))) expect_equal(colnames(y$y), colnames(x)) # complex input }) # ----------------------------------------------------------------------- # fftfilt() test_that("parameters to fftfilt() are correct", { expect_error(fftfilt()) expect_error(fftfilt(1)) expect_error(fftfilt(1, 2, 3, 4)) expect_error(fftfilt(matrix(rep(1L, 4), 2), 1)) expect_error(fftfilt(2, array(rep(1L, 12), dim = c(2, 3, 2)))) expect_error(fftfilt(2, 1, matrix(rep(1L, 4), 2))) }) test_that("fftfilt() tests are correct", { b <- c(1, 1) x <- c(1L, rep(0L, 9)) res <- c(rep(1L, 2), rep(0L, 8)) expect_equal(fftfilt(b, x), res) expect_equal(fftfilt(b, replicate(2, x)), replicate(2,res)) expect_equal(fftfilt(b, replicate(2, x + 2 *.Machine$double.eps)), replicate(2,res), tolerance = tol) r <- sqrt (1/2) * (1+1i) b <- c(1, 1) * r x <- c(1L, rep(0L, 9)) res <- c(rep(1L, 2), rep(0L, 8)) expect_equal(fftfilt(b, x), r * res, tolerance = tol) expect_equal(fftfilt(b, r * x), r * r * res, tolerance = tol) b <- c(1, 1) x <- matrix(rep(0L, 30), 10, 3); x[1, 1] <--1; x[1, 2] <- 1 y0 <- matrix(rep(0L, 30), 10, 3); y0[1:2, 1] <- -1; y0[1:2, 2] <- 1 y <- fftfilt(b, x) expect_equal(y0, y) y <- fftfilt(b * 1i, x) expect_equal(y0 * 1i, y) y <- fftfilt(b, x * 1i) expect_equal(y0 * 1i, y) y <- fftfilt(b * 1i, x * 1i) expect_equal(-y0, y) x <- runif(10) y <- fftfilt(b, cbind(x, x * 1i)) expect_equal(all(abs(Im(y[, 1])) < tol), TRUE) expect_equal(all(abs(Re(y[, 2])) < tol), TRUE) b <- runif(10) x <- runif(10) y0 <- filter(b, 1, x) y <- fftfilt(b, x) expect_equal(y0, y, tolerance = tol) # Github Issue #3 b <- c(1, 1) x <- matrix(rep(0L, 30), 10, 3); x[1, 1] <--1; x[1, 2] <- 1 # y0 <- matrix(rep(0L, 30), 10, 3); y0[1:2, 1] <- -1; y0[1:2, 2] <- 1 # y <- fftfilt(b, x, n = 10) # expect_equal(y0, y) y <- matrix(rep(0L, 30), 10, 3); y[1:2, 1] <- -1; y[1:2, 2] <- 1 colnames(x) <- colnames(y) <- c("one", "two", "three") expect_equal(fftfilt(b, x, n = 10), y) expect_equal(colnames(fftfilt(b, x, n = 10)), colnames(y)) expect_equal(fftfilt(b, x[, 1], n = 10), y[, 1]) }) # ----------------------------------------------------------------------- # filter_zi() test_that("parameters to filter_zi() are correct", { expect_error(filter_zi()) expect_error(filter_zi(1)) expect_error(filter_zi(1, 2)) expect_error(filter_zi(1, 2, 3, 4, 5)) expect_error(filter_zi(0, 0, 'invalid')) }) test_that("filter_zi() tests are correct", { h <- butter(2, 0.4) l <- max(length(h$b), length(h$a)) - 1 x <- y <- rep(1, l) expect_equal(filtic(h, y, x), filter_zi(h), tolerance = tol) }) gsignal/tests/testthat/test_Transforms_Functions.R0000644000176200001440000002531514420222025022247 0ustar liggesusers# gsignal Transforms Functions library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # cplxreal() test_that("parameters to cplxreal() are correct", { expect_error(cplxreal()) expect_error(cplxreal(1, 2, 3, 4)) expect_error(cplxreal(1, matrix(1L, 2, 3))) expect_error(cplxreal(1, -1)) expect_error(cplxreal(1, dim = 3)) }) test_that("cplxreal() tests are correct", { ret <- cplxreal(1) expect_equal(length(ret$zc), 0) expect_equal(ret$zr, 1) ret <- cplxreal(c(1 + 2i, 1 - 2i)) expect_equal(ret$zc, 1 + 2i) expect_equal(length(ret$zr), 0) ret <- cplxreal(polyroot(c(1, 0, 0, 1))) expect_equal(ret$zc, complex(real = 0.5, imag = sinpi(1 / 3)), tolerance = tol) expect_equal(ret$zr, -1) # Octave signal 1.4.2: Test with 2 real zeros, one of them equal to 0 ret <- cplxreal(pracma::roots(c(1, 0, 0, 1, 0))) expect_equal(ret$zc, 0.5 + sin(pi/3) * 1i) expect_equal(ret$zr, c(-1, 0), tolerance = tol) # Octave signal 1.4.2: Test with 3 real zeros, two of them equal to 0 ret <- cplxreal(pracma::roots(c(1, 0, 0, 1, 0, 0))) expect_equal(ret$zc, 0.5 + sin (pi/3) * 1i) expect_equal(ret$zr, c(-1, 0, 0)) }) # ----------------------------------------------------------------------- # digitrevorder() test_that("parameters to digitrevorder() are correct", { expect_error(digitrevorder()) expect_error(digitrevorder(1)) expect_error(digitrevorder(1, 2, 3)) expect_error(digitrevorder(1, 1)) expect_error(digitrevorder(1, 37)) expect_error(digitrevorder(0:3, 8)) }) test_that("digitrevorder() tests are correct", { expect_equal(digitrevorder(0, 2), 0) expect_equal(digitrevorder(0, 36), 0) expect_equal(digitrevorder(0:3, 4), 0:3) expect_equal(digitrevorder(0:7, 2), c(0, 4, 2, 6, 1, 5, 3, 7)) expect_equal(digitrevorder(0:7 * 1i, 2), c(0, 4, 2, 6, 1, 5, 3, 7) * 1i) expect_equal(digitrevorder(0:15, 2), c(0, 8, 4, 12, 2, 10, 6, 14, 1, 9, 5, 13, 3, 11, 7, 15)) expect_equal(digitrevorder(0:15, 4), c(0, 4, 8, 12, 1, 5, 9, 13, 2, 6, 10, 14, 3, 7, 11, 15)) }) # ----------------------------------------------------------------------- # bitrevorder() test_that("parameters to bitrevorder() are correct", { expect_error(bitrevorder()) expect_error(bitrevorder(1, 2)) expect_error(bitrevorder(1, 2, 3)) expect_error(bitrevorder(NULL)) expect_error(bitrevorder(0:2)) }) test_that("bitrevorder() tests are correct", { expect_equal(bitrevorder(0), 0) expect_equal(bitrevorder(0:1), 0:1) expect_equal(bitrevorder(0:7), c(0, 4, 2, 6, 1, 5, 3, 7)) expect_equal(bitrevorder(0:7 * 1i), c(0, 4, 2, 6, 1, 5, 3, 7) * 1i) expect_equal(bitrevorder(0:15), c(0, 8, 4, 12, 2, 10, 6, 14, 1, 9, 5, 13, 3, 11, 7, 15)) }) # ----------------------------------------------------------------------- # fftshift() test_that("parameters to fftshift() are correct", { expect_error(fftshift()) expect_error(fftshift(1, 2, 3)) #expect_error(fftshift(matrix(1:4, 2, 2), -1)) expect_error(fftshift(NULL)) expect_error(fftshift(array(1:8, c(2, 2, 2)))) }) test_that("fftshift() tests are correct", { expect_equal(fftshift(1), 1) x <- 0:7 y <- fftshift(x) expect_equal(y, c(4, 5, 6, 7, 0, 1, 2, 3)) expect_equal(fftshift(y), x) x <- 0:6 y <- fftshift(x) expect_equal(y, c(4, 5, 6, 0, 1, 2, 3)) expect_equal(fftshift(y), c(1, 2, 3, 4, 5, 6, 0)) x <- 0:3 x <- matrix(c(x, 2 * x, 3 * x + 1, 4 * x + 1), 4, byrow = TRUE) y <- fftshift(x, 1) expect_equal(y, matrix(c(1, 4, 7, 10, 1, 5, 9, 13, 0, 1, 2, 3, 0, 2, 4, 6), 4, byrow = TRUE)) y <- fftshift(x, 2) expect_equal(y, matrix(c(2, 3, 0, 1, 4, 6, 0, 2, 7, 10, 1, 4, 9, 13, 1, 5), 4, byrow = TRUE)) y <- fftshift(x, c(1, 2)) expect_equal(y, matrix(c(7, 10, 1, 4, 9, 13, 1, 5, 2, 3, 0, 1, 4, 6, 0, 2), 4, byrow = TRUE)) }) # ----------------------------------------------------------------------- # ifftshift() test_that("parameters to ifftshift() are correct", { expect_error(ifftshift()) expect_error(ifftshift(1, 2, 3)) #expect_error(ifftshift(matrix(1:4, 2, 2), -1)) expect_error(ifftshift(NULL)) expect_error(ifftshift(array(1:8, c(2, 2, 2)))) }) test_that("ifftshift() tests are correct", { expect_equal(ifftshift(1), 1) x <- 0:7 y <- ifftshift(x) expect_equal(y, c(4, 5, 6, 7, 0, 1, 2, 3)) expect_equal(ifftshift(y), x) x <- 0:6 y <- ifftshift(x) expect_equal(y, c(3, 4, 5, 6, 0, 1, 2)) expect_equal(ifftshift(y), c(6, 0, 1, 2, 3, 4, 5)) x <- 0:3 x <- matrix(c(x, 2 * x, 3 * x + 1, 4 * x + 1), 4, byrow = TRUE) y <- ifftshift(x, 1) expect_equal(y, matrix(c(1, 4, 7, 10, 1, 5, 9, 13, 0, 1, 2, 3, 0, 2, 4, 6), 4, byrow = TRUE)) expect_equal(ifftshift(y, 1), x) y <- ifftshift(x, 2) expect_equal(y, matrix(c(2, 3, 0, 1, 4, 6, 0, 2, 7, 10, 1, 4, 9, 13, 1, 5), 4, byrow = TRUE)) expect_equal(ifftshift(y, 2), x) y <- ifftshift(x, c(1, 2)) expect_equal(y, matrix(c(7, 10, 1, 4, 9, 13, 1, 5, 2, 3, 0, 1, 4, 6, 0, 2), 4, byrow = TRUE)) expect_equal(ifftshift(y, c(1, 2)), x) }) # ----------------------------------------------------------------------- # cceps() test_that("parameters to cceps() are correct", { expect_error(cceps()) expect_error(cceps(1, 2)) expect_error(cceps(matrix(1:4, 2, 2))) expect_error(cceps(TRUE)) expect_error(cceps(1:10 * 1i)) }) test_that("cceps() tests are correct", { expect_error(cceps(rep(1L, 4))) expect_error(cceps(0)) x <- runif (256) cps <- cceps(x) expect_equal(length(x), length(cps)) }) # ----------------------------------------------------------------------- # rceps() test_that("parameters to rceps() are correct", { expect_error(rceps()) expect_error(rceps(1, 2)) expect_error(rceps(1, TRUE, 3)) expect_error(rceps(matrix(1:4, 2, 2))) expect_error(rceps(TRUE)) expect_error(rceps(1:10 * 1i)) }) test_that("rceps() tests are correct", { # Test that an odd-length input produces an odd-length output x <- runif(33) rc <- rceps(x, TRUE) expect_equal(length(rc$y), length(x)) expect_equal(length(rc$ym), length(x)) }) # ----------------------------------------------------------------------- # czt() test_that("parameters to czt() are correct", { expect_error(czt()) expect_error(czt('a')) expect_error(czt(1, -1)) expect_error(czt(1, 1, 'a')) expect_error(czt(1, 1, 1, 'a')) expect_error(czt(1, 2, 3, 4, 5)) }) test_that("czt() tests are correct", { x <- c(1, 2, 4, 1, 2, 3, 5, 2, 3, 5, 6, 7, 8, 4, 3, 6, 3, 2, 5, 1) expect_equal(stats::fft(x), czt(x), tolerance = 1e-6) expect_equal(stats::mvfft(cbind(x, x)), czt(cbind(x, x)), tolerance = 1e-6) }) # ----------------------------------------------------------------------- # dct() and idct test_that("parameters to dct() and idct() are correct", { expect_error(dct()) expect_error(dct('a')) expect_error(dct(1, -1)) expect_error(dct(1, 1, 1)) expect_error(idct()) expect_error(idct('a')) expect_error(idct(1, -1)) expect_error(idct(1, 1, 1)) }) test_that("dct() and idct() tests are correct", { # even-length series x <- c(1, 2, 4, 1, 2, 3, 5, 2, 3, 5, 6, 7, 8, 4, 3, 6, 3, 2, 5, 1) expect_equal(x, idct(dct(x))) expect_equal(cbind(x, x), idct(dct(cbind(x, x)))) #uneven-length series x <- c(1, 2, 4, 1, 2, 3, 5, 2, 3, 5, 6, 7, 8, 4, 3, 6, 3, 2, 5) expect_equal(x, idct(dct(x))) expect_equal(cbind(x, x), idct(dct(cbind(x, x)))) }) # ----------------------------------------------------------------------- # dct2() and idct2 test_that("parameters to dct2() and idct2() are correct", { expect_error(dct2()) expect_error(dct2('a')) expect_error(dct2(matrix(1:4, 2, 2), -1)) expect_error(dct2(matrix(1:4, 2, 2), 1, -1)) expect_error(dct2(1, 1, 1, 1)) expect_error(idct2()) expect_error(idct2('a')) expect_error(idct2(matrix(1:4, 2, 2), -1)) expect_error(idct2(matrix(1:4, 2, 2), 1, -1)) expect_error(idct2(1, 1, 1, 1)) }) test_that("dct2() and idct2() tests are correct", { # even-length series x <- c(1, 2, 4, 1, 2, 3, 5, 2, 3, 5, 6, 7, 8, 4, 3, 6, 3, 2, 5, 1) expect_equal(cbind(x, x), idct2(dct2(cbind(x, x)))) #uneven-length series x <- c(1, 2, 4, 1, 2, 3, 5, 2, 3, 5, 6, 7, 8, 4, 3, 6, 3, 2, 5) expect_equal(cbind(x, x), idct2(dct2(cbind(x, x)))) }) # ----------------------------------------------------------------------- # dst() and idst test_that("parameters to dst() and idst() are correct", { expect_error(dst()) expect_error(dst('a')) expect_error(dst(1, -1)) expect_error(dst(1, 1, 1)) expect_error(idst()) expect_error(idst('a')) expect_error(idst(1, -1)) expect_error(idst(1, 1, 1)) }) test_that("dst() and idst() tests are correct", { # even-length series x <- c(1, 2, 4, 1, 2, 3, 5, 2, 3, 5, 6, 7, 8, 4, 3, 6, 3, 2, 5, 1) expect_equal(x, idst(dst(x))) expect_equal(cbind(x, x), idst(dst(cbind(x, x)))) #uneven-length series x <- c(1, 2, 4, 1, 2, 3, 5, 2, 3, 5, 6, 7, 8, 4, 3, 6, 3, 2, 5) expect_equal(x, idst(dst(x))) expect_equal(cbind(x, x), idst(dst(cbind(x, x)))) }) # ----------------------------------------------------------------------- # fwht() and ifwht test_that("parameters to fwht() and ifwht() are correct", { expect_error(fwht()) expect_error(fwht('a')) expect_error(fwht(1, -1)) expect_error(fwht(1, 1, 1)) expect_error(fwht(1, 1, 'invalid')) expect_error(ifwht()) expect_error(ifwht('a')) expect_error(ifwht(1, -1)) expect_error(ifwht(1, 1, 1)) expect_error(ifwht(1, 1, 'invalid')) }) test_that("fwht() and ifwht() tests are correct", { expect_equal(fwht(rep(0L, 16)), rep(0L, 16)) expect_equal(fwht(rep(1L, 16)), c(1L, rep(0L, 15))) expect_equal(fwht(rep(0L, 17)), rep(0L, 32)) expect_equal(fwht(c(1, -1, 1, -1, 1, -1, 1, -1)), c(0, 0, 0, 0, 0, 0, 0, 1)) expect_equal(ifwht(rep(0L, 16)), rep(0L, 16)) expect_equal(ifwht(c(1L, rep(0L, 15))), rep(1L, 16)) expect_equal(ifwht(rep(0L, 17)), rep(0L, 32)) expect_equal(ifwht(c(0, 0, 0, 0, 0, 0, 0, 1)), c(1, -1, 1, -1, 1, -1, 1, -1)) x <- matrix(round(runif(256) * 100), ncol = 16) expect_equal(ifwht(fwht(x)), x) expect_equal(ifwht(fwht(x, ordering = "sequency"), ordering = "sequency"), x) expect_equal(ifwht(fwht(x, ordering = "hadamard"), ordering = "hadamard"), x) expect_equal(ifwht(fwht(x, ordering = "dyadic"), ordering = "dyadic"), x) }) # ----------------------------------------------------------------------- # hilbert() test_that("parameters to hilbert() are correct", { expect_error(hilbert()) expect_error(hilbert('a')) expect_warning(hilbert(1 + 1i)) expect_error(hilbert(1, 'a')) expect_error(hilbert(1, -1)) }) test_that("hilbert() tests are correct", { x <- 1:4 i <- c(1, -1, -1, 1) expect_equal(Re(hilbert(x)), x) expect_equal(Im(hilbert(x)), i) # test with small numbers (Github bug #4) expect_equal(Re(hilbert(1e-12 * x)), 1e-12 * x) expect_equal(Im(hilbert(1e-12 * x)), 1e-12 * i) }) gsignal/tests/testthat/test_Utility_Functions.R0000644000176200001440000001305214420222025021547 0ustar liggesusers# gsignal Utility Functions library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # fracshift() test_that("parameters to fracshift() are correct", { expect_error(fracshift()) expect_error(fracshift('invalid')) expect_error(fracshift(array())) expect_error(fracshift(1:10, c(1, 1))) expect_error(fracshift(1:10, 'invalid')) expect_error(fracshift(1:10, 7, 'invalid')) }) test_that("fracshift() tests are correct", { N <- 1024 p <- 6 q <- 7 d1 <- 64 d2 <- d1 * p/q t <- 128 ba <- butter (10, .25) n <- rep(0, N) n[N / 2 + (-t:t)] <- rnorm(2 * t + 1) n <- filter(ba, n) n1 <- fracshift(n, d1) n1 <- resample(n1, p, q) n2 <- resample(n, p, q) n2 <- fracshift(n2, d2) err <- abs(n2 - n1) expect_equal(max(err), 0, tolerance = 1e-3) # test #integer shift similar similar to non-integer N <- 1024 t <- seq(0, 1, length.out = N) x <- exp(-t^2 / 2 / 0.25^2) * sin(2 * pi * 10 * t) d <- 10 y <- fracshift(x, as.integer(d)) yh <- fracshift(x, as.double(d) + tol) expect_equal(y, yh, tolerance = tol) # test Octave bug #52758 x <- c(0, 1, 0, 0, 0, 0, 0, 0) y <- fracshift(x, 1) expect_equal(length(x), length(y)) }) # ----------------------------------------------------------------------- # clustersegment() test_that("parameters to clustersegment() are correct", { expect_error(clustersegment()) expect_error(clustersegment('invalid')) expect_error(clustersegment(array())) expect_error(clustersegment(1, 2)) }) test_that("clustersegment() tests are correct", { x <- rep(0L, 5) rng <- clustersegment(x) expect_equal(rng, matrix(NA, 1)) x <- rep(10L, 5) rng <- clustersegment(x) expect_equal(rng, matrix(NA, 1)) x <- c(rep(0L, 5), 2) rng <- clustersegment(x) expect_equal(rng, matrix(c(6, 6), nrow = 2)) x <- c(2, rep(0L, 5)) rng <- clustersegment(x) expect_equal(rng, matrix(c(1, 1), nrow = 2)) x <- matrix(c(1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 1, 0), nrow = 3, byrow = TRUE) rng <- clustersegment(x) expect_equal(rng[[1]], matrix(c(1, 3, 6, 10), nrow = 2)) expect_equal(rng[[2]], matrix(c(1, 3, 5, 5, 8, 10), nrow = 2)) expect_equal(rng[[3]], matrix(c(1, 1, 9, 9), nrow = 2)) }) # ----------------------------------------------------------------------- # schtrig() test_that("parameters to schtrig() are correct", { expect_error(schtrig()) expect_error(schtrig('invalid')) expect_error(schtrig(array())) expect_error(schtrig(1, 2, 3, 4)) }) test_that("schtrig() tests are correct", { x <- c(0, 0.5, 1, 1.5, 2, 1.5, 1.5, 1.2, 1, 0, 0) y <- schtrig(x, c(1.3, 1.6)) expect_equal(y$v, c(0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0)) expect_equal(y$rng, matrix(c(4, 4, 6, 7), nrow = 2)) expect_equal(y$st, 0) x <- c(0, 0.5, 1, 1.5, 2, 1.5, 1.5, 1.2, 1, 0, 0) y <- schtrig(x, c(1.3, 1.6, 1.8)) expect_equal(y$v, c(0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0)) expect_equal(y$rng, matrix(NA, nrow = 1)) expect_equal(y$st, 0) expect_equal(schtrig(x, c(1.3, 1.6)), schtrig(x, c(1.3, 1.6, 1.3))) }) # ----------------------------------------------------------------------- # upsamplefill() test_that("parameters to upsamplefill() are correct", { expect_error(upsamplefill()) expect_error(upsamplefill('invalid')) expect_error(upsamplefill(array())) expect_error(upsamplefill(1, 'invalid')) expect_error(upsamplefill(1, -1, 'invalid')) expect_error(upsamplefill(1, -1, TRUE)) expect_error(upsamplefill(1, 2, 3, 4)) }) test_that("upsamplefill() tests are correct", { expect_equal(upsamplefill(c(1, 3, 5), 2), c(1, 2, 3, 2, 5, 2)) expect_equal(upsamplefill(c(1, 2, 5), c(2, -2)), c(1, 2, -2, 2, 2, -2, 5, 2, -2)) expect_equal(upsamplefill(diag(2), 2, TRUE), matrix(c(rep(1, 3), rep(0, 6), rep(1, 3)), ncol = 2)) expect_equal(upsamplefill(c(1, 3, 5), 2, TRUE), c(1, 1, 1, 3, 3, 3, 5, 5, 5)) }) # ----------------------------------------------------------------------- # wkeep() test_that("parameters to wkeep() are correct", { expect_error(wkeep()) expect_error(wkeep('invalid')) expect_error(wkeep(1, 'invalid')) expect_error(wkeep(1, 1, 'invalid')) expect_error(wkeep(1, -1, 'invalid')) expect_error(wkeep(1:10, 11)) expect_error(wkeep(1:10, 6, 7)) expect_error(wkeep(1:10, 6, -1)) expect_error(wkeep(matrix(1:10), 1)) expect_error(wkeep(matrix(1:10), c(1,2), 1)) expect_error(wkeep(1, 2, 3, 4)) }) test_that("wkeep() tests are correct", { expect_equal(wkeep(1:10, 2), c(5, 6)) expect_equal(wkeep(1:10, 2, "l"), c(1, 2)) expect_equal(wkeep(1:10, 2, "r"), c(9, 10)) m <- matrix(c(17, 23, 4, 10, 11, 24, 5, 6, 12, 18, 1, 7, 13, 19, 25, 8, 14, 20, 21, 2, 15, 16, 22, 3, 9 ), 5, 5) expect_equal(wkeep(m, c(3, 2)), matrix(c(5, 6, 12, 7, 13, 19), 3)) expect_equal(wkeep(m, c(2, 4), c(3, 1)), matrix(c(4, 10, 6, 12, 13, 19, 20, 21), 2)) }) # ----------------------------------------------------------------------- # zerocrossing() test_that("parameters to zerocrossing() are correct", { expect_error(zerocrossing()) expect_error(zerocrossing(1)) expect_error(zerocrossing('invalid', 1)) expect_error(zerocrossing(1, 'invalid')) expect_error(zerocrossing(1:2, 1:3)) expect_error(zerocrossing(1, 1, 3)) }) test_that("zerocrossing() tests are correct", { x <- 1:10 y <- sawtooth(x) expect_equal(floor(zerocrossing(x, y)), c(3, 6, 9)) y <- sin(x) expect_equal(floor(zerocrossing(x, y)), c(3, 6, 9)) y <- cos(x) expect_equal(floor(zerocrossing(x, y)), c(1, 4, 7)) }) gsignal/tests/testthat/test_Correlation_and_Convolution_Functions.R0000644000176200001440000001502114420222025025604 0ustar liggesusers# gsignal Standard Functions library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # cconv() test_that("parameters to cconv() are correct", { expect_error(cconv()) expect_error(cconv('invalid')) expect_error(cconv(1, 1, c(1,1))) expect_error(cconv(1, 1, -1)) expect_error(cconv(1, 1, 'invalid')) }) test_that("cconv() tests are correct", { x <- 1:5 expect_equal(cconv(x, 1), 1:5) expect_equal(cconv(x, c(1, 1)), c(1, 3, 5, 7, 9, 5)) expect_equal(cconv(x, c(1, 1), 3), c(8, 12, 10)) expect_equal(cconv(c(2, 1, 2, 1), c(1, 2, 3, 4)), c(2, 5, 10, 16, 12, 11, 4)) expect_equal(cconv(c(2, 1, 2, 1), c(1, 2, 3, 4), 4), c(14, 16, 14, 16)) expect_equal(cconv(c(2, 1, 2, 1), c(1, 2, 3, 4), 3), c(22, 17, 21)) expect_equal(cconv(c(2, 1, 2, 1), c(1, 2, 3, 4), 2), c(28, 32)) expect_equal(cconv(c(2, 1, 2, 1), c(1, 2, 3, 4), 1), 60) expect_equal(cconv(x*1i, 1), c(0+1i, 0+2i, 0+3i, 0+4i, 0+5i)) }) # ----------------------------------------------------------------------- # convmtx() test_that("parameters to convmtx() are correct", { expect_error(convmtx()) expect_error(convmtx(1, 'invalid')) expect_error(convmtx(1, -1)) }) test_that("convmtx() tests are correct", { expect_equal(convmtx(c(3, 4, 5), 3), matrix(c(3,4,5,0,0,0,3,4,5,0,0,0,3,4,5), 5, 3)) }) # ----------------------------------------------------------------------- # wconv() test_that("parameters to wconv() are correct", { expect_error(wconv()) expect_error(wconv('invalid')) expect_error(wconv(1, -1)) expect_error(wconv('1', -1)) expect_error(wconv('1', 1:5, 1:2, 'invalid')) }) test_that("wconv() tests are correct", { a <- matrix(1:16, 4, 4) b <- matrix(1:9, 3,3) expect_equal(wconv('2', a, b), matrix(c(1,4,10,16,17,12,9,29,62,83,75,48,36,99,192,237,198,120,84,207, 372,417,330,192,115,263,446,485,365,204,91,202,334,358,263,144), 6,6)) expect_equal(wconv('1', a, b, 'same'), c(35,56,84,120,165,210,255,300,345,390,435,480,508,518,509,480)) expect_equal(wconv('r', a, b), matrix(c(1,2,3,4,7,10,13,16,22,28,34,40,50,60,70,80,78,92,106,120, 106,124,142,160,134,156,178,200,162,188,214,240,190,220,250, 280,208,232,256,280,185,202,219,236,117,126,135,144), 4, 12)) expect_equal(wconv('r', a, c(0,1), 'same'), matrix(1:16, 4, 4)) expect_equal(wconv('c', a, c(0,1), 'valid'), matrix(c(1:3,5:7,9:11,13:15), 3, 4)) }) # ----------------------------------------------------------------------- # xcorr() test_that("parameters to xcorr() are correct", { expect_error(xcorr()) expect_error(xcorr('invalid')) expect_error(xcorr(array(1:12, dim = c(2, 2, 3)))) expect_error(xcorr(1, 'invalid')) expect_error(xcorr(1, array(1:12, dim = c(2, 2, 3)))) expect_error(xcorr(1, -1, maglag = -1)) expect_error(xcorr(matrix(1:9, 3, 3), 1)) expect_error(xcorr(1, -1, scale = 'invalid')) expect_error(xcorr(1:10, 1:10, 2, 'none', 'extra')) }) test_that("xcorr() tests are correct", { rl <- xcorr(1, -1) expect_equal(rl$R, -1) expect_equal(rl$lags, 0) rl <- xcorr(c(1, 2)) expect_equal(rl$R, c(2, 5, 2)) expect_equal(rl$lags, c(-1, 0, 1)) rl <- xcorr(1:10, 1:10, 2, 'none') expect_equal(rl$R, c(276, 330, 385, 330, 276)) expect_equal(rl$lags, -2:2) rl <- xcorr(1:10, 1:10, 2, 'biased') expect_equal(rl$R, c(27.6, 33.0, 38.5, 33.0, 27.6)) expect_equal(rl$lags, -2:2) rl <- xcorr(1:10, 1:10, 2, 'unbiased') expect_equal(rl$R, c(34.5, 36.666667, 38.5, 36.666667, 34.5)) expect_equal(rl$lags, -2:2) rl <- xcorr(1:10, 1:10, 2, 'coeff') expect_equal(rl$R, c(0.7168831, 0.8571429, 1.0000000, 0.8571429, 0.7168831), tolerance = tol) expect_equal(rl$lags, -2:2) }) # ----------------------------------------------------------------------- # xcorr2() test_that("parameters to xcorr2() are correct", { expect_error(xcorr2()) expect_error(xcorr2('invalid')) expect_error(xcorr2(array(1:12, dim = c(2, 2, 3)))) expect_error(xcorr2(1, 'invalid')) expect_error(xcorr2(1, array(1:12, dim = c(2, 2, 3)))) expect_error(xcorr2(1, -1)) expect_error(xcorr2(matrix(1:9, 3, 3), 1)) expect_error(xcorr2(matrix(1:9, 3, 3), scale = 'invalid')) expect_error(xcorr2(matrix(1:9, 3, 3), matrix(1:9, 3, 3), 'none', 'extra')) }) test_that("xcorr2() tests are correct", { a <- pracma::magic(3) b <- matrix(c(6, 13, 10, 18), 2, 2) R <- matrix(c(144,122,121, 78, 134,187,257,127, 102,282,253, 68, 40,114, 74, 12), 4, 4, byrow = TRUE) expect_equal(xcorr2(a, b, 'none'), R) expect_equal(xcorr2(a, b, 'biased'), R / 4) expect_equal(xcorr2(a, b, 'unbiased'), R / matrix(c(1,2,2,1,2,4,4,2,2,4,4,2,1,2,2,1), 4, 4)) Rc <- matrix(c(0.71771, 0.60336, 0.79316, 0.51834, 0.62534, 0.74937, 0.97263, 0.54925, 0.81340, 0.98240, 0.80001, 0.37243, 0.39873, 0.46152, 0.32003, 0.23924), 4, 4, byrow = TRUE) expect_equal(xcorr2(a, b, 'coeff'), Rc, tolerance = 1e-5) row_shift <- 18 col_shift <- 20 a <- matrix(runif(900, 1, 255), 30, 30) b <- a[(row_shift - 10):row_shift, (col_shift - 7):col_shift] R <- xcorr2(a, b, "coeff") expect_equal(as.vector(which(R == max(R), arr.ind = TRUE)), c(row_shift, col_shift)) }) # ----------------------------------------------------------------------- # xcov() test_that("parameters to xcov() are correct", { expect_error(xcov()) expect_error(xcov('invalid')) expect_error(xcov(array(1:12, dim = c(2, 2, 3)))) expect_error(xcov(1, 'invalid')) expect_error(xcov(1, array(1:12, dim = c(2, 2, 3)))) expect_error(xcov(1, -1, maglag = -1)) expect_error(xcov(matrix(1:9, 3, 3), 1)) expect_error(xcov(1, -1, scale = 'invalid')) expect_error(xcov(1:10, 1:10, 2, 'none', 'extra')) }) test_that("xcov() tests are correct", { cl <- xcov(1, -1) expect_equal(cl$C, 0) expect_equal(cl$lags, 0) cl <- xcov(c(1, 2)) expect_equal(cl$C, c(-0.25, 0.50, -0.25)) expect_equal(cl$lags, c(-1, 0, 1)) cl <- xcov(1:10, 1:10, 2, 'none') expect_equal(cl$C, c(34, 57.75, 82.50, 57.75, 34)) expect_equal(cl$lags, -2:2) cl <- xcov(1:10, 1:10, 2, 'biased') expect_equal(cl$C, c(3.4, 5.775, 8.25, 5.775, 3.4)) expect_equal(cl$lags, -2:2) cl <- xcov(1:10, 1:10, 2, 'unbiased') expect_equal(cl$C, c(4.25, 6.4167, 8.25, 6.4167, 4.25), tolerance = 1e-5) expect_equal(cl$lags, -2:2) cl <- xcov(1:10, 1:10, 2, 'coeff') expect_equal(cl$C, c(0.4121212, 0.7, 1, 0.7, 0.4121212), tolerance = tol) expect_equal(cl$lags, -2:2) }) gsignal/tests/testthat/test_Window_Functions.R0000644000176200001440000003261714525417770021406 0ustar liggesusers# gsignal Window functions library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # bartlett() test_that("parameters to bartlett() are correct", { expect_error(bartlett()) expect_error(bartlett(0.5)) expect_error(bartlett(-1L)) expect_error(bartlett(array(1L, c(1, 4)))) }) test_that("bartlett() tests are correct", { expect_equal(bartlett(1), 1L) expect_equal(bartlett(2), c(0, 0)) expect_equal(rev(bartlett(15)), bartlett(15)) expect_equal(rev(bartlett(16)), bartlett(16)) N <- 9 A <- bartlett(N) expect_equal(A[ceiling(N / 2)], 1L) }) # ----------------------------------------------------------------------- # hamming() test_that("parameters to hamming() are correct", { expect_error(hamming()) expect_error(hamming(0.5)) expect_error(hamming(-1L)) expect_error(hamming(array(1L, c(1, 4)))) expect_error(hamming(1, 'invalid')) }) test_that("hamming() tests are correct", { expect_equal(hamming(1), 1L) expect_equal(hamming(2), 0.54 - 0.46 * rep(1L, 2), tolerance = tol) expect_equal(rev(hamming(15)), hamming(15)) expect_equal(rev(hamming(16)), hamming(16)) N <- 15 A <- hamming(N) expect_equal(A[ceiling(N / 2)], 1L) expect_equal(hamming(15), hamming(15, 'symmetric'), tolerance = tol) expect_equal(hamming(16)[1:15], hamming(15, 'periodic'), tolerance = tol) N <- 16 A <- hamming(N, 'periodic') expect_equal(A[N / 2 + 1], 1L) }) # ----------------------------------------------------------------------- # hann() test_that("parameters to hann() are correct", { expect_error(hann()) expect_error(hann(0.5)) expect_error(hann(-1L)) expect_error(hann(array(1L, c(1, 4)))) expect_error(hann(1, 'invalid')) }) test_that("hann() tests are correct", { expect_equal(hann(1), 1L) expect_equal(hann(2), 0.5 - 0.5 * rep(1L, 2)) expect_equal(rev(hann(15)), hann(15)) expect_equal(rev(hann(16)), hann(16)) N <- 15 A <- hann(N) expect_equal(A[ceiling(N / 2)], 1L) expect_equal(hann(15), hann(15, 'symmetric'), tolerance = tol) expect_equal(hann(16)[1:15], hann(15, 'periodic'), tolerance = tol) N <- 16 A <- hann(N, 'periodic') expect_equal(A[N / 2 + 1], 1L) }) # ----------------------------------------------------------------------- # triang() test_that("parameters to triang() are correct", { expect_error(triang()) expect_error(triang(0.5)) expect_error(triang(-1L)) expect_error(triang(array(1L, c(1, 4)))) }) test_that("triang() tests are correct", { expect_equal(triang(1), 1L) expect_equal(triang(2), c(1, 1) / 2) expect_equal(triang(3), c(1, 2, 1) / 2) expect_equal(triang(4), c(1, 3, 3, 1) / 4) x <- bartlett(5) expect_equal(triang(3), x[2:4]) }) # ----------------------------------------------------------------------- # blackman() test_that("parameters to blackman() are correct", { expect_error(blackman()) expect_error(blackman(0.5)) expect_error(blackman(-1L)) expect_error(blackman(array(1L, c(1, 4)))) expect_error(blackman(1, 'invalid')) }) test_that("blackman() tests are correct", { expect_equal(blackman(1), 1L) expect_equal(blackman(2), c(0, 0)) expect_equal(rev(blackman(15)), blackman(15)) expect_equal(rev(blackman(16)), blackman(16)) N <- 9 A <- blackman(N) expect_equal(A[ceiling(N / 2)], 1L) expect_equal(blackman(15), blackman(15, 'symmetric'), tolerance = tol) expect_equal(blackman(16)[1:15], blackman(15, 'periodic'), tolerance = tol) N <- 16 A <- blackman(N, 'periodic') expect_equal(A[N / 2 + 1], 1L) }) # ----------------------------------------------------------------------- # barthannwin() test_that("parameters to barthannwin() are correct", { expect_error(barthannwin()) expect_error(barthannwin(0.5)) expect_error(barthannwin(-1L)) expect_error(barthannwin(array(1L, c(1, 4)))) expect_error(barthannwin(1, 2)) }) test_that("barthannwin() tests are correct", { expect_equal(barthannwin(1), 1L) expect_equal(barthannwin(2), c(0, 0)) expect_equal(rev(barthannwin(15)), barthannwin(15)) expect_equal(rev(barthannwin(16)), barthannwin(16)) }) # ----------------------------------------------------------------------- # blackmanharris() test_that("parameters to blackmanharris() are correct", { expect_error(blackmanharris()) expect_error(blackmanharris(0.5)) expect_error(blackmanharris(-1L)) expect_error(blackmanharris(array(1L, c(1, 4)))) expect_error(blackmanharris(1, 'invalid')) }) test_that("blackmanharris() tests are correct", { expect_equal(blackmanharris(1), 1L) expect_equal(blackmanharris(2), c(6e-5, 6e-5)) expect_equal(rev(blackmanharris(15)), blackmanharris(15)) expect_equal(rev(blackmanharris(16)), blackmanharris(16)) expect_equal(blackmanharris(15), blackmanharris(15, 'symmetric'), tolerance = tol) expect_equal(blackmanharris(16)[1:15], blackmanharris(15, 'periodic'), tolerance = tol) }) # ----------------------------------------------------------------------- # blackmannuttall() test_that("parameters to blackmannuttall() are correct", { expect_error(blackmannuttall()) expect_error(blackmannuttall(0.5)) expect_error(blackmannuttall(-1L)) expect_error(blackmannuttall(array(1L, c(1, 4)))) expect_error(blackmannuttall(1, 'invalid')) }) test_that("blackmannuttall() tests are correct", { expect_equal(blackmannuttall(1), 1L) expect_equal(blackmannuttall(2), c(0.0003628, 0.0003628), , tolerance = tol) expect_equal(rev(blackmannuttall(15)), blackmannuttall(15)) expect_equal(rev(blackmannuttall(16)), blackmannuttall(16)) expect_equal(blackmannuttall(15), blackmannuttall(15, 'symmetric'), tolerance = tol) expect_equal(blackmannuttall(16)[1:15], blackmannuttall(15, 'periodic'), tolerance = tol) }) # ----------------------------------------------------------------------- # barthannwin() test_that("parameters to barthannwin() are correct", { expect_error(barthannwin()) expect_error(barthannwin(0.5)) expect_error(barthannwin(-1L)) expect_error(barthannwin(array(1L, c(1, 4)))) expect_error(barthannwin(1, 2)) }) test_that("barthannwin() tests are correct", { expect_equal(barthannwin(1), 1L) expect_equal(barthannwin(2), c(0, 0)) expect_equal(rev(barthannwin(15)), barthannwin(15)) expect_equal(rev(barthannwin(16)), barthannwin(16)) }) # ----------------------------------------------------------------------- # bohmanwin() test_that("parameters to bohmanwin() are correct", { expect_error(bohmanwin()) expect_error(bohmanwin(0.5)) expect_error(bohmanwin(-1L)) expect_error(bohmanwin(array(1L, c(1, 4)))) expect_error(bohmanwin(1, 2)) }) test_that("bohmanwin() tests are correct", { expect_equal(bohmanwin(1), 1L) expect_equal(bohmanwin(2), rep(0, 2)) expect_equal(rev(bohmanwin(15)), bohmanwin(15)) expect_equal(rev(bohmanwin(16)), bohmanwin(16)) expect_equal(bohmanwin(15)[1], 0L) expect_equal(bohmanwin(15)[15], 0L) }) # ----------------------------------------------------------------------- # boxcar() test_that("parameters to boxcar() are correct", { expect_error(boxcar()) expect_error(boxcar(0.5)) expect_error(boxcar(-1L)) expect_error(boxcar(array(1L, c(1, 4)))) expect_error(boxcar(1, 2)) }) test_that("boxcar() tests are correct", { expect_equal(boxcar(1), 1L) expect_equal(boxcar(2), rep(1L, 2)) expect_equal(rev(boxcar(100)), rep(1L, 100)) }) # ----------------------------------------------------------------------- # chebwin() test_that("parameters to chebwin() are correct", { expect_error(chebwin()) expect_error(chabwin(0.5)) expect_error(chebwin(-1L)) expect_error(chebwin(array(1L, c(1, 4)))) }) test_that("chebwin() tests are correct", { expect_equal(chebwin(1), 1L) expect_equal(chebwin(2), rep(1L, 2)) expect_equal(rev(chebwin(15)), chebwin(15)) expect_equal(rev(chebwin(16)), chebwin(16)) }) # ----------------------------------------------------------------------- # flattopwin() test_that("parameters to flattopwin() are correct", { expect_error(flattopwin()) expect_error(flattopwin(0.5)) expect_error(flattopwin(-1L)) expect_error(flattopwin(array(1L, c(1, 4)))) expect_error(flattopwin(1, 'invalid')) }) test_that("flattopwin() tests are correct", { expect_equal(flattopwin(1), 1L) expect_equal(flattopwin(2), 0.0042 / 4.6402 * rep(1L, 2), tolerance = tol) expect_equal(rev(flattopwin(15)), flattopwin(15)) expect_equal(rev(flattopwin(16)), flattopwin(16)) expect_equal(flattopwin(15), flattopwin(15, 'symmetric'), tolerance = tol) expect_equal(flattopwin(16)[1:15], flattopwin(15, 'periodic'), tolerance = tol) }) # ----------------------------------------------------------------------- # gaussian() test_that("parameters to gaussian() are correct", { expect_error(gaussian()) expect_error(gaussian(0.5)) expect_error(gaussian(-1L)) expect_error(gaussian(array(1L, c(1, 4)))) expect_error(gaussian(1, 2, 3)) }) test_that("gaussian() tests are correct", { expect_equal(gaussian(1), 1L) expect_equal(rev(gaussian(15)), gaussian(15)) expect_equal(rev(gaussian(16)), gaussian(16)) }) # ----------------------------------------------------------------------- # gausswin() test_that("parameters to gausswin() are correct", { expect_error(gausswin()) expect_error(gausswin(0.5)) expect_error(gausswin(-1L)) expect_error(gausswin(array(1L, c(1, 4)))) expect_error(gausswin(1, 2, 3)) }) test_that("gausswin() tests are correct", { expect_equal(gausswin(1), 1) expect_equal(gausswin(2), c(exp(-3.125), exp(-3.125)), tolerance = tol) expect_equal(gausswin(3), c(exp(-3.125), 1, exp(-3.125)), tolerance = tol) expect_equal(rev(gausswin(15)), gausswin(15)) expect_equal(rev(gausswin(16)), gausswin(16)) }) # ----------------------------------------------------------------------- # kaiser() test_that("parameters to kaiser() are correct", { expect_error(kaiser()) expect_error(kaiser(0.5)) expect_error(kaiser(-1L)) expect_error(kaiser(array(1L, c(1, 4)))) expect_error(kaiser(1, 2, 3)) }) test_that("kaiser() tests are correct", { expect_equal(kaiser(1), 1) expect_equal(round(kaiser(2), 4), rep(0.9403, 2)) expect_equal(rev(kaiser(15)), kaiser(15)) expect_equal(rev(kaiser(16)), kaiser(16)) }) # ----------------------------------------------------------------------- # nuttallwin() test_that("parameters to nuttallwin() are correct", { expect_error(nuttallwin()) expect_error(nuttallwin(0.5)) expect_error(nuttallwin(-1L)) expect_error(nuttallwin(array(1L, c(1, 4)))) expect_error(nuttallwin(1, 2)) expect_error(nuttallwin(1, 'invalid')) }) test_that("nuttallwin() tests are correct", { expect_equal(nuttallwin(1), 1L) expect_equal(nuttallwin(2), c(0, 0)) expect_equal(rev(nuttallwin(15)), nuttallwin(15)) expect_equal(rev(nuttallwin(16)), nuttallwin(16)) expect_equal(nuttallwin(15), nuttallwin(15, 'symmetric'), tolerance = tol) expect_equal(nuttallwin(16)[1:15], nuttallwin(15, 'periodic'), tolerance = tol) }) # ----------------------------------------------------------------------- # parzenwin() test_that("parameters to parzenwin() are correct", { expect_error(parzenwin()) expect_error(parzenwin(0.5)) expect_error(parzenwin(-1L)) expect_error(parzenwin(array(1L, c(1, 4)))) expect_error(parzenwin(1, 2)) }) test_that("parzenwin() tests are correct", { expect_equal(parzenwin(1), 1L) expect_equal(parzenwin(2), 0.25 * rep(1, 2)) expect_equal(rev(parzenwin(15)), parzenwin(15)) expect_equal(rev(parzenwin(16)), parzenwin(16)) }) # ----------------------------------------------------------------------- # rectwin() test_that("parameters to rectwin() are correct", { expect_error(rectwin()) expect_error(rectwin(0.5)) expect_error(rectwin(-1L)) expect_error(rectwin(array(1L, c(1, 4)))) expect_error(rectwin(1, 2)) }) test_that("rectwin() tests are correct", { expect_equal(rectwin(1), 1L) expect_equal(rectwin(2), rep(1L, 2)) expect_equal(rev(rectwin(100)), rep(1L, 100)) }) # ----------------------------------------------------------------------- # tukeywin() test_that("parameters to tukeywin() are correct", { expect_error(tukeywin()) expect_error(tukeywin(0.5)) expect_error(tukeywin(-1L)) expect_error(tukeywin(array(1L, c(1, 4)))) expect_error(tukeywin(1, 2, 3)) }) test_that("tukeywin() tests are correct", { expect_equal(tukeywin(1, 0), 1L) expect_equal(tukeywin(1, 1), 1L) expect_equal(tukeywin(2, 0), rep(1L, 2)) expect_equal(tukeywin(2, 1), rep(0L, 2)) expect_equal(tukeywin(3, 0), rep(1L, 3)) expect_equal(tukeywin(3, 1), c(0, 1, 0)) expect_equal(tukeywin(4, 0), rep(1L, 4)) expect_equal(tukeywin(4, 1), c(0, 0.75, 0.75, 0)) expect_equal(tukeywin(5, 0), rep(1L, 5)) expect_equal(tukeywin(5, 1), c(0, 0.5, 1, 0.5, 0)) expect_equal(tukeywin(16, 0), rectwin(16)) expect_equal(tukeywin(16, 1), hann(16), tolerance = tol) }) # ----------------------------------------------------------------------- # welchwin() test_that("parameters to welchwin() are correct", { expect_error(welchwin()) expect_error(welchwin(0.5)) expect_error(welchwin(1)) expect_error(welchwin(2, "symmatric")) expect_error(welchwin(-1L)) expect_error(welchwin(array(1L, c(1, 4)))) expect_error(welchwin(1, 'invalid')) }) test_that("welchwin() tests are correct", { expect_equal(welchwin(2, 'periodic'), c(0,1)) expect_equal(welchwin(3, 'symmetric'), c(0, 1, 0)) expect_equal(rev(welchwin(15)), welchwin(15)) expect_equal(rev(welchwin(16)), welchwin(16)) expect_equal(welchwin(15), welchwin(15, 'symmetric'), tolerance = tol) expect_equal(welchwin(16)[1:15], welchwin(15, 'periodic'), tolerance = tol) }) gsignal/tests/testthat/test_FIR_Filter_Design_Functions.R0000644000176200001440000001165314420222025023327 0ustar liggesusers# gsignal filtering functions library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # sgolay() test_that("parameters to sgolay() are correct", { expect_error(sgolay()) expect_error(sgolay(-1)) expect_error(sgolay(0.5)) expect_error(sgolay(1)) expect_error(sgolay(1, -1)) expect_error(sgolay(1, 0.5)) expect_error(sgolay(1, 2)) expect_error(sgolay(1, 2, 3, 4, 5)) }) test_that("sgolay() tests are correct", { N <- 2^12 t <- seq(0, N-1) / N dt <- t[2] - t[1] w <- 2 * pi * 50 offset <- 0.5 # 50 Hz carrier # exponential modulation and its derivatives d <- 1 + exp(-3 * (t - offset)) dd <- -3 * exp(-3 * (t - offset)) d2d <- 9 * exp(-3 * (t - offset)) d3d <- -27 * exp(-3 * (t -offset)) # modulated carrier and its derivatives x <- d * sin(w * t) dx <- dd * sin(w * t) + w * d * cos(w * t) d2x <- (d2d - w^2 * d) * sin(w * t) + 2 * w * dd * cos(w * t) d3x <- (d3d - 3 * w^2 * dd) * sin(w * t) + (3 * w * d2d - w^3 * d) * cos(w * t) y <- sgolayfilt(x, sgolay(8, 41, 0, dt)) expect_equal(norm(y - x, '2') / norm(x, '2'), 0, tolerance = 5e-6) y <- sgolayfilt(x, sgolay(8, 41, 1, dt)) expect_equal(norm(y - dx, '2') / norm(dx, '2'), 0, tolerance = 5e-6) y <- sgolayfilt(x,sgolay(8, 41, 2, dt)) expect_equal(norm(y - d2x, '2') / norm(d2x, '2'), 0, tolerance = 1e-5) y <- sgolayfilt(x, sgolay(8, 41, 3, dt)) expect_equal(norm(y - d3x, '2') / norm(d3x, '2'), 0, tolerance = 1e-4) }) # ----------------------------------------------------------------------- # fir2() test_that("parameters to fir2() are correct", { expect_error(fir2()) expect_error(fir2(-1)) expect_error(fir2(0.5)) expect_error(fir2(1)) expect_error(fir2(1, -1)) expect_error(fir2(1, 0.5)) expect_error(fir2(1, 2)) expect_error(fir2(1, c(0,1), c(1,0), 4, 5, hamming(-1))) expect_error(fir2(1, c(0,1), c(1,0), 4, 5, hamming(1), 7)) }) test_that("fir2() tests are correct", { # Test that the grid size is rounded up to the next power of 2 f <- c(0, 0.6, 0.6, 1); m <- c(1, 1, 0, 0) b9 <- fir2 (30, f, m, 9) b16 <- fir2 (30, f, m, 16) b17 <- fir2 (30, f, m, 17) b32 <- fir2 (30, f, m, 32) expect_equal(b9, b16, tolerance = tol) expect_equal(b17, b32, tolerance = tol) expect_false(isTRUE(all.equal(b16, b17, tolerance = tol))) # Test expected magnitudes of passbands, stopbands, and cutoff frequencies f <- c(0, 0.7, 0.7, 1); m <- c(0, 0, 1, 1) b <- fir2 (50, f, m) h <- abs(freqz (b, c(0, 0.7, 1), fs = 2)$h) expect_lte(h[1], 3e-3) expect_lte(h[2], 1 / sqrt(2)) expect_equal(h[3], 1, tolerance = 2e-3) f <- c(0, 0.25, 0.25, 0.75, 0.75, 1); m <- c(0, 0, 1, 1, 0, 0) b <- fir2 (50, f, m) h <- abs (freqz (b, c(0, 0.25, 0.5, 0.75, 1), fs = 2)$h) expect_lte(h[1], 3e-3) expect_lte(h[2], 1 / sqrt(2)) expect_equal(h[3], 1, tolerance = 2e-3) expect_lte(h[4], 1 / sqrt (2)) expect_lte(h[5], 3e-3) f <- c(0, 0.45, 0.45, 0.55, 0.55, 1); m <- c(1, 1, 0, 0, 1, 1) b <- fir2 (50, f, m) h <- abs (freqz (b, c(0, 0.45, 0.5, 0.55, 1), fs = 2)$h) expect_equal(h[1], 1, tolerance = 2e-3) expect_lte(h[2], 1 / sqrt(2)) expect_equal(h[3], 1e-1, tolerance = 2e-2) expect_lte(h[4], 1 / sqrt (2)) expect_equal(h[5], 1, tolerance = 2e-3) }) # ----------------------------------------------------------------------- # fir1() test_that("parameters to fir1() are correct", { expect_error(fir1()) expect_error(fir1(-1)) expect_error(fir1(0.5)) expect_error(fir1(1)) expect_error(fir1(1, -1)) expect_error(fir1(1, 2)) expect_error(fir1(1, 0.5, 'invalid')) expect_error(fir1(1, 0.5, "low", 'invalid(1)')) expect_error(fir1(1, 0.5, "low", hamming(2), 'invalid')) expect_error(fir1(1, 0.5, "low", hamming(2), 'scale', 6)) }) test_that("fir1() tests are correct", { b <- fir1(30, 0.3) h <- abs (freqz (b, c(0, 0.3, 1), fs = 2)$h) expect_equal(h[1], 1, tolerance = 1e-2) expect_true(all(h[2:3] <= 1 / sqrt(2))) b <- fir1(30, 0.7, "high") h <- abs (freqz (b, c(0, 0.7, 1), fs = 2)$h) expect_equal(h[3], 1, tolerance = 1e-2) expect_true(all(h[1:2] <= c(3e-3, 1 / sqrt(2)))) b <- fir1 (30, c(0.3, 0.7), 'pass') h <- abs (freqz (b, c(0, 0.3, 0.5, 0.7, 1), fs = 2)$h) expect_equal(h[3], 1, tolerance = 1e-3) expect_true(all(h[-3] <= c(3e-3, 1 / sqrt(2), 1 / sqrt(2), 3e-3))) b <- fir1(50, c(0.3, 0.7), "stop") h <- abs (freqz (b, c(0, 0.3, 0.5, 0.7, 1), fs = 2)$h) expect_equal(h[c(1, 5)], c(1, 1), tolerance = 1e-3) expect_true(all(h[2:4] <= c(1 / sqrt(2), 3e-3, 1 / sqrt(2)))) }) # ----------------------------------------------------------------------- # firls() test_that("parameters to firls() are correct", { expect_error(firls()) expect_error(firls(-1)) expect_error(firls(0.5)) expect_error(firls(1)) expect_error(firls(1, 2)) expect_error(firls(1, 2, 3)) expect_error(firls(1, 0.5, c(1, 1))) expect_error(firls(1, c(0.1, 0.5), c(1, 0), c(3, 3))) expect_error(firls(1, 2, 3, 4, 5)) }) gsignal/tests/testthat/test_Filter_Analysis_Functions.R0000644000176200001440000001515414670257046023223 0ustar liggesusers# gsignal filter analysis functions library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # freqs() test_that("parameters to freqs() are correct", { expect_error(freqs()) expect_error(freqs(1)) expect_error(freqs(1, 2)) }) test_that("freqs() tests are correct", { h <- freqs(1, 1, 1) expect_equal(h$h, 1 + 0i) h <- freqs(c(1, 2), c(1, 1), 1:4) expect_equal(h$h, c(1.5-0.5i, 1.2-0.4i, 1.1-0.3i, 1.058824-0.235294i), tolerance = tol) }) # ----------------------------------------------------------------------- # fwhm() test_that("parameters to fwhm() are correct", { expect_error(fwhm()) expect_error(fwhm(1)) expect_error(fwhm(1, 2, 3, 4, 5)) expect_error(fwhm(array(1))) expect_error(fwhm(1, c(1,2))) expect_error(fwhm(1, array(1:12, dim = c(2, 3, 2)))) expect_error(fwhm(1, 2, ref = 'invalid')) expect_error(fwhm(1, 2, level = 'invalid')) }) test_that("fwhm() tests are correct", { x <- seq(-pi, pi, 0.001) y <- cos(x) expect_equal(fwhm(x, y), 2 * pi / 3, tolerance = tol) expect_equal(fwhm(y = -10:10), 0L) expect_equal(fwhm(y = rep(1L, 50)), 0L) x <- seq(-20, 20, 1) y1 <- -4 + rep(0L, length(x)); y1[4:10] <- 8 y2 <- -2 + rep(0L, length(x)); y2[4:11] <- 2 y3 <- 2 + rep(0L, length(x)); y3[5:13] <- 10 expect_equal(fwhm(x, cbind(y1, y2, y3)), c(20 / 3, 7.5, 9.25), tolerance = tol) x <- 1:3 y <- c(-1, 3, -1) expect_equal(fwhm(x, y), 0.75) expect_equal(fwhm(x, y, 'max'), 0.75) expect_equal(fwhm(x, y, 'zero'), 0.75) expect_equal(fwhm(x, y, 'middle'), 1L) expect_equal(fwhm(x, y, 'min'), 1L) x <- 1:3 y <- c(-1, 3, -1) expect_equal(fwhm(x, y, level = 0.1), 1.35) expect_equal(fwhm(x, y, ref = 'max', level = 0.1), 1.35) expect_equal(fwhm(x, y, ref = 'min', level = 0.1), 1.40) expect_equal(fwhm(x, y, ref = 'abs', level = 2.5), 0.25) expect_equal(fwhm(x, y, ref = 'abs', level = -0.5), 1.75) x <- -5:5 y <- 18 - x * x expect_equal(fwhm(y = y), 6) expect_equal(fwhm(x, y), 6) expect_equal(fwhm(x, y, 'min'), 7) }) # ----------------------------------------------------------------------- # freqz() test_that("parameters to freqz() are correct", { expect_error(freqz()) expect_error(freqz('invalid')) expect_error(freqz(NA, 1)) expect_error(freqz(1, NA)) expect_error(freqz(1, 1, -1)) expect_error(freqz(1, 1, 1, FALSE, 0)) }) test_that("freqz() tests are correct", { # test correct values and fft-polyval consistency # butterworth filter, order 2, cutoff pi/2 radians b <- c(0.292893218813452, 0.585786437626905, 0.292893218813452) a <- c(1, 0, 0.171572875253810) hw <- freqz(b, a, 32) expect_equal(Re(hw$h[1]), 1) expect_equal(abs(hw$h[17])^2, 0.5) expect_equal(hw$h, freqz(b, a, hw$w)$h, tolerance = tol) # fft should be consistent with polyval # test whole-half consistency b <- c(1, 1, 1)/3 # 3-sample average hw <- freqz(b, 1, 32, whole = TRUE) expect_equal(hw$h[2:16], Conj(hw$h[32:18]), tolerance = tol) hw2 <- freqz(b, 1, 16, whole = FALSE) expect_equal(hw$h[1:16], hw2$h, tolerance = tol) expect_equal(hw$w[1:16], hw2$w, tolerance = tol) # test sampling frequency properly interpreted b <- c(1, 1, 1) / 3; a <- c(1, 0.2) hw <- freqz(b, a, 16, fs = 320) expect_equal(hw$w, (0:15) * 10) hw2 <- freqz(b, a, (0:15) * 10, fs = 320) expect_equal(hw2$w, (0:15) * 10) expect_equal(hw$h, hw2$h, tolerance = tol) hw3 <- freqz(b, a, 32, whole = TRUE, fs = 320) expect_equal(hw3$w, (0:31) * 10) # Github Issue #9 sys <- Arma(b = c(0.000731569700125585, 0, -0.00292627880050234, 0, 0.00438941820075351, 0, -0.00292627880050234, 0, 0.000731569700125585), a = c(1, -7.04203950456817, 21.7283807572297, -38.3801847495478, 42.4586614063362, -30.1289923970756, 13.3939745471932, -3.41070179210893, 0.380901732541468) ) hw <- freqz(sys, 5L) expect_equal(hw$h, c(3.255208e-06+0.000000e+00i, -9.759891e-04+1.062529e-01i, 3.328587e-03+2.658062e-03i, 3.101129e-04+1.143374e-04i, 1.305432e-05+2.075128e-06i), tol = 1e-3) hw <- freqz(sys, c(0, 1)) expect_equal(hw$w, c(0, 1)) expect_equal(hw$h, c(3e-06+0i, 8.254e-03+0.01047173i), tol = 1e-3) }) # ----------------------------------------------------------------------- # grpdelay() test_that("parameters to grpdelay() are correct", { expect_error(grpdelay()) expect_error(grpdelay('invalid')) }) test_that("grpdelay() tests are correct", { gd1 <- grpdelay(c(0, 1)) gd2 <- grpdelay(c(0, 1), 1) expect_equal(gd1$gd, gd2$gd) gd <- grpdelay(c(0, 1), 1, 4) expect_equal(gd$gd, rep(1L, 4)) expect_equal(gd$w, pi/4 * 0:3, tolerance = tol) gd <- grpdelay(c(0, 1), 1, 4, whole = TRUE) expect_equal(gd$gd, rep(1L, 4)) expect_equal(gd$w, pi/2 * 0:3, tolerance = tol) gd <- grpdelay(c(0, 1), 1, 4, fs = 0.5) expect_equal(gd$gd, rep(1L, 4)) expect_equal(gd$w, 1/16 * 0:3, tolerance = tol) gd <- grpdelay(c(0, 1), 1, 4, TRUE, 1) expect_equal(gd$gd, rep(1L, 4)) expect_equal(gd$w, 1/4 * 0:3) gd <- grpdelay(c(1, -0.9i), 1, 4, TRUE, 1) gd0 <- 0.447513812154696; gdm1 <- 0.473684210526316 expect_equal(gd$gd, c(gd0, -9, gd0, gdm1), tolerance = tol) expect_equal(gd$w, 1/4 * 0:3) gd <- grpdelay(1, c(1, .9), n = 2 * pi * c(0, 0.125, 0.25, 0.375)) expect_equal(gd$gd, c(-0.47368, -0.46918, -0.44751, -0.32316), tolerance = 1e-5) gd <- grpdelay(1, c(1, .9), c(0, 0.125, 0.25, 0.375), fs = 1) expect_equal(gd$gd, c(-0.47368, -0.46918, -0.44751, -0.32316), tolerance = 1e-5) gd <- grpdelay(c(1, 2), c(1, 0.5, .9), 4) expect_equal(gd$gd, c(-0.29167, -0.24218, 0.53077, 0.40658), tolerance = 1e-5) b1 <- c(1, 2); a1f <- c(0.25, 0.5, 1); a1 <- rev(a1f) gd1 <- grpdelay(b1, a1, 4)$gd gd <- grpdelay(conv(b1, a1f), 1, 4)$gd - 2 expect_equal(gd, gd1, tolerance = 1e-5) expect_equal(gd, c(0.095238, 0.239175, 0.953846, 1.759360), tolerance = 1e-5) a <- c(1, 0, 0.9) b <- c(0.9, 0, 1) dh <- grpdelay(b, a, 512, 'whole')$gd da <- grpdelay(1, a, 512, 'whole')$gd db <- grpdelay(b, 1, 512, 'whole')$gd expect_equal(dh, db + da, ttolerance = 1e-5) }) # ----------------------------------------------------------------------- # impz() test_that("parameters to impz() are correct", { expect_error(impz()) expect_error(impz('invalid')) }) test_that("impz() tests are correct", { xt <- impz(1, c(1, -1, 0.9), 100) expect_equal(length(xt$t), 100L) expect_equal(xt$t, 0:99) xt <- impz(1, c(1, -1, 0.9), 0:101) expect_equal(length(xt$t), 102L) expect_equal(xt$t, 0:101) }) gsignal/tests/testthat/test_IIR_Filter_Design_Functions.R0000644000176200001440000006762114420222025023340 0ustar liggesusers# gsignal IIR filter design functions library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # cheb() test_that("parameters to cheb() are correct", { expect_error(cheb()) expect_error(cheb(0.5)) expect_error(cheb(-1L)) expect_error(cheb(array(1L, c(1, 4)))) }) test_that("cheb() tests are correct", { expect_equal(cheb(1, 1), 1) expect_equal(cheb(2, 1), 1) expect_equal(cheb(5, 2), 362) expect_equal(cheb(5, c(2,3)), c(362, 3363)) }) # ----------------------------------------------------------------------- # besselap() test_that("parameters to besselap() are correct", { expect_error(besselap()) expect_error(besselap(0.5)) expect_error(besselap(-1L)) expect_error(besselap(array(1L, c(1, 4)))) expect_error(besselap(1, 2)) }) test_that("besselap() tests are correct", { expect_equal(besselap(1)$z, complex(0)) expect_equal(besselap(1)$p, -1) expect_equal(besselap(2)$p, c(-0.8660254+0.5i, -0.8660254-0.5i)) expect_equal(besselap(3)$p, c(-0.7456404+0.7113666i, -0.7456404-0.7113666i, -0.9416000+0.0000000i), tolerance = tol) }) # ----------------------------------------------------------------------- # besself() test_that("parameters to besself() are correct", { expect_error(besself()) expect_error(besself(1)) expect_error(besself(1, 2, 3, 4)) expect_error(besself(0.5, 0.2)) expect_error(besself(3, -1)) expect_error(besself(3, 2, "invalid")) }) test_that("besself() tests are correct", { zpg <- besself(1, 1, 'low') expect_equal(zpg$z, complex(0)) expect_equal(zpg$p, -1L) expect_equal(zpg$g, 1L) zpg <- besself(1, 1, 'high') expect_equal(zpg$z, 0L) expect_equal(zpg$p, -1L) expect_equal(zpg$g, 1L) zpg <- besself(1, c(1, 2), 'stop') expect_equal(zpg$z, c(0-1.414214i, 0+1.414214i), tolerance = tol) expect_equal(zpg$p, c(-0.5+1.322876i, -0.5-1.322876i), tolerance = tol) expect_equal(zpg$g, 1L) zpg <- besself(1, c(1, 2), 'pass') expect_equal(zpg$z, 0L) expect_equal(zpg$p, c(-0.5+1.322876i, -0.5-1.322876i), tolerance = tol) expect_equal(zpg$g, 1L) zpg <- besself(2, 1, 'low') expect_equal(zpg$z, complex(0)) expect_equal(zpg$p, c(-0.8660254+0.5i, -0.8660254-0.5i), tolerance = tol) expect_equal(zpg$g, 1L) zpg <- besself(2, 1, 'high') expect_equal(zpg$z, c(0L, 0L)) expect_equal(zpg$p, c(-0.8660254-0.5i, -0.8660254+0.5i), tolerance = tol) expect_equal(zpg$g, 1L) zpg <- besself(2, c(1, 2), 'stop') expect_equal(zpg$z, c(0-1.414214i, 0+1.414214i, 0-1.414214i, 0+1.414214i), tolerance = tol) expect_equal(zpg$p, c(-0.354087+1.121579i, -0.354087-1.121579i, -0.511939-1.621579i, -0.511939+1.621579i), tolerance = tol) expect_equal(zpg$g, 1L) zpg <- besself(2, c(1, 2), 'pass') expect_equal(zpg$z, c(0L, 0L)) expect_equal(zpg$p, c( -0.354087-1.121579i, -0.354087+1.121579i, -0.511939+1.621579i, -0.511939-1.621579i), tolerance = tol) expect_equal(zpg$g, 1L) }) # ----------------------------------------------------------------------- # bilinear() test_that("parameters to bilinear() are correct", { expect_error(bilinear()) expect_error(bilinear(1)) expect_error(bilinear(1, 2)) expect_error(bilinear(Zpg(c(1,1,1), 1, 1))) }) test_that("bilinear() tests are correct", { res <- bilinear(1, 1, 1, 1) expect_equal(res$z, 3) expect_equal(res$p, 3) expect_equal(res$g, 1) res <- bilinear(1, 2, 1, 1) expect_equal(res$z, 3) expect_equal(res$p, Inf) expect_equal(res$g, Inf) res <- bilinear(1, 3, 1, 1) expect_equal(res$z, 3) expect_equal(res$p, -5) expect_equal(res$g, -1) }) # ----------------------------------------------------------------------- # sftrans() test_that("parameters to sftrans() are correct", { expect_error(sftrans()) expect_error(sftrans(1)) expect_error(sftrans(1, 2)) expect_error(sftrans(Zpg(c(1,1,1), 1, 1))) }) test_that("sftrans() tests are correct", { res <- sftrans(1, 1, 1, 1, TRUE) expect_equal(res$z, 1) expect_equal(res$p, 1) expect_equal(res$g, 1) res <- sftrans(1, 2, 1, 1, TRUE) expect_equal(res$z, 1) expect_equal(res$p, 0.5) expect_equal(res$g, 0.5) res <- sftrans(1, 3, 1, 1, TRUE) expect_equal(res$z, 1) expect_equal(res$p, 1 / 3, tolerance = tol) expect_equal(res$g, 1/3) res <- sftrans(1, 3, 1, 1, FALSE) expect_equal(res$z, 1) expect_equal(res$p, 3) expect_equal(res$g, 1) }) # ----------------------------------------------------------------------- # buttord() test_that("parameters to buttord() are correct", { expect_error(buttord()) expect_error(buttord(.1)) expect_error(buttord(.1, .2)) expect_error(buttord(c(.1, .1), c(.2, .2), 3, 4)) expect_error(buttord(c(.1, .2), c(.5, .6), 3, 4)) expect_error(buttord(c(.1, .5), c(.2, .6), 3, 4)) expect_error(buttord(.1, .2, 3, 4, 5)) expect_error(buttord(1, 2, 3, 4, 's', 6)) }) test_that("buttord() tests are correct", { # Analog band-pass res <- buttord(2 * pi * c(9875, 10126.5823), 2 * pi * c(9000, 10436), 1, 26, "s") expect_equal(res$n, 4) expect_equal(round(res$Wc), c(61903, 63775)) expect_equal(round(res$Wc_s), c(61575, 64114)) # Analog band-pass res <- buttord (2 * pi * c(9875, 10126.5823), 2 * pi * c(9582, 11000), 1, 26, "s") expect_equal(res$n, 4) expect_equal(round(res$Wc), c(61903, 63775)) expect_equal(round(res$Wc_s), c(61575, 64115)) # Analog band-pass res <- buttord (2 * pi * c(9875, 10126.5823), 2 * pi * c(9000, 10437), 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(61850, 63830)) expect_equal(round(res$Wc_s), c(61848, 63831)) # Analog band-pass res <- buttord (2 * pi * c(9875, 10126.5823), 2 * pi * c(9581, 11000), 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(61850, 63830)) expect_equal(round(res$Wc_s), c(61847, 63832)) # Analog high-pass res <- buttord (2 * pi * 13583, 2 * pi * 4000, 1, 26, "s") expect_equal(res$n, 4) expect_equal(round(res$Wc), 72081) expect_equal(round(res$Wc_s), 53101) # Analog high-pass res <- buttord (2 * pi * 13584, 2 * pi * 4000, 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), 68140) expect_equal(round(res$Wc_s), 68138) # Analog low-pass res <- buttord (2 * pi * 4000, 2 * pi * 13583, 1, 26, "s") expect_equal(res$n, 4) expect_equal(round(res$Wc), 29757) expect_equal(round(res$Wc_s), 40394) # Analog low-pass res <- buttord (2 * pi * 4000, 2 * pi * 13584, 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), 31481) expect_equal(round(res$Wc_s), 31482) # Analog notch (narrow band-stop) res <- buttord (2 * pi * c(9000, 10436), 2 * pi * c(9875, 10126.5823), 1, 26, "s") expect_equal(res$n, 4) expect_equal(round(res$Wc), c(60607, 65138)) expect_equal(round(res$Wc_s), c(61184, 64524)) # Analog notch (narrow band-stop) res <- buttord (2 * pi * c(9582, 11000), 2 * pi * c(9875, 10126.5823), 1, 26, "s") expect_equal(res$n, 4) expect_equal(round(res$Wc), c(60606, 65139)) expect_equal(round(res$Wc_s), c(61184, 64524)) # Analog notch (narrow band-stop) res <- buttord (2 * pi * c(9000, 10437), 2 * pi * c(9875, 10126.5823), 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(60722, 65015)) expect_equal(round(res$Wc_s), c(60726, 65011)) # Analog notch (narrow band-stop) res <- buttord (2 * pi * c(9581, 11000), 2 * pi * c(9875, 10126.5823), 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(60721, 65016)) expect_equal(round(res$Wc_s), c(60726, 65011)) # Digital band-pass fs <- 44100 res <- buttord (2 / fs * c(9500, 9750), 2 / fs * c(8500, 10051), 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 4) expect_equal(round(Wc), c(9477, 9773)) expect_equal(round(Wc_s), c(9425, 9826)) # Digital band-pass fs <- 44100 res <- buttord (2 / fs * c(9500, 9750), 2 / fs * c(9204, 10700), 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 4) expect_equal(round(Wc), c(9477, 9773)) expect_equal(round(Wc_s), c(9425, 9826)) # Digital band-pass fs <- 44100 res <- buttord (2 / fs * c(9500, 9750), 2 / fs * c(8500, 10052), 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9469, 9782)) expect_equal(round(Wc_s), c(9468, 9782)) # Digital band-pass fs <- 44100 res <- buttord (2 / fs * c(9500, 9750), 2 / fs * c(9203, 10700), 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9469, 9782)) expect_equal(round(Wc_s), c(9468, 9782)) # Digital high-pass fs <- 44100 res <- buttord (2 / fs * 10987, 2 / fs * 4000, 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 4) expect_equal(round(Wc), 9808) expect_equal(round(Wc_s), 7780) # Digital high-pass fs <- 44100 res <- buttord (2 / fs * 10988, 2 / fs * 4000, 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), 9421) expect_equal(round(Wc_s), 9421) # Digital low-pass fs <- 44100 res <- buttord (2 / fs * 4000, 2 / fs * 10987, 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 4) expect_equal(round(Wc), 4686) expect_equal(round(Wc_s), 6176) # Digital low-pass fs <- 44100 res <- buttord (2 / fs * 4000, 2 / fs * 10988, 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), 4936) expect_equal(round(Wc_s), 4936) # Digital notch (narrow band-stop) fs <- 44100 res <- buttord (2 / fs * c(8500, 10833), 2 / fs * c(9875, 10126.5823), 0.5, 40) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 4) expect_equal(round(Wc), c(9369, 10640)) expect_equal(round(Wc_s), c(9605, 10400)) # Digital notch (narrow band-stop) fs <- 44100 res <- buttord (2 / fs * c(9183, 11000), 2 / fs * c(9875, 10126.5823), 0.5, 40) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 4) expect_equal(round(Wc), c(9370, 10640)) expect_equal(round(Wc_s), c(9605, 10400)) # Digital notch (narrow band-stop) fs <- 44100 res <- buttord (2 / fs * c(8500, 10834), 2 / fs * c(9875, 10126.5823), 0.5, 40) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9421, 10587)) expect_equal(round(Wc_s), c(9422, 10587)) # Digital notch (narrow band-stop) fs <- 44100 res <- buttord (2 / fs * c(9182, 11000), 2 / fs * c(9875, 10126.5823), 0.5, 40) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9421, 10587)) expect_equal(round(Wc_s), c(9422, 10587)) }) # ----------------------------------------------------------------------- # butter() test_that("parameters to butter() are correct", { expect_error(butter()) expect_error(butter(1)) expect_error(butter(1, 2, 3, 4, 5)) expect_error(butter(.5, .2)) expect_error(butter(3, .2, "invalid")) expect_error(butter(9, .6, "stop")) expect_error(butter(9, .6, "pass")) expect_error(butter(9, .6, "pass", "q")) expect_error(butter(9, .6, "pass", "z", "invalid")) }) test_that("butter() tests are correct", { # shared sf, sf2, off_db off_db <- 0.5 fs <- 6000; fs2 <- fs / 2 sinetone <- function(f, r, s, a) a * sin(2 * pi * f * seq(0, s, length.out = r * s)) data <- cbind(sinetone(5,fs,10,1), sinetone(10,fs,10,1), sinetone(50,fs,10,1), sinetone(200,fs,10,1), sinetone(400,fs,10,1)) l <- nrow(data) # Test low pass order 1 with 3dB @ 50Hz bf <- butter ( 1, 50 / fs2 ) filtered <- NULL; for (i in 1:5) filtered <- cbind(filtered, filter(bf, data[, i])) damp_db <- NULL; for (i in 1:5) damp_db <- cbind(damp_db, 20 * log10(max(filtered[(l - fs):l, i]))) expect_equal(c(damp_db[4] - damp_db[5], damp_db[1:3]), c(6, 0, 0, -3), tolerance = off_db) # Test low pass order 4 with 3dB @ 50Hz bf <- butter(4, 50 / fs2) filtered <- NULL; for (i in 1:5) filtered <- cbind(filtered, filter(bf, data[, i])) damp_db <- NULL; for (i in 1:5) damp_db <- cbind(damp_db, 20 * log10(max(filtered[(l - fs):l, i]))) expect_equal(c(damp_db[4] - damp_db[5], damp_db[1:3]), c(24, 0, 0, -3), tolerance = off_db) # Test high pass order 1 with 3dB @ 50Hz bf <- butter(1, 50 / fs2, "high") filtered <- NULL; for (i in 1:5) filtered <- cbind(filtered, filter(bf, data[, i])) damp_db <- NULL; for (i in 1:5) damp_db <- cbind(damp_db, 20 * log10(max(filtered[(l - fs):l, i]))) expect_equal(c(damp_db[2] - damp_db[1], damp_db[3:5]), c(6, -3, 0, 0), tolerance = off_db) # Test high pass order 4 with 3dB @ 50Hz bf <- butter(4, 50 / fs2, "high") filtered <- NULL; for (i in 1:5) filtered <- cbind(filtered, filter(bf, data[, i])) damp_db <- NULL; for (i in 1:5) damp_db <- cbind(damp_db, 20 * log10(max(filtered[(l - fs):l, i]))) expect_equal(c(damp_db[2] - damp_db[1], damp_db[3:5]), c(24, -3, 0, 0), tolerance = off_db) # Test outut formats zpg <- butter(3, 0.05, output = "Zpg") expect_equal(as.Arma(zpg), butter(3, 0.05)) sos <- butter(3, 0.05, output = "Sos") expect_equal(as.Arma(sos), butter(3, 0.05)) }) # ----------------------------------------------------------------------- # cheb1ord() test_that("parameters to cheb1ord() are correct", { expect_error(cheb1ord()) expect_error(cheb1ord(.1)) expect_error(cheb1ord(.1, .2)) expect_error(cheb1ord(c(.1, .1), c(.2, .2), 3, 4)) expect_error(cheb1ord(c(.1, .2), c(.5, .6), 3, 4)) expect_error(cheb1ord(c(.1, .5), c(.2, .6), 3, 4)) expect_error(cheb1ord(.1, .2, 3, 4, 5)) expect_error(cheb1ord(1, 2, 3, 4, 's', 6)) }) test_that("cheb1ord() tests are correct", { # Analog band-pass res <- cheb1ord(2 * pi * c(9875, 10126.5823), 2 * pi * c(9000, 10437), 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(62046, 63627)) expect_equal(round(res$Wc_s), c(61652, 64035)) # Analog band-pass res <- cheb1ord (2 * pi * c(9875, 10126.5823), 2 * pi * c(9581, 12000), 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(62046, 63627)) expect_equal(round(res$Wc_s), c(61651, 64036)) # Analog high-pass res <- cheb1ord (2 * pi * 13584, 2 * pi * 4000, 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), 85351) expect_equal(round(res$Wc_s), 56700) # Analog high-pass res <- cheb1ord (2 * pi * 13584, 2 * pi * 4000, 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), 85351) expect_equal(round(res$Wc_s), 56700) # Analog low-pass res <- cheb1ord (2 * pi * 4000, 2 * pi * 13584, 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), 25133) expect_equal(round(res$Wc_s), 37832) # Analog notch (narrow band-stop) res <- cheb1ord (2 * pi * c(9000, 10437), 2 * pi * c(9875, 10126.5823), 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(60201, 65578)) expect_equal(round(res$Wc_s), c(61074, 64640)) # Analog notch (narrow band-stop) res <- cheb1ord (2 * pi * c(9581, 12000), 2 * pi * c(9875, 10126.5823), 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(60199, 65580)) expect_equal(round(res$Wc_s), c(61074, 64640)) # Digital band-pass fs <- 44100 res <- cheb1ord (2 / fs * c(9500, 9750), 2 / fs * c(8500, 10052), 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9500, 9750)) expect_equal(round(Wc_s), c(9437, 9814)) # Digital band-pass fs <- 44100 res <- cheb1ord (2 / fs * c(9500, 9750), 2 / fs * c(9182, 12000), 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9500, 9750)) expect_equal(round(Wc_s), c(9428, 9823)) # Digital high-pass fs <- 44100 res <- cheb1ord (2 / fs * 10988, 2 / fs * 4000, 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), 10988) expect_equal(round(Wc_s), 8197) # Digital low-pass fs <- 44100 res <- cheb1ord (2 / fs * 4000, 2 / fs * 10988, 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), 4000) expect_equal(round(Wc_s), 5829) # Digital notch (narrow band-stop) fs <- 44100 res <- cheb1ord (2 / fs * c(8500, 10834), 2 / fs * c(9875, 10126.5823), 0.5, 40) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9182, 10834)) expect_equal(round(Wc_s), c(9475, 10532)) # Digital notch (narrow band-stop) fs <- 44100 res <- cheb1ord (2 / fs * c(9182, 12000), 2 / fs * c(9875, 10126.5823), 0.5, 40) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9182, 10834)) expect_equal(round(Wc_s), c(9475, 10532)) }) # ----------------------------------------------------------------------- # cheby1() test_that("parameters to cheby1() are correct", { expect_error(cheby1()) expect_error(cheby1(1)) expect_error(cheby1(1, 2, 3, 4, 5)) expect_error(cheby1(.5, .2)) expect_error(cheby1(3, .2, 0.5, "invalid")) expect_error(cheby1(9, .6, 0.5, "stop")) expect_error(cheby1(9, .6, 0.5, "pass")) expect_error(cheby1(9, .6, 0.5, "pass", "q")) }) # ----------------------------------------------------------------------- # cheb2ord() test_that("parameters to cheb2ord() are correct", { expect_error(cheb2ord()) expect_error(cheb2ord(.1)) expect_error(cheb2ord(.1, .2)) expect_error(cheb2ord(c(.1, .1), c(.2, .2), 3, 4)) expect_error(cheb2ord(c(.1, .2), c(.5, .6), 3, 4)) expect_error(cheb2ord(c(.1, .5), c(.2, .6), 3, 4)) expect_error(cheb2ord(.1, .2, 3, 4, 5)) expect_error(cheb2ord(1, 2, 3, 4, 's', 6)) }) test_that("cheb2ord() tests are correct", { # Analog band-pass res <- cheb2ord(2 * pi * c(9875, 10126.5823), 2 * pi * c(9000, 10437), 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(61074, 64640)) expect_equal(round(res$Wc_s), c(60201, 65578)) # Analog band-pass res <- cheb2ord (2 * pi * c(9875, 10126.5823), 2 * pi * c(9581, 12000), 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(61074, 64640)) expect_equal(round(res$Wc_s), c(60199, 65580)) # Analog high-pass res <- cheb2ord (2 * pi * 13584, 2 * pi * 4000, 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), 37832) expect_equal(round(res$Wc_s), 25133) # Analog low-pass res <- cheb2ord (2 * pi * 4000, 2 * pi * 13584, 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), 56700) expect_equal(round(res$Wc_s), 85351) # Analog notch (narrow band-stop) res <- cheb2ord (2 * pi * c(9000, 10437), 2 * pi * c(9875, 10126.5823), 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(61652, 64035)) expect_equal(round(res$Wc_s), c(62046, 63627)) # Analog notch (narrow band-stop) res <- cheb2ord (2 * pi * c(9581, 12000), 2 * pi * c(9875, 10126.5823), 1, 26, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(61651, 64036)) expect_equal(round(res$Wc_s), c(62046, 63627)) # Digital band-pass fs <- 44100 res <- cheb2ord (2 / fs * c(9500, 9750), 2 / fs * c(8500, 10052), 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9344, 9908)) expect_equal(round(Wc_s), c(9203, 10052)) # Digital band-pass fs <- 44100 res <- cheb2ord (2 / fs * c(9500, 9750), 2 / fs * c(9182, 12000), 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9344, 9908)) expect_equal(round(Wc_s), c(9182, 10073)) # Digital high-pass fs <- 44100 res <- cheb2ord (2 / fs * 10988, 2 / fs * 4000, 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), 5829) expect_equal(round(Wc_s), 4000) # Digital low-pass fs <- 44100 res <- cheb2ord (2 / fs * 4000, 2 / fs * 10988, 1, 26) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), 8197) expect_equal(round(Wc_s), 10988) # Digital notch (narrow band-stop) fs <- 44100 res <- cheb2ord (2 / fs * c(8500, 10834), 2 / fs * c(9875, 10126.5823), 0.5, 40) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9804, 10198)) expect_equal(round(Wc_s), c(9875, 10127)) # Digital notch (narrow band-stop) fs <- 44100 res <- cheb2ord (2 / fs * c(9182, 12000), 2 / fs * c(9875, 10126.5823), 0.5, 40) Wc <- res$Wc * fs / 2 Wc_s <- res$Wc_s * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9804, 10198)) expect_equal(round(Wc_s), c(9875, 10127)) }) # ----------------------------------------------------------------------- # cheby2() test_that("parameters to cheby2() are correct", { expect_error(cheby2()) expect_error(cheby2(1)) expect_error(cheby2(1, 2, 3, 4, 5)) expect_error(cheby2(.5, .2)) expect_error(cheby2(3, .2, 0.5, "invalid")) expect_error(cheby2(9, .6, 0.5, "stop")) expect_error(cheby2(9, .6, 0.5, "pass")) expect_error(cheby2(9, .6, 0.5, "pass", "q")) }) # ----------------------------------------------------------------------- # ellipord() test_that("parameters to ellipord() are correct", { expect_error(ellipord()) expect_error(ellipord(.1)) expect_error(ellipord(.1, .2)) expect_error(ellipord(c(.1, .1), c(.2, .2), 3, 4)) expect_error(ellipord(c(.1, .2), c(.5, .6), 3, 4)) expect_error(ellipord(c(.1, .5), c(.2, .6), 3, 4)) expect_error(ellipord(.1, .2, 3, 4, 5)) expect_error(ellipord(1, 2, 3, 4, 's', 6)) }) test_that("ellipord() tests are correct", { # Analog band-pass res <- ellipord(2 * pi * c(9875, 10126.5823), 2 * pi * c(9000, 10657), 3, 40, "s") expect_equal(res$n, 2) expect_equal(round(res$Wc), c(62046, 63627)) # Analog band-pass res <- ellipord (2 * pi * c(9875, 10126.5823), 2 * pi * c(9384, 12000), 3, 40, "s") expect_equal(res$n, 2) expect_equal(round(res$Wc), c(62046, 63627)) # Analog band-pass res <- ellipord (2 * pi * c(9875, 10126.5823), 2 * pi * c(9000, 10656), 3, 40, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(62046, 63627)) # Analog band-pass res <- ellipord (2 * pi * c(9875, 10126.5823), 2 * pi * c(9385, 12000), 3, 40, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(62046, 63627)) # Analog high-pass res <- ellipord (2 * pi * 20224, 2 * pi * 4000, 3, 40, "s") expect_equal(res$n, 2) expect_equal(round(res$Wc), 127071) # Analog high-pass res <- ellipord (2 * pi * 20223, 2 * pi * 4000, 3, 40, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), 127065) # Analog low-pass res <- ellipord (2 * pi * 4000, 2 * pi * 20224, 3, 40, "s") expect_equal(res$n, 2) expect_equal(round(res$Wc), 25133) # Analog low-pass res <- ellipord (2 * pi * 4000, 2 * pi * 20223, 3, 40, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), 25133) # Analog notch (narrow band-stop) res <- ellipord (2 * pi * c(9000, 10657), 2 * pi * c(9875, 10126.5823), 3, 40, "s") expect_equal(res$n, 2) expect_equal(round(res$Wc), c(58958, 66960)) # Analog notch (narrow band-stop) res <- ellipord (2 * pi * c(9384, 12000), 2 * pi * c(9875, 10126.5823), 3, 40, "s") expect_equal(res$n, 2) expect_equal(round(res$Wc), c(58961 , 66956)) # Analog notch (narrow band-stop) res <- ellipord (2 * pi * c(9000, 10656), 2 * pi * c(9875, 10126.5823), 3, 40, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(58964, 66954)) # Analog notch (narrow band-stop) res <- ellipord (2 * pi * c(9385, 12000), 2 * pi * c(9875, 10126.5823), 3, 40, "s") expect_equal(res$n, 3) expect_equal(round(res$Wc), c(58968, 66949)) # Digital band-pass fs <- 44100 res <- ellipord (2 / fs * c(9500, 9750), 2 / fs * c(8500, 10261), 3, 40) Wc <- res$Wc * fs / 2 expect_equal(res$n, 2) expect_equal(round(Wc), c(9500, 9750)) # Digital band-pass fs <- 44100 res <- ellipord (2 / fs * c(9500, 9750), 2 / fs * c(9000, 10700), 3, 40) Wc <- res$Wc * fs / 2 expect_equal(res$n, 2) expect_equal(round(Wc), c(9500, 9750)) # Digital band-pass fs <- 44100 res <- ellipord (2 / fs * c(9500, 9750), 2 / fs * c(8500, 10260), 3, 40) Wc <- res$Wc * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9500, 9750)) # Digital band-pass fs <- 44100 res <- ellipord (2 / fs * c(9500, 9750), 2 / fs * c(9001, 10700), 3, 40) Wc <- res$Wc * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(9500, 9750)) # Digital high-pass fs <- 44100 res <- ellipord (2 / fs * 13713, 2 / fs * 4000, 3, 40) Wc <- res$Wc * fs / 2 expect_equal(res$n, 2) expect_equal(round(Wc), 13713) # Digital high-pass fs <- 44100 res <- ellipord (2 / fs * 13712, 2 / fs * 4000, 3, 40) Wc <- res$Wc * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), 13712) # Digital low-pass fs <- 44100 res <- ellipord (2 / fs * 4000, 2 / fs * 13713, 3, 40) Wc <- res$Wc * fs / 2 expect_equal(res$n, 2) expect_equal(round(Wc), 4000) # Digital low-pass fs <- 44100 res <- ellipord (2 / fs * 4000, 2 / fs * 13712, 3, 40) Wc <- res$Wc * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), 4000) # Digital notch (narrow band-stop) fs <- 44100 res <- ellipord (2 / fs * c(8500, 11073), 2 / fs * c(9875, 10126.5823), 0.5, 40) Wc <- res$Wc * fs / 2 expect_equal(res$n, 2) expect_equal(round(Wc), c(8952, 11073)) # Digital notch (narrow band-stop) fs <- 44100 res <- ellipord (2 / fs * c(8952, 12000), 2 / fs * c(9875, 10126.5823), 0.5, 40) Wc <- res$Wc * fs / 2 expect_equal(res$n, 2) expect_equal(round(Wc), c(8952, 11073)) # Digital notch (narrow band-stop) fs <- 44100 res <- ellipord (2 / fs * c(8500, 11072), 2 / fs * c(9875, 10126.5823), 0.5, 40) Wc <- res$Wc * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(8953, 11072)) # Digital notch (narrow band-stop) fs <- 44100 res <- ellipord (2 / fs * c(8953, 12000), 2 / fs * c(9875, 10126.5823), 0.5, 40) Wc <- res$Wc * fs / 2 expect_equal(res$n, 3) expect_equal(round(Wc), c(8953, 11072)) }) # ----------------------------------------------------------------------- # ellip() test_that("parameters to ellip() are correct", { expect_error(ellip()) expect_error(ellip(1)) expect_error(ellip(1, 2)) expect_error(ellip(1, 2, 3)) expect_error(ellip(1, 2, 3, 4, 5, 6, 7)) expect_error(ellip(0.5, 2, 40, .2)) expect_error(ellip(3, 2, 40, .2, "invalid")) expect_error(ellip(3, 2, 40, .2, "low", "invalid")) }) # ----------------------------------------------------------------------- # pei_tseng_notch() test_that("parameters to pei_tseng_notch() are correct", { expect_error(pei_tseng_notch()) expect_error(pei_tseng_notch(1)) expect_error(pei_tseng_notch(1, 2, 3)) expect_error(pei_tseng_notch(c(1, 2), 3)) expect_error(pei_tseng_notch(-1, 1)) expect_error(pei_tseng_notch(1, -1)) expect_error(pei_tseng_notch(3, "invalid")) expect_error(pei_tseng_notch("invalid", 2)) expect_error(pei_tseng_notch(matrix(0, 2, 2), 2)) expect_error(pei_tseng_notch(1, matrix(0L, 2, 2))) }) test_that("pei_tseng_notch() tests are correct", { sinetone <- function(f, r, s, a) a * sin(2 * pi * f * seq(0, s, length.out = r * s)) ## 2Hz bandwidth fs <- 800; nyq <- fs / 2 data <- cbind(sinetone(49, fs, 10, 1), sinetone(50, fs, 10, 1), sinetone(51, fs, 10, 1)) l <- nrow(data) ba <- pei_tseng_notch( 50 / nyq, 2 / nyq) filtered <- filter(ba, data) damp_db <- apply(filtered, 2, function(x) 20 * log10(max(x[(l - 1000):l]))) expect_equal(as.vector(damp_db), c(-3.037382, -44.16588, -3.065681), tolerance = tol) ## 1Hz bandwidth data <- cbind(sinetone(49.5, fs, 10, 1), sinetone(50, fs, 10, 1), sinetone(50.5, fs, 10, 1)) l <- nrow(data) ba <- pei_tseng_notch( 50 / nyq, 1 / nyq) filtered <- filter(ba, data) damp_db <- apply(filtered, 2, function(x) 20 * log10(max(x[(l - 1000):l]))) expect_equal(as.vector(damp_db), c(-3.064986, -38.10409, -2.997267), tolerance = tol) }) # ----------------------------------------------------------------------- # cheb2ap() test_that("parameters to cheb2ap() are correct", { expect_error(cheb2ap()) expect_error(cheb2ap(1)) expect_error(cheb2ap(-1, 3)) expect_error(cheb2ap(3, -1)) }) gsignal/tests/testthat/test_Signal_Measurement.R0000644000176200001440000001102614670250533021651 0ustar liggesusers# gsignal Signal Measurement library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # findpeaks() test_that("parameters to findpeaks() are correct", { expect_error(findpeaks()) expect_error(findpeaks(1)) expect_error(findpeaks(c(1, 1))) expect_error(findpeaks(complex(3, 1, 1))) expect_error(findpeaks(c(1, 1, 1), MinPeakHeight = -1)) expect_error(findpeaks(c(1, 1, 1), MinPeakDistance = -1)) expect_error(findpeaks(c(1, 1, 1), MinPeakWidth = -1)) expect_error(findpeaks(c(1, 1, 1), DoubleSided = -1)) }) test_that("findpeaks() tests are correct", { expect_null(findpeaks (c(1, 1, 1))) expect_null(findpeaks (t(c(1, 1, 1)))) # Test Matlab/Octave compatibility p <- findpeaks(c(34, 134, 353, 64, 134, 14, 56, 67, 234, 143, 64, 575, 8657)) expect_equal(p$pks, c(353, 134, 234)) ## Test for bug #45056 ## Test input vector is an oversampled sinusoid with clipped peaks x <- pmin(3, cos (2*pi*c(0:8000) / 600) + 2.01) expect_equal(findpeaks(x)$pks, rep(3L, 13)) }) # ----------------------------------------------------------------------- # peak2peak() test_that("parameters to peak2peak() are correct", { expect_error(peak2peak()) expect_error(peak2peak('invalid')) expect_error(peak2peak(1, 2, 3)) expect_error(peak2peak(1, 1.5)) expect_error(peak2peak(1, -1)) }) test_that("peak2peak() tests are correct", { x <- c(1:5) expect_equal(peak2peak(x), 4) x <- matrix(c(1,2,3, 100, 150, 200, 1000, 1500, 2000), 3, 3) expect_equal(peak2peak(x), c(2, 100, 1000)) expect_equal(peak2peak(x, 1), c(999, 1498, 1997)) x <- array(c(1, 1.5, 2, 100, 150, 200, 1000, 1500, 2000, 10000, 15000, 20000), c(2,3,2)) expect_equal(peak2peak(x, 1), c(14999.0, 19998.5)) expect_equal(peak2peak(x, 2), c(1499, 9998, 19850)) expect_equal(peak2peak(x, 3), c(199, 19000)) x <- c(1+1i, 2+3i, 3+5i, 4+7i, 5+9i) expect_equal(peak2peak(x), 4+8i) }) # ----------------------------------------------------------------------- # peak2rms() test_that("parameters to peak2rms() are correct", { expect_error(peak2rms()) expect_error(peak2rms('invalid')) expect_error(peak2rms(1, 2, 3)) expect_error(peak2rms(1, 1.5)) expect_error(peak2rms(1, -1)) }) test_that("peak2rms() tests are correct", { expect_equal(peak2rms(1), 1L) expect_equal(peak2rms(-5), 1L) x <- c(1:5) expect_equal(peak2rms(x), 5 / sqrt(11), tolerance = tol) x <- matrix(c(1,2,3, 100, 150, 200, 1000, 1500, 2000), 3, 3) expect_equal(peak2rms(x), c(3/sqrt(14/3), 200/sqrt(72500/3), 2000/sqrt(7250000/3)), tolerance = tol) expect_equal(peak2rms(x, 1), c(1000/sqrt(1010001/3), 1500/sqrt(2272504/3), 2000/sqrt(4040009/3)), tolerance = tol) x <- c(1+1i, 2+3i, 3+5i, 4+7i, 5+9i) expect_equal(peak2rms(x), 1.552125, tolerance = tol) }) # ----------------------------------------------------------------------- # rms() test_that("parameters to rms() are correct", { expect_error(rms()) expect_error(rms('invalid')) expect_error(rms(1, 2, 3)) expect_error(rms(1, 1.5)) expect_error(rms(1, -1)) }) test_that("rms() tests are correct", { expect_equal(rms(0), 0L) expect_equal(rms(1), 1L) expect_equal(rms(c(1, 2, -1)), sqrt(2), tolerance = tol) x <- c(1:5) expect_equal(rms(x), sqrt(11), tolerance = tol) x <- matrix(c(1,2,3, 100, 150, 200, 1000, 1500, 2000), 3, 3) expect_equal(rms(x), c(sqrt(14/3), sqrt(72500/3), sqrt(7250000/3)), tolerance = tol) expect_equal(rms(x, 1), c(sqrt(336667), sqrt(2272504/3), sqrt(1346670)), tolerance = tol) x <- c(1+1i, 2+3i, 3+5i, 4+7i, 5+9i) expect_equal(rms(x), 6.63325, tolerance = tol) }) # ----------------------------------------------------------------------- # rssq() test_that("parameters to rssq() are correct", { expect_error(rssq()) expect_error(rssq('invalid')) expect_error(rssq(1, 2, 3)) expect_error(rssq(1, 1.5)) expect_error(rssq(1, -1)) }) test_that("rssq() tests are correct", { expect_equal(rssq(1), 1L) expect_equal(rssq(-5), 5L) expect_equal(rssq(c(1, 2, -1)), sqrt(6), tolerance = tol) x <- c(1:5) expect_equal(rssq(x), sqrt(55), tolerance = tol) x <- matrix(c(1,2,3, 100, 150, 200, 1000, 1500, 2000), 3, 3) expect_equal(rssq(x), c(sqrt(14), sqrt(72500), sqrt(7250000)), tolerance = tol) expect_equal(rssq(x, 1), c(sqrt(1010001), sqrt(2272504), sqrt(4040009)), tolerance = tol) x <- c(1+1i, 2+3i, 3+5i, 4+7i, 5+9i) expect_equal(rssq(x), 14.8324, tolerance = tol) }) gsignal/tests/testthat/test_Sample_Rate_Change_Functions.R0000644000176200001440000000750514661370046023571 0ustar liggesusers# gsignal Sample Rate Change Functions library(gsignal) library(testthat) # ----------------------------------------------------------------------- # upfirdn() test_that("parameters to upfirdn() are correct", { expect_error(upfirdn()) expect_error(upfirdn(1)) expect_error(upfirdn(1, 2, 3, 4, 5)) expect_error(upfirdn(0:10, matrix(1:4, 2, 2), 1, 1)) }) test_that("upfirdn() tests are correct", { expect_equal(upfirdn(1:100, 1, 1, 1), seq(1, 100, 1)) expect_equal(upfirdn(1:100, 1, 1, 2), seq(1, 100, 2)) expect_equal(upfirdn(cbind(1:100, 1:100), 1, 1, 1), cbind(seq(1, 100, 1), seq(1, 100, 1))) expect_equal(upfirdn(cbind(1:100, 1:100), 1, 1, 2), cbind(seq(1, 100, 2), seq(1, 100, 2))) }) # ----------------------------------------------------------------------- # resample() test_that("parameters to resample() are correct", { expect_error(resample()) expect_error(resample(1)) expect_error(resample(1, 2)) expect_error(resample(1, 2, 3, 4, 5)) expect_error(resample(1, 1, 0.1)) expect_error(resample(1, 0.1, 1)) }) test_that("resample() tests are correct", { expect_equal(resample(1:100, 1, 1), seq(1, 100, 1)) expect_equal(resample(cbind(1:100, 1:100), 1, 1), cbind(seq(1, 100, 1), seq(1, 100, 1))) expect_equal(length(resample(1:100, 1, 2)), 50) expect_equal(nrow(resample(cbind(1:100, 1:100), 1, 2)), 50) expect_equal(length(resample(1:100, 2, 1)), 200) expect_equal(nrow(resample(cbind(1:100, 1:100), 2, 1)), 200) }) # ----------------------------------------------------------------------- # downsample() test_that("parameters to downsample() are correct", { expect_error(downsample()) expect_error(downsample(1)) expect_error(downsample(1, -1)) expect_error(downsample(1, 1, -1)) expect_error(downsample(1, 1, 1)) expect_error(downsample(1, 2, 3, 4)) }) test_that("downsample() tests are correct", { expect_equal(downsample(1:5, 2), c(1, 3, 5)) expect_equal(downsample(matrix(1:10, 5, byrow = TRUE), 2), matrix(c(1, 2, 5, 6, 9, 10), 3, byrow = TRUE)) expect_equal(downsample(1:5, 2, 1), c(2, 4)) expect_equal(downsample(matrix(1:10, 5, byrow = TRUE), 2, 1), matrix(c(3, 4, 7, 8), 2, byrow = TRUE)) }) # ----------------------------------------------------------------------- # upsample() test_that("parameters to upsample() are correct", { expect_error(upsample()) expect_error(upsample(1)) expect_error(upsample(1, -1)) expect_error(upsample(1, 1, -1)) expect_error(upsample(1, 1, 1)) expect_error(upsample(1, 2, 3, 4)) }) test_that("upsample() tests are correct", { expect_equal(upsample(c(1, 3, 5), 2), c(1, 0, 3, 0, 5, 0)) expect_equal(upsample(matrix(c(1, 2, 5, 6, 9, 10), 3, byrow = TRUE), 2), matrix(c(1, 2, 0, 0, 5, 6, 0, 0, 9, 10, 0, 0), 6, byrow = TRUE)) expect_equal(upsample(c(2, 4), 2, 1), c(0, 2, 0, 4)) expect_equal(upsample(matrix(c(3, 4, 7, 8), 2, byrow = TRUE), 2, 1), matrix(c(0, 0, 3, 4, 0, 0, 7, 8), 4, byrow = TRUE)) }) # ----------------------------------------------------------------------- # decimate() test_that("parameters to decimate() are correct", { expect_error(decimate()) expect_error(decimate(1)) expect_error(decimate(1, -1)) expect_error(decimate(1, 1, -1)) expect_error(decimate(1, 2, 3, 4)) expect_error(decimate(1, 2, 3, "error")) }) test_that("decimate() tests are correct", { expect_equal(round(decimate(1:10, 2), 3), c(0.997, 2.977, 4.899, 7.007, 8.843)) expect_equal(round(decimate(1:10, 2, ftype = "fir"), 3), c(0.953, 3.095, 4.097, 3.966, 4.029)) expect_equal(round(decimate(matrix(c(1:10, 1:10), ncol = 2), 2), 3), matrix(c(0.997, 2.977, 4.899, 7.007, 8.843, 0.997, 2.977, 4.899, 7.007, 8.843), ncol = 2)) # Github #17 expect_equal(decimate(1:100, 2, 'fir'), seq(1, 100, 2)) }) gsignal/tests/testthat/test_Power_Spectrum_Analysis_Functions.R0000644000176200001440000001125114666064600024743 0ustar liggesusers# gsignal Power Spectrum Analysis Functions library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # pwelch() test_that("parameters to pwelch() are correct", { expect_error(pwelch()) expect_error(pwelch('a')) expect_error(pwelch(1:10, -1)) expect_error(pwelch(1:10, 4, -1)) expect_error(pwelch(1:10, 4, 0.5, -1)) expect_error(pwelch(1:10, 4, 0.5, 12, -1)) expect_error(pwelch(1:10, 4, 0.5, 12, pi, 'invalid')) expect_error(pwelch(1:10, 4, 0.5, 12, pi, 'none', 'unused')) }) test_that("pwelch() tests are correct", { fs <- 1000 secs <- 10 freq <- 30 A <- 1 t <- seq(0, secs, length.out = fs * secs) x <- A * cos(freq * 2 * pi * t) Pxx <- pwelch(x, fs = fs) expect_equal(length(Pxx$freq), 65L) expect_equal(length(Pxx$spec), 65L) expect_equal(round(Pxx$freq[which.max(Pxx$spec)], -1), 30L) expect_null(Pxx$cross) expect_null(Pxx$phase) expect_null(Pxx$coh) expect_null(Pxx$trans) expect_equal(Pxx$x_len, 9984L) expect_equal(Pxx$seg_len, 128L) expect_equal(Pxx$psd_len, 65L) expect_equal(Pxx$nseries, 1L) y <- A * sin(freq * 2 * pi * t) Pxy <- pwelch(cbind(x, y), fs = fs) expect_equal(length(Pxy$freq), 65L) expect_equal(dim(Pxy$spec), c(65L, 2L)) expect_equal(dim(Pxy$cross), c(65L, 1L)) expect_equal(round(Pxy$freq[which.max(Pxy$cross[, 1])], -1), 30L) expect_equal(colnames(Pxy$cross), "x-y") expect_equal(dim(Pxy$phase), c(65L, 1L)) expect_equal(unname(Pxy$phase[which(Pxy$freq>30)[1], 1]), pi/2, tolerance = 1e-4) expect_equal(colnames(Pxy$phase), "x-y") expect_equal(dim(Pxy$coh), c(65L, 1L)) expect_equal(unname(Pxy$coh[which(Pxy$freq>30)[1], 1]), 1, tolerance = 1e-4) expect_equal(colnames(Pxy$coh), "x-y") expect_equal(dim(Pxy$trans), c(65L, 1L)) expect_equal(unname(abs(Pxy$trans[which(Pxy$freq>30)[1], 1])), 1, tolerance = 1e-4) expect_equal(colnames(Pxy$trans), "x-y") expect_equal(Pxx$x_len, 9984L) expect_equal(Pxy$seg_len, 128L) expect_equal(Pxy$psd_len, 65L) expect_equal(Pxy$nseries, 2L) Pxx <- pwelch(x, fs = fs, range = "whole") expect_equal(length(Pxx$freq), 128L) expect_equal(length(Pxx$spec), 128L) # test if pwelch returns N/2 + 1 instead of nextpow2 # Github discussion #5 # and Github Issue #6: expect $spec to be vector if x is vector x <- runif(2e6) fs <- 100 win <- 4 * fs Pxx <- pwelch(x, win, fs = fs) expect_true(is.vector(Pxx$spec)) expect_length(Pxx$spec, 201L) # Github Issue #6: expect matrix of column 1 if input is matrix x <- matrix(runif(2e6), ncol = 1) Pxx <- pwelch(x, win, fs = fs) expect_equal(ncol(Pxx$spec), 1L) }) # ----------------------------------------------------------------------- # ar_psd() test_that("parameters to ar_psd() are correct", { expect_error(ar_psd()) expect_error(ar_psd('a')) expect_error(ar_psd(c(0,0))) expect_error(ar_psd(1:10, -1)) expect_error(ar_psd(1:10, 4, -1)) expect_error(ar_psd(1:10, 4, 2, -1)) expect_error(ar_psd(1:10, 4, 2, 1, 'invalid')) expect_error(ar_psd(1:10, 4, 2, 1, 'whole', 'invalid')) expect_error(ar_psd(1:10, 4, 2, 1, 'whole', 'fft', 7)) }) test_that("ar_psd() tests are correct", { psd <- ar_psd(c(1, 0), 1) expect_equal(psd$freq, (1 / 2 / 256) * seq(0, 255), tolerance = tol) expect_equal(psd$psd, rep(2L, 256)) n <- 64 psd <- ar_psd(c(1, 0, 0), 1, n) expect_equal(psd$freq, (1 / 2 / n) * seq(0, n - 1), tolerance = tol) expect_equal(psd$psd, rep(2L, n)) psd <- ar_psd(c(1, 0, 2), 1, n) expect_equal(which.max(psd$psd), (n / 2) + 1) psd <- ar_psd(c(1,0, 2), 1, n, range = "whole") expect_equal(which.max(psd$psd), (n / 4) + 1) psd <- ar_psd(c(1, 0, 2), 1, n, range = "centerdc") mx <- max(psd$psd, na.rm = TRUE) expect_equal(which(abs(psd$psd - mx) < tol), c(17, 49)) }) # ----------------------------------------------------------------------- # pow2db() test_that("parameters to pow2db() and db2pow() are correct", { expect_error(pow2db()) expect_error(pow2db('a')) expect_error(pow2db(1, 2)) expect_error(pow2db(-1)) expect_error(pow2db(c(-1, 2))) expect_error(db2pow()) expect_error(db2pow('a')) expect_error(db2pow(1, 2)) }) test_that("pow2db() tests are correct", { expect_equal(pow2db(0), -Inf) expect_equal(pow2db(-1 + 0i), 0 + 13.64376i, tolerance = 1e-4) expect_equal(db2pow(0), 1) expect_equal(db2pow(-1 + 0i), 0.7943 + 0i, tolerance = 1e-4) pow <- c(0, 10, 20, 60, 100) expect_equal(pow2db(pow), c(-Inf, 10, 13.01, 17.782, 20), tolerance = 1e-4) expect_equal(db2pow(pow2db(pow)), pow) db <- c(-10, 0, 10, 20, 25) expect_equal(db2pow(db), c(0.1, 1, 10, 100, 316.22777), tolerance = 1e-4) expect_equal(pow2db(db2pow(db)), db) }) gsignal/tests/testthat/test_Standard_Functions.R0000644000176200001440000000137614420222025021652 0ustar liggesusers# gsignal Standard Functions library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # detrend() test_that("parameters to detrend() are correct", { expect_error(detrend()) expect_error(detrend('invalid')) expect_error(detrend(1:10, -1)) expect_error(detrend(1:10, 'invalid')) expect_error(detrend(1:10, 0, 1)) }) test_that("detrend() tests are correct", { N <- 32 x <- seq(0, N - 1, 1) / N + 2 y <- detrend (x) expect_true(all(abs(y) < tol)) N <- 32 t <- seq(0, N - 1, 1) / N x <- t * t + 2 y <- detrend (x, 2) expect_true(all(abs(y) < tol)) N <- 32 t <- seq(0, N - 1, 1) / N x <- cbind(t, 4 * t - 3) y <- detrend (x) expect_true(all(abs(y) < tol)) }) gsignal/tests/testthat/test_gsignal-internal.R0000644000176200001440000000544514420222025021321 0ustar liggesusers# gsignal Internal functions library(gsignal) library(testthat) # ----------------------------------------------------------------------- # isScalar() test_that("parameters to isScalar() are correct", { expect_error(isScalar()) expect_error(isScalar(1, 2)) }) test_that("isScalar() returns TRUE or FALSE", { expect_equal(isScalar(1), TRUE) expect_equal(isScalar(c(1,2)), FALSE) expect_equal(isScalar(NULL), FALSE) expect_equal(isScalar(matrix(c(1,2,3,4),2,2)), FALSE) expect_equal(isScalar("t"), TRUE) expect_equal(isScalar("test"), FALSE) expect_equal(isScalar(c("test", "ing")), FALSE) expect_equal(isScalar(complex(real = 1, imaginary = 1)), TRUE) }) # ----------------------------------------------------------------------- # isPosscal() test_that("parameters to isPosscal() are correct", { expect_error(isPosscal()) expect_error(isPosscal(1, 2)) }) test_that("isPosscal returns TRUE or FALSE", { expect_equal(isPosscal(1), TRUE) expect_equal(isPosscal(-1), FALSE) expect_equal(isPosscal(c(1,2)), FALSE) expect_equal(isPosscal(NULL), FALSE) expect_equal(isPosscal(matrix(c(1,2,3,4),2,2)), FALSE) expect_equal(isPosscal("t"), FALSE) expect_equal(isPosscal(complex(real = 1, imaginary = 1)), FALSE) expect_equal(isPosscal(Re(complex(real = 1, imaginary = 1))), TRUE) }) # ----------------------------------------------------------------------- # isWhole() test_that("parameters to isWhole() are correct", { expect_error(isWhole()) expect_error(isWhole(1, 2, 3)) }) test_that("isWhole() returns TRUE or FALSE", { expect_equal(isWhole(1), TRUE) expect_equal(isWhole(-1), TRUE) expect_equal(isWhole(-12.5), FALSE) expect_equal(isWhole(c(1,2)), TRUE) expect_equal(isWhole(NULL), FALSE) expect_equal(isWhole(matrix(c(1,2,3,4),2,2)), TRUE) expect_equal(isWhole("t"), FALSE) expect_equal(isWhole(complex(real = 1, imaginary = 1)), TRUE) expect_equal(isWhole(complex(real = 1.1, imaginary = 1)), FALSE) expect_equal(isWhole(complex(real = 1, imaginary = 1.1)), FALSE) expect_equal(isWhole(Re(complex(real = 1, imaginary = 1))), TRUE) }) # ----------------------------------------------------------------------- # unfactor() test_that("parameters to unfactor() are correct", { expect_error(unfactor()) expect_error(unfactor(1, 2)) expect_warning(unfactor(as.factor("test"))) }) test_that("unfactor returns integer levels of factor", { expect_equal(unfactor(as.factor(c(1,2,3))), c(1,2,3)) expect_equal(unfactor(1), NULL) expect_equal(unfactor("test"), NULL) }) # ----------------------------------------------------------------------- # sinc() test_that("parameters to sinc() are correct", { expect_error(sinc()) expect_error(sinc(1, 2)) }) test_that("sinc() returns correct values", { expect_equal(sinc(0), 1L) expect_equal(round(sum(sinc(1:1e6)), 4), 0) }) gsignal/tests/testthat/test_Signals.R0000644000176200001440000004441614420222025017464 0ustar liggesusers# gsignal Signals functions library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # buffer() test_that("parameters to buffer() are correct", { expect_error(buffer()) expect_error(buffer(x = 1:10, n = 4.1)) expect_error(buffer(x = 1:10, n = 4, p = 3.1)) expect_error(buffer(x = 1:10, n = 4, p = 4)) expect_error(buffer(x = 1:10, n = 4, p = 1, opt = 10:11)) expect_error(buffer(x = 1:10, n = 4, p = 1, opt = 'badstring')) expect_error(buffer(x = 1:10, n = 3, p = -2, opt = 4)) expect_error(buffer(x = 1:10, n = 4, zopt = 5)) }) test_that("buffer() tests returning only y are correct", { expect_equal(buffer(1:10, 4), matrix(c(1:10, 0, 0), 4, 3)) expect_equal(buffer(1:10, 4, 1), matrix(c(0:3, 3:6, 6:9, 9, 10, 0, 0), 4, 4)) expect_equal(buffer(1:10, 4, 2), matrix(c(0, 0:2, 1:4, 3:6, 5:8, 7:10), 4, 5)) expect_equal(buffer(1:10, 4, 3), rbind(c(0, 0, 0:7), c(0, 0:8), 0:9, 1:10)) expect_equal(buffer(1:10, 4, -1), matrix(c(1:4, 6:9), 4, 2)) expect_equal(buffer(1:10, 4, -2), matrix(c(1:4, 7:10), 4, 2)) expect_equal(buffer(1:10, 4, -3), matrix(c(1:4, 8:10, 0), 4, 2)) expect_equal(buffer(1:10, 4, 1, 11), matrix(c(11,1:3,3:6,6:9,9,10,0,0), 4, 4)) expect_equal(buffer(1:10, 4, 1, 'nodelay'), matrix(c(1:4,4:7,7:10), 4, 3)) expect_equal(buffer(1:10, 4, 2, 'nodelay'), matrix(c(1:4,3:6,5:8,7:10), 4, 4)) expect_equal(buffer(1:10, 4, 3, c(11, 12, 13)), rbind(c(11:13, 1:7), c(12:13, 1:8), c(13, 1:9), 1:10)) expect_equal(buffer(1:10, 4, 3, 'nodelay'), rbind(1:8, 2:9, 3:10, c(4:10, 0))) expect_equal(buffer(1:11, 4, -2, 1), matrix(c(2:5, 8:11), 4, 2)) }) test_that("buffer() tests returning y, and z are correct", { buf <- buffer(1:12, 4, zopt = TRUE) expect_equal(buf$y, matrix(1:12, 4, 3)) expect_equal(buf$z, NULL) buf <- buffer(1:11, 4, zopt = TRUE) expect_equal(buf$y, matrix(1:8, 4, 2)) expect_equal(buf$z, 9:11) buf <- buffer(t(1:12), 4, zopt = TRUE) expect_equal(buf$y, matrix(1:12, 4, 3)) expect_equal(buf$z, NULL) # slightly different from Matlab implementation (column vector) # not sure if this matters - find field tests for this situation buf <- buffer(t(1:11), 4, zopt = TRUE) expect_equal(buf$y, matrix(1:8, 4, 2)) expect_equal(buf$z, 9:11) }) test_that("buffer() tests returning y, z, and opt are correct", { buf <- buffer(1:15, 4, -2, 1, zopt = TRUE) expect_equal(buf$y, matrix(c(2:5,8:11), 4, 2)) expect_equal(buf$z, c(14,15)) expect_equal(buf$opt, 0L) buf <- buffer(1:11, 4, -2, 1, zopt = TRUE) expect_equal(buf$y, matrix(c(2:5,8:11), 4, 2)) expect_equal(buf$z, NULL) expect_equal(buf$opt, 2) # slightly different from Matlab implementation (column vector) # not sure if this matters - find field tests for this situation buf <- buffer(t(1:15), 4, -2, 1, zopt = TRUE) expect_equal(buf$y, matrix(c(2:5,8:11), 4, 2)) expect_equal(buf$z, c(14,15)) expect_equal(buf$opt, 0L) buf <- buffer(t(1:11), 4, -2, 1, zopt = TRUE) expect_equal(buf$y, matrix(c(2:5,8:11), 4, 2)) expect_equal(buf$z, NULL) expect_equal(buf$opt, 2) buf <- buffer(1:11, 5, 2, c(-1,0), zopt = TRUE) expect_equal(buf$y, matrix(c(-1:3,2:6,5:9), 5, 3)) expect_equal(buf$z, c(10, 11)) expect_equal(buf$opt, c(8, 9)) buf <- buffer(t(1:11), 5, 2, c(-1,0), zopt = TRUE) expect_equal(buf$y, matrix(c(-1:3,2:6,5:9), 5, 3)) expect_equal(buf$z, c(10, 11)) expect_equal(buf$opt, c(8, 9)) buf <- buffer(t(1:10), 6, 4, zopt = TRUE) expect_equal(buf$y, matrix(c(rep(0, 4), 1:2, rep(0, 2), 1:4, 1:6, 3:8, 5:10), 6, 5)) expect_equal(buf$z, NULL) expect_equal(buf$opt, 7:10) }) test_that("buffer() works correctly with continuous buffering", { # overlap data <- buffer(1:1100, 11) n <- 4 p <- 1 buf <- list(y = NULL, z = NULL, opt = -5) for (i in seq_len(ncol(data))) { x <- data[,i] buf <- buffer(x = c(buf$z,x), n, p, opt=buf$opt, zopt = TRUE) } expect_equal(buf$y, matrix(c(1089:1092, 1092:1095, 1095:1098), 4, 3)) expect_equal(buf$z, c(1099, 1100)) expect_equal(buf$opt, 1098) # underlap data <- buffer(1:1100, 11) n <- 4 p <- -2 buf <- list(y = NULL, z = NULL, opt = 1) for (i in seq_len(ncol(data))) { x <- data[,i] buf <- buffer(x = c(buf$z,x), n, p, opt=buf$opt, zopt = TRUE) } expect_equal(buf$y, matrix(c(1088:1091, 1094:1097), 4, 2)) expect_equal(buf$z, 1100) expect_equal(buf$opt, 0) }) # ----------------------------------------------------------------------- # chirp() test_that("parameters to chirp() are correct", { expect_error(chirp()) expect_error(chirp(1, 2, 3, 4, 5, 6, 7)) expect_error(chirp(0, shape = "foo")) }) test_that("chirp() works for linear, quadratic and logarithmic shapes", { t <- seq(0, 5, 0.001) y <- chirp (t) expect_equal(sum(head(y)), 5.999952, tolerance = tol) expect_equal(sum(tail(y)), 2.146626e-05, tolerance = tol) t <- seq(-2, 15, 0.001) y <- chirp (t, 400, 10, 100, "quadratic") expect_equal(sum(head(y)), 0.8976858, tolerance = tol) expect_equal(sum(tail(y)), 0.4537373, tolerance = tol) t <- seq(0, 5, 1/8000) y <- chirp (t, 200, 2, 500, "logarithmic") expect_equal(sum(head(y)), -4.56818, tolerance = tol) expect_equal(sum(tail(y)), 0.8268064, tolerance = tol) }) # ----------------------------------------------------------------------- # cmorwavf() test_that("parameters to cmorwavf() are correct", { expect_error(cmorwavf(n = -1)) expect_error(cmorwavf(n = 2.5)) expect_error(cmorwavf(fb = -1)) expect_error(cmorwavf(fb = 0)) expect_error(cmorwavf(fc = -1)) expect_error(cmorwavf(fc = 0)) }) test_that("cmorwavf() works correctly", { expect_equal(round(mean(Re(cmorwavf(-8, 8, 1000, 1.5, 1)$psi)), 4), 0) expect_equal(round(mean(Im(cmorwavf(-8, 8, 1000, 1.5, 1)$psi)), 4), 0) expect_lt(max(Re(cmorwavf(-8, 8, 1000, 1.5, 1)$psi)), 1L) expect_lt(max(Im(cmorwavf(-8, 8, 1000, 1.5, 1)$psi)), 1L) expect_gt(min(Re(cmorwavf(-8, 8, 1000, 1.5, 1)$psi)), -1L) expect_gt(min(Im(cmorwavf(-8, 8, 1000, 1.5, 1)$psi)), -1L) }) # ----------------------------------------------------------------------- # diric() test_that("parameters to diric() are correct", { expect_error(diric()) expect_error(diric(seq(-2*pi, 2*pi, len = 301))) expect_error(diric(seq(-2*pi, 2*pi, len = 301), 0)) expect_error(diric(seq(-2*pi, 2*pi, len = 301), -1)) expect_error(diric(seq(-2*pi, 2*pi, len = 301), 2.5)) }) # ----------------------------------------------------------------------- # gauspuls() test_that("parameters to gauspuls() are correct", { expect_error(gauspuls()) expect_error(gauspuls(seq(-2*pi, 2*pi, len = 301), -1)) expect_error(gauspuls(seq(-2*pi, 2*pi, len = 301), 2, 0)) expect_error(gauspuls(seq(-2*pi, 2*pi, len = 301), 2, -1)) }) # ----------------------------------------------------------------------- # gmonopuls() test_that("parameters to gmonopuls() are correct", { expect_error(gmonopuls()) expect_error(gmonopuls(seq(-2*pi, 2*pi, len = 301), -1)) }) # ----------------------------------------------------------------------- # mexihat() test_that("parameters to mexihat() are correct", { expect_error(mexihat(n = -1)) expect_error(mexihat(n = 2.5)) }) # ----------------------------------------------------------------------- # meyeraux() test_that("parameters to meyeraux() are correct", { expect_error(meyeraux()) }) # ----------------------------------------------------------------------- # morlet() test_that("parameters to morlet() are correct", { expect_error(morlet(n = -1)) expect_error(morlet(n = 2.5)) }) # ----------------------------------------------------------------------- # pulstran() test_that("parameters to pulstran() are correct", { expect_error(pulstran()) expect_error(pulstran(NULL)) expect_error(pulstran(1, 2, 3, 4, 5, 6)) expect_error(pulstran(d = seq(0, 0.1, 0.01))) }) test_that("rectpuls() works correctly", { t <- seq(0, 1, 0.01) d <- seq(0, 1, 0.1) expect_equal(pulstran(NA, d, 'sin'), NA_integer_) expect_equal(pulstran(t, NULL, 'sin'), rep(0L, length(t))) expect_equal(pulstran(seq(0, 0.1, 0.001)), rep(0L, length(seq(0, 0.1, 0.001)))) expect_equal(length(pulstran(t, d, 'sin')), length(t)) }) # ----------------------------------------------------------------------- # rectpuls() test_that("parameters to rectpuls() are correct", { expect_error(rectpuls()) expect_error(rectpuls(NULL, 0.1)) expect_error(rectpuls(seq(-2*pi, 2*pi, len = 301), -1)) expect_error(rectpuls(seq(-2*pi, 2*pi, len = 301), 1, 3)) expect_error(rectpuls(seq(-2*pi, 2*pi, len = 301), 1i)) }) test_that("rectpuls() works correctly", { expect_equal(rectpuls(0, 0), 0L) expect_equal(rectpuls(0, 0.1), 1L) expect_equal(rectpuls(rep(0L, 10)), rep(1L, 10)) expect_equal(rectpuls(-1:1), c(0, 1, 0)) expect_equal(rectpuls(-5:5, 9), c(0, rep(1L, 9), 0)) }) # ----------------------------------------------------------------------- # sawtooth() test_that("parameters to sawtooth() are correct", { expect_error(sawtooth()) expect_error(sawtooth(NULL, 0.1)) expect_error(sawtooth(0:10, -1)) expect_error(sawtooth(0:10, 2)) expect_error(sawtooth(0:10, 1, 3)) expect_error(sawtooth(0:10, 1i)) }) test_that("sawtooth() works correctly", { expect_equal(sawtooth(0, 0), 1L) expect_equal(sawtooth(0, 1), -1L) expect_equal(sawtooth(rep(0L, 10)), rep(-1L, 10)) }) # ----------------------------------------------------------------------- # square() test_that("parameters to square() are correct", { expect_error(square()) expect_error(square(NULL, 1)) expect_error(square(0:10, -1)) expect_error(square(0:10, 150)) expect_error(square(0:10, 1, 3)) expect_error(square(0:10, 1i)) }) test_that("square() works correctly", { expect_equal(square(0, 0), -1L) expect_equal(square(0, 1), 1L) expect_equal(square(rep(0L, 10)), rep(1L, 10)) expect_equal(square(1:12, 50), rep(c(rep(1,3), rep(-1, 3)), 2)) }) # ----------------------------------------------------------------------- # tripuls() test_that("parameters to tripuls() are correct", { expect_error(tripuls()) expect_error(tripuls(NULL, 1)) expect_error(tripuls(0:10, c(0,1))) expect_error(tripuls(0:10, 1, -2)) expect_error(tripuls(0:10, 1, 2)) expect_error(tripuls(0:10, 1i)) }) test_that("tripuls() works correctly", { expect_equal(tripuls(0, 1), 1L) expect_equal(tripuls(rep(0L, 10)), rep(1L, 10)) }) # ----------------------------------------------------------------------- # shanwavf() test_that("parameters to shanwavf() are correct", { expect_error(shanwavf(n = -1)) expect_error(shanwavf(n = 2.5)) expect_error(shanwavf(fb = -1)) expect_error(shanwavf(fb = 0)) expect_error(shanwavf(fc = -1)) expect_error(shanwavf(fc = 0)) }) test_that("shanwavf() works correctly", { expect_equal(mean(Re(shanwavf(-20, 20, 1000, 1.5, 1)$psi)), 0, tolerance = 1e-3) expect_equal(mean(Im(shanwavf(-20, 20, 1000, 1.5, 1)$psi)), 0, tolerance = 1e-3) }) # ----------------------------------------------------------------------- # shiftdata() test_that("parameters to shiftdata() are correct", { expect_error(shiftdata()) expect_error(shiftdata(1, 2, 3)) expect_error(shiftdata(1, 2.5)) expect_error(shiftdata(1, 2i)) expect_error(shiftdata(1:5, 2)) expect_error(shiftdata(array(1:24, c(2,3)), 3)) }) test_that("shiftdata() works correctly", { sd <- shiftdata(matrix(1:9, 3, 3, byrow = TRUE), 2) expect_equal(sd$x, matrix(c(1, 4, 7, 2, 5, 8, 3, 6, 9), 3, 3, byrow = TRUE)) expect_equal(sd$perm, c(2,1)) expect_equal(sd$nshifts, NA) sd <- shiftdata(array(c(27, 63, 67, 42, 48, 74, 11, 5, 93, 15, 34, 70, 23, 60, 54, 81, 28, 38), c(3, 3, 2)), 2) expect_equal(sd$x, array(c(27, 42, 11, 63, 48, 5, 67, 74, 93, 15, 23, 81, 34, 60, 28, 70, 54, 38), c(3, 3, 2))) expect_equal(sd$perm, c(2, 1, 3)) expect_equal(sd$nshifts, NA) X <- array(round(runif(4 * 4 * 4 * 4) * 100), c(4, 4, 4, 4)) Y <- shiftdata(X, 3) T <- NULL for (i in 1:3) { for (j in 1:3) { for (k in 1:2) { for (l in 1:2) { T <- c(T, Y$x[k, i, j, l] - X[i, j, k ,l]) } } } } expect_equal(T, rep(0L, length(T))) }) # ----------------------------------------------------------------------- # unshiftdata() test_that("parameters to unshiftdata() are correct", { expect_error(unshiftdata()) expect_error(unshiftdata(1, 2, 3)) expect_error(unshiftdata(1)) expect_error(unshiftdata(2i)) #expect_error(unshiftdata(list(x = 1:5, perm = 1, nshifts = 0))) expect_error(unshiftdata(list(x=array(1:5), perm = 2i, nshifts = 0))) expect_error(unshiftdata(list(x=array(1:5), perm = NULL, nshifts = NULL))) }) test_that("unshiftdata() works correctly", { x <- 1:5 sd <- shiftdata(x) x2 <- unshiftdata(sd) expect_equal(array(x), x2) x <- array(round(runif(3 * 3) * 100), c(3, 3)) sd <- shiftdata(x, 2) x2 <- unshiftdata(sd) expect_equal(x, x2) x <- array(round(runif(4 * 4 * 4 * 4) * 100), c(4, 4, 4, 4)) sd <- shiftdata(x, 3) x2 <- unshiftdata(sd) expect_equal(x, x2) x <- array(round(runif(1 * 1 * 3 * 4) * 100), c(1, 1, 3, 4)) sd <- shiftdata(x) x2 <- unshiftdata(sd) expect_equal(x, x2) }) # ----------------------------------------------------------------------- # sigmoid_train() test_that("parameters to sigmoid_train() are correct", { expect_error(sigmoid_train()) expect_error(sigmoid_train(1:10, NULL, NULL)) expect_error(sigmoid_train(1:10, rbind(c(1,2),1), NULL)) expect_error(sigmoid_train(1:10, rbind(c(1,2),1), 2i)) }) test_that("sigmoid_train() works correctly", { st <- sigmoid_train(1:10, rbind(c(2,3)), 1) expect_equal(st$y, st$s, tolerance = tol) st <- sigmoid_train(1:10, c(2,3), 1) expect_equal(st$y, st$s, tolerance = tol) }) # ----------------------------------------------------------------------- # specgram() test_that("parameters to specgram() are correct", { expect_error(specgram()) expect_error(specgram(matrix(1:10, 2, 5))) expect_error(specgram(x = 1:10, n = 4.1)) expect_warning(specgram(x = 1:10, n = 11)) expect_warning(specgram(x = 1:10, n = 2, window = 1:11)) expect_error(specgram(x = 1:10, n = 2, overlap = 3)) }) test_that("specgram() works correctly", { sp <- specgram(chirp(seq(-2, 15, by = 0.001), 400, 10, 100, 'quadratic')) expect_equal(length(sp$f), 128L) expect_equal(length(sp$t), 131L) expect_equal(nrow(sp$S), length(sp$f)) expect_equal(ncol(sp$S), length(sp$t)) }) # ----------------------------------------------------------------------- # uencode() test_that("parameters to uencode() are correct", { expect_error(uencode()) expect_error(uencode(1)) expect_error(uencode(1, 2, 3, 4, 5)) expect_error(uencode(1, 100)) expect_error(uencode(1, 4, 0)) expect_error(uencode(1, 4, -1)) expect_error(uencode(1, 4, 2, 'invalid')) }) test_that("uencode() works correctly", { expect_equal(uencode(seq(-3, 3, 0.5), 2), c(0, 0, 0, 0, 0, 1, 2, 3, 3, 3, 3, 3, 3)) expect_equal(uencode(seq(-4, 4, 0.5), 3, 4), c(0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 7)) expect_equal(uencode(seq(-8, 8, 0.5), 4, 8, FALSE), c(0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 13, 13, 14, 14, 15, 15, 15)) expect_equal(uencode(seq(-8, 8, 0.5), 4, 8, TRUE), c(-8, -8, -7, -7, -6, -6, -5, -5, -4, -4, -3, -3, -2, -2, -1, -1, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 7)) expect_equal(uencode(matrix(c(-2, 1, -1, 2), 2, 2), 2), matrix(c(0, 3, 0, 3), 2, 2)) expect_equal(uencode(matrix(c(1+1i, 2+1i, 3+1i, 4+2i, 5+2i, 6+2i, 7+3i, 8+3i, 9+3i), 3, 3, byrow = TRUE), 2), matrix(rep(3, 9), 3, 3)) }) # ----------------------------------------------------------------------- # udecode() test_that("parameters to udecode() are correct", { expect_error(udecode()) expect_error(udecode(1)) expect_error(udecode(1, 2, 3, 4, 5)) expect_error(udecode(1, 100)) expect_error(udecode(1, 4, 0)) expect_error(udecode(1, 4, -1)) expect_error(udecode(1, 4, 2, 'invalid')) }) test_that("udecode() works correctly", { expect_equal(udecode(c(rep(0, 5), 1, 2, rep(3, 6)), 2), c(-1, -1, -1, -1, -1, -0.5, 0, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)) expect_equal(udecode(0:10, 2, 1, TRUE), c(-1, -0.5, 0, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5)) expect_equal(udecode(0:10, 2, 1, FALSE), c(-1, -0.5, 0, 0.5, -1, -0.5, 0, 0.5, -1, -0.5, 0)) expect_equal(udecode(-4:3, 3, 2), c(-2, -1.5, -1, -0.5, 0, 0.5, 1, 1.5)) expect_equal(udecode(-7:7, 3, 2, TRUE), c(-2, -2, -2, -2, -1.5, -1, -0.5, 0, 0.5, 1, 1.5, 1.5, 1.5, 1.5, 1.5)) expect_equal(udecode(-7:7, 3, 2, FALSE), c(0.5, 1, 1.5, -2, -1.5, -1, -0.5, 0, 0.5, 1, 1.5, -2, -1.5, -1, -0.5)) expect_equal(udecode(matrix(c(-2, 1, -1, 2), 2, 2), 2), matrix(c(-1, 0.5, -0.5, 0.5), 2, 2)) expect_equal(udecode(matrix(c(1+1i, 2+1i, 3+1i, 4+2i, 5+2i, 6+2i, 7+3i, 8+3i, 9+3i), 3, 3, byrow = TRUE), 2), matrix(complex(real = c(-0.5, 0.0, rep(0.5, 7)), imaginary = c(rep(-0.5, 3), rep(0, 3), rep(0.5,3))), 3, 3)) }) # ----------------------------------------------------------------------- # sinetone() test_that("parameters to sinetone() are correct", { expect_error(sinetone()) expect_error(sinetone('invalid')) expect_error(sinetone(-1)) expect_error(sinetone(1, 'invalid')) expect_error(sinetone(1, 0)) expect_error(sinetone(1, 1, 'invalid')) expect_error(sinetone(1, 1, 0)) expect_error(sinetone(1, 1, 1, 'invalid')) expect_error(sinetone(1, 1, 1, 1, 1)) }) test_that("sinetone() works correctly", { y <- sinetone(0) expect_equal(length(y), 8000) expect_equal(y, rep(0, 8000)) y <-sinetone (18e6, 150e6, 19550/150e6, 1) expect_equal(length(y), 19550) }) # ----------------------------------------------------------------------- # sinewave() test_that("parameters to sinewave() are correct", { expect_error(sinewave()) expect_error(sinewave(1, 'invalid')) expect_error(sinewave(1, 1, 'invalid')) expect_error(sinewave(1, 2, 3, 4)) }) test_that("sinetone() works correctly", { expect_equal(sinewave(1), 0) expect_equal(sinewave(1, 4, 1), 1) expect_equal(sinewave(1, 12, 1), 1 / 2, tolerance = tol) expect_equal(sinewave(1, 12, 2), sqrt(3) / 2, tolerance = tol) expect_equal(sinewave(1, 20, 1), (sqrt(5) - 1) / 4, tolerance = tol) expect_equal(sinewave(1), sinewave(1, 1, 0), tolerance = tol) expect_equal(sinewave(3, 4), sinewave(3, 4, 0), tolerance = tol) }) gsignal/tests/testthat/test_Miscellaneous_Functions.R0000644000176200001440000003334114420222025022712 0ustar liggesusers# gsignal Miscellaneous Functions library(gsignal) library(testthat) # ----------------------------------------------------------------------- # ifft() and imvfft() test_that("parameters to ifft() are correct", { expect_error(ifft()) expect_error(ifft('invalid')) expect_error(ifft(1, -2)) expect_error(ifft(1, 2, 3, 4, 5)) }) test_that("ifft() tests are correct", { expect_equal(ifft(stats::fft(1:10)), 1:10) expect_equal(ifft(stats::fft(c(1+5i, 2+3i, 3+2i, 4+6i, 5+2i))), c(1+5i, 2+3i, 3+2i, 4+6i, 5+2i)) expect_equal(imvfft(stats::mvfft(matrix(1:20, 4, 5))), matrix(1:20, 4, 5)) }) # ----------------------------------------------------------------------- # pad(), prepad(), postpad() test_that("parameters to pad() are correct", { expect_error(pad()) expect_error(pad('invalid')) expect_error(pad(1, -2)) expect_error(pad(1, 2, 3, 4, 5, 6)) }) test_that("pad() tests are correct", { v <- 1:24 expect_equal(postpad(v, 30), c(1:24, rep(0, 6))) expect_equal(postpad(v, 20), 1:20) expect_equal(prepad(v, 30), c(rep(0, 6), 1:24)) expect_equal(prepad(v, 20), 5:24) m <- matrix(1:24, 4, 6) expect_equal(postpad(m, 8, 100), matrix(c(1:4, rep(100, 4), 5:8, rep(100, 4), 9:12, rep(100, 4), 13:16, rep(100, 4), 17:20, rep(100, 4), 21:24, rep(100, 4)), 8, 6, byrow = FALSE)) expect_equal(postpad(m, 8, 100, MARGIN = 1), matrix(c(1:24, rep(100, 8)), 4, 8)) expect_equal(prepad(m, 8, 100), matrix(c(rep(100, 4), 1:4, rep(100, 4), 5:8, rep(100, 4), 9:12, rep(100, 4), 13:16, rep(100, 4), 17:20, rep(100, 4), 21:24), 8, 6, byrow = FALSE)) expect_equal(prepad(m, 8, 100, MARGIN = 1), matrix(c(rep(100, 8), 1:24), 4, 8)) expect_equal(postpad(m, 2), matrix(c(1, 2, 5, 6, 9, 10, 13, 14, 17, 18, 21, 22), 2, 6)) expect_equal(postpad(m, 2, MARGIN = 1), matrix(1:8, 4, 2)) expect_equal(prepad(m, 2), matrix(c(3, 4, 7, 8, 11, 12, 15, 16, 19, 20, 23, 24), 2, 6)) expect_equal(prepad(m, 2, MARGIN = 1), matrix(17:24, 4, 2)) }) # ----------------------------------------------------------------------- # poly() test_that("parameters to poly() are correct", { expect_error(poly()) expect_error(poly('invalid')) expect_error(poly(1, 2)) expect_error(poly(matrix(1:6, 2, 3))) }) test_that("poly() tests are correct", { expect_equal(poly(0), c(1, 0)) expect_equal(poly(1), c(1, -1)) expect_equal(poly(-1), c(1, 1)) expect_equal(poly(c(1, 2, 3)), c(1, -6, 11, -6)) expect_equal(poly(matrix(1:4, 2, 2, byrow = TRUE)), c(1, -5, -2)) expect_equal(poly(c(-1 + 1i)), c(1 + 0i, 1 - 1i)) }) # ----------------------------------------------------------------------- # filter() test_that("parameters to filter() are correct", { expect_error(filter()) expect_error(filter(1, 2)) expect_error(filter(1, 2, 'invalid')) expect_error(filter(1, 1, 1:10, 'invalid')) expect_error(filter(c(1, 1), 1, 1:10, c(0, 0))) }) test_that("filter() tests are correct", { a <- c(1, 1) b <- c(1, 1) x <- c(1, rep(0L, 9)) expect_equal(filter(b, 1, x), c(rep(1L, 2), rep(0L, 8))) filt <- Ma(b) expect_equal(filter(filt, x), c(rep(1L, 2), rep(0L, 8))) expect_equal(filter(1, a, x), rep(c(1L, -1L), 5)) filt <- Arma(b, a) expect_equal(filter(filt, x), c(1L, rep(0L, 9))) # # complex input # r <- sqrt (1/2) * (1 + 1i) # a <- a * r # b <- b * r # expect_equal(suppressWarnings(filter (b, 1, x)), Re(r * c(rep(1L, 2), rep(0L, 8)))) # expect_equal(suppressWarnings(filter (b, a, x)), c(1L, rep(0L, 9))) a <- c(1, 1) b <- c(1, 1) x <- c(1, rep(0L, 9)) lst <- filter (b, 1, x, -1) expect_equal(lst[['y']], c(0, 1, 0, 0, 0, 0, 0, 0, 0, 0)) expect_equal(lst[['zf']], 0) b <- c(1, 1) x <- y0 <- matrix(0L, 10, 3) x[1, 1] <- -1; x[1, 2] <- 1 y0[1:2, 1] <- -1; y0[1:2, 2] <- 1 y <- filter(b, 1, x) expect_equal(y, y0) expect_equal(filter(1, rep(1, 10) / 10, NULL), NULL) expect_equal(filter(1, rep(1, 10) / 10, rep(0,10)), rep(0,10)) expect_equal(filter(1, rep(1, 10) / 10, 1:5), rep(10, 5)) # Test using initial conditions expect_equal(filter(c(1, 1, 1), c(1, 1), c(1, 2), c(1, 1))[['y']], c(2, 2)) expect_equal(filter(c(1, 3), 1, matrix(1:6, ncol = 2, byrow = TRUE), matrix(c(4, 5), ncol = 2))[['y']], matrix(c(5, 7, 6, 10, 14, 18), ncol = 2, byrow = TRUE)) }) # ----------------------------------------------------------------------- # conv() test_that("parameters to conv() are correct", { expect_error(conv()) expect_error(conv(1)) expect_error(conv(1, 2, 3, 4)) expect_error(conv(1, 2, 'invalid')) }) test_that("conv() tests are correct", { x <- rep(1L, 3); b <- 2; c <- 3 expect_equal(conv(x, x), c(1, 2, 3, 2, 1)) expect_equal(conv(x, b), rep(2L, 3)) expect_equal(conv(b, x), rep(2L, 3)) expect_equal(conv(x, c), rep(3L, 3)) expect_equal(conv(c, x), rep(3L, 3)) expect_equal(conv(b, c), 6) a <- 1:10; b <- 1:3 expect_equal(length(conv (a,b)), length(a) + length(b) - 1) expect_equal(length(conv (b,a)), length(a) + length(b) - 1) expect_equal(conv(a, b, "full"), conv (a,b)) expect_equal(conv(b, a, "full"), conv (b,a)) expect_equal(conv(a, b, "same"), c(4, 10, 16, 22, 28, 34, 40, 46, 52, 47)) expect_equal(conv(b, a, "same"), c(28, 34, 40)) expect_equal(conv(a, b, "valid"), c(10, 16, 22, 28, 34, 40, 46, 52)) expect_equal(conv(b, a, "valid"), NULL) expect_equal(conv(a, a, "valid"), 220L) expect_equal(conv(b, b, "valid"), 10L) }) # ----------------------------------------------------------------------- # fftconv() test_that("parameters to fftconv() are correct", { expect_error(fftconv()) expect_error(fftconv(1)) expect_error(fftconv(1, 2, 3, 4)) }) test_that("fftconv() tests are correct", { x <- rep(1L, 3); b <- 2; c <- 3 expect_equal(fftconv(x, x), c(1, 2, 3, 2, 1)) expect_equal(fftconv(x, b), rep(2L, 3)) expect_equal(fftconv(b, x), rep(2L, 3)) expect_equal(fftconv(x, c), rep(3L, 3)) expect_equal(fftconv(c, x), rep(3L, 3)) expect_equal(fftconv(b, c), 6) a <- 1:10; b <- 1:3 expect_equal(length(fftconv (a,b)), length(a) + length(b) - 1) expect_equal(length(fftconv (b,a)), length(a) + length(b) - 1) expect_equal(fftconv(a, b, NULL), fftconv (a,b)) expect_equal(fftconv(b, a, NULL), fftconv (b,a)) }) # ----------------------------------------------------------------------- # conv2() test_that("parameters to conv2() are correct", { expect_error(conv2()) expect_error(conv2(1)) expect_error(conv2(1, 2, 3, 4)) expect_error(conv2(matrix(1,1), matrix(2,1), 'invalid')) }) test_that("conv2() tests are correct", { a <- matrix(1:16, 4, 4) b <- matrix(1:9, 3,3) ans <- matrix(c(1, 9, 36, 84, 115, 91, 4, 29, 99, 207, 263, 202, 10, 62, 192, 372, 446, 334, 16, 83, 237, 417, 485, 358, 17, 75, 198, 330, 365, 263, 12, 48, 120, 192, 204, 144), 6, 6, byrow = TRUE) expect_equal(conv2(a, b), ans) expect_equal(conv2(a, b, 'same'), ans[2:5, 2:5]) expect_equal(conv2(a, b, 'valid'), ans[3:4, 3:4]) a <- matrix(c(1:5, 1:5), 2, 5, byrow = TRUE) b <- matrix(1:2, 1, 2) ans <- matrix(rep(c(1,4,7,10,13,10),2),2,6, byrow=T) expect_equal(conv2(a, b), ans) expect_equal(conv2(a, b, 'same'), ans[1:2, 2:6]) expect_equal(conv2(a, b, 'valid'), ans[1:2, 2:5]) }) # ----------------------------------------------------------------------- # cplxpair() test_that("parameters to cplxpair() are correct", { expect_error(cplxpair()) expect_error(cplxpair(1, -1)) expect_error(cplxpair(1, 2, 3, 4)) expect_error(cplxpair(c(2000 * (1 + .Machine$double.eps) + 4i, 2000 * (1 - .Machine$double.eps) - 4i), 0)) expect_error(cplxpair(c(2e6 + 1i, 2e6 - 1i, 1e-9 * (1 + 1i), 1e-9 * (1 - 2i)))) }) test_that("cplxpair() tests are correct", { expect_equal(cplxpair(1), 1) expect_equal(cplxpair(c(1 + 1i, 1-1i)), c(1 - 1i, 1 + 1i)) expect_equal(cplxpair(c(1 + 1i, 1 + 1i, 1, 1 - 1i, 1 - 1i, 2)), c(1 - 1i, 1 + 1i, 1 - 1i, 1 + 1i, 1, 2)) expect_equal(cplxpair(c(0, 1, 2)), c(0, 1, 2)) expect_equal(cplxpair(c(2000 * (1 + .Machine$double.eps) + 4i, 2000 * (1 - .Machine$double.eps) - 4i)), c(2000 - 4i, 2000 + 4i)) z <- c(1 + 1i, 1 + 1i, 1, 1 - 1i, 1 - 1i, 2) ans <- cplxpair(z) m <- cbind(z, z) expect_equivalent(cplxpair(m, MARGIN = 2), cbind(ans, ans)) expect_error(cplxpair(m, MARGIN = 1)) # shared z,y z <- exp (2i * pi * c(4, 3, 5, 2, 6, 1, 0) / 7) z[2] <- Conj(z[1]) z[4] <- Conj(z[3]) z[6] <- Conj(z[5]) expect_equal(cplxpair(z[pracma::randperm(7)]), z) expect_equal(cplxpair(z[pracma::randperm(7)]), z) expect_equal(cplxpair(z[pracma::randperm(7)]), z) expect_equal(cplxpair(cbind(z[pracma::randperm(7)], z[pracma::randperm(7)])), cbind(z, z, deparse.level = 0)) expect_equal(cplxpair(cbind(z[pracma::randperm(7)], z[pracma::randperm(7)])), cbind(z, z, deparse.level = 0)) y <- c(-1-1i, -1+1i, -3, -2, 1, 2, 3) expect_equal(cplxpair(cbind(z[pracma::randperm(7)], y[pracma::randperm(7)], deparse.level = 0)), cbind(z, y, deparse.level = 0)) expect_equal(cplxpair(cbind(z[pracma::randperm(7)], y[pracma::randperm(7)], z[pracma::randperm(7)], deparse.level = 0)), cbind(z, y, z, deparse.level = 0)) # Test tolerance expect_equal(cplxpair(c(2000 * (1 + .Machine$double.eps) + 4i, 2000 * (1 - .Machine$double.eps) - 4i)), c(2000 - 4i, 2000 + 4i), tolerance = 100 * .Machine$double.eps) expect_error(cplxpair(c(2000 * (1 + .Machine$double.eps) + 4i, 2000 * (1 - .Machine$double.eps) - 4i), tol = 0)) expect_error(cplxpair(c(2e6+1i, 2e6-1i, 1e-9 * (1+1i), 1e-9 * (1-2i)))) }) # ----------------------------------------------------------------------- # unwrap() test_that("parameters to unwrap() are correct", { expect_error(unwrap()) expect_error(unwrap('invalid')) expect_error(unwrap(1 + 0i, 0)) expect_error(unwrap(matrix(1), 2, 3)) }) test_that("unwrap() tests are correct", { # shared i, t, r, w, tol i <- 0 t <- NULL r <- 0:100 w <- r - 2 * pi * floor((r + pi) / (2 * pi)) tol <- 1e3 * .Machine$double.eps expect_equal(unwrap(w), r, tolerance = tol) expect_equivalent(unwrap(cbind(w, w)), cbind(r, r)) ## Test that small values of tol have the same effect as tol = pi expect_equal(unwrap(w, 0.1), r) expect_equal(unwrap(w, tol), r) ## Test that phase changes larger than 2*pi unwrap properly expect_equal(unwrap(c(0, 1)), c(0, 1)) expect_equal(unwrap(c(0, 4)), c(0, 4 - 2 * pi)) expect_equal(unwrap(c(0, 7)), c(0, 7 - 2 * pi)) expect_equal(unwrap(c(0, 10)), c(0, 10 - 4 * pi)) expect_equal(unwrap(c(0, 13)), c(0, 13 - 4 * pi)) expect_equal(unwrap(c(0, 16)), c(0, 16 - 6 * pi)) expect_equal(unwrap(c(0, 19)), c(0, 19 - 6 * pi)) expect_lt(max(abs(diff(unwrap(100 * pi * runif(1000, 1))))), pi) A <- c(pi*(-4), pi*(-2+1/6), pi/4, pi*(2+1/3), pi*(4+1/2), pi*(8+2/3), pi*(16+1), pi*(32+3/2), pi*64) expect_equal(unwrap(A), unwrap(A, pi)) }) # ----------------------------------------------------------------------- # mpoles() test_that("parameters to mpoles() are correct", { expect_error(mpoles()) expect_error(mpoles(1, 2, 3, 4, 5)) expect_error(mpoles(1, 'invalid', TRUE, TRUE)) expect_error(mpoles(1, 0.001, 'invalid', TRUE)) expect_error(mpoles(1, 0.001, TRUE, 'invalid')) }) test_that("mpoles() tests are correct", { res <- mpoles(c(0, 0), 0.01) expect_equal(res, c(1, 2)) p <- c(2, 3, 1, 1, 2) res <- mpoles (p, index.return = TRUE) expect_equal(res$m, c(1, 1, 2, 1, 2)) expect_equal(res$n, c(2, 5, 1, 4, 3)) expect_equal(p[res$n], c(3, 2, 2, 1, 1)) }) # ----------------------------------------------------------------------- # polyreduce() test_that("parameters to polyreduce() are correct", { expect_error(polyreduce()) expect_error(polyreduce(NULL)) expect_error(polyreduce(1, 2)) }) test_that("polyreduce() tests are correct", { expect_equal(polyreduce(c(0, 0, 1, 2, 3)), c(1, 2, 3)) expect_equal(polyreduce(c(1, 2, 3, 0, 0)), c(1, 2, 3, 0, 0)) expect_equal(polyreduce(c(1, 0, 3)), c(1, 0, 3)) expect_equal(polyreduce(c(0, 0, 0)), 0) }) # ----------------------------------------------------------------------- # residue() and rresidue() test_that("parameters to residue() are correct", { expect_error(residue()) expect_error(residue(NULL)) expect_error(residue(1, 2, 3, 4)) expect_error(rresidue()) expect_error(rresidue(NULL)) expect_error(rresidue(1, 2, 3, 4, 5)) }) test_that("residue() tests are correct", { tol <- 1e-6 b <- c(1, 1, 1) a <- c(1, -5, 8, -4) rpk <- residue (b, a) expect_equal(Re(rpk$r), c(-2, 7, 3)) expect_equal(Re(rpk$p), c(2, 2, 1)) expect_null(rpk$k) ba <- rresidue (rpk$r, rpk$p, rpk$k) expect_equal(Re(ba$b), b) expect_equal(Re(ba$a), a) b <- c(1, 0, 1) a <- c(1, 0, 18, 0, 81) rpk <- residue (b, a) expect_equal(rpk$r, c(-5i, 12, +5i, 12) / 54, tolerance = tol) expect_equal(rpk$p, c(+3i, +3i, -3i, -3i)) expect_null(rpk$k) ba <- rresidue (rpk$r, rpk$p, rpk$k) expect_equal(Re(ba$b), c(0, b)) expect_equal(Re(ba$a), a) r <- c(7, 3, -2) p <- c(2, 1, 2) k <- c(1, 0) ba <- rresidue(r, p, k) expect_equal(Re(ba$b), c(1, -5, 18, -39, 28)) expect_equal(Re(ba$a), c(1, -5, 8, -4)) rpk <- residue(ba$b, ba$a) mn <- mpoles(p, index.return = TRUE) expect_equal(sort(Re(rpk$r)), sort(r[mn$n])) b <- 1 a <- c(1, 10, 25) rpk <- residue (b, a) expect_equal(Re(rpk$r), c(0, 1)) expect_equal(Re(rpk$p), c(-5, -5)) expect_null(rpk$k) ba <- rresidue (rpk$r, rpk$p, rpk$k) expect_equal(Re(ba$b), b) expect_equal(Re(ba$a), a) }) gsignal/tests/testthat/test_System_Identification_Functions.R0000644000176200001440000000727314420222025024411 0ustar liggesusers# gsignal System Identification Functions library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # arburg() test_that("parameters to arburg() are correct", { expect_error(arburg()) expect_error(arburg('a')) expect_error(arburg(c(0,0))) expect_error(arburg(1:10, -1)) expect_error(arburg(1:10, 9)) expect_error(arburg(1:10, 7, 'invalid')) }) test_that("arburg() tests are correct", { cf <- arburg(rep(0L, 5), 1) expect_equal(cf$a, c(1, NaN)) expect_equal(cf$e, NaN) expect_equal(cf$k, NaN) cf <- arburg(c(1L, rep(0L, 4)), 1) expect_equal(cf$a, c(1, 0)) expect_equal(cf$e, 0.2) expect_equal(cf$k, 0) cf <- arburg(c(1L, 0L, 1L, 0L, 0L), 1) expect_equal(cf$a, c(1, 0)) expect_equal(cf$e, 0.4) expect_equal(cf$k, 0) cf <- arburg(c(1L, 0L, 1L, 0L, 0L), 2) expect_equal(cf$a, c(1, 0, -2 / 3), tolerance = tol) expect_equal(cf$e, 2 / 9, tolerance = tol) expect_equal(cf$k, c(0, -2 / 3), tolerance = tol) x <- filter(1, c(1, -0.75, 0.5), 0.2 * rnorm(1024)) y <- cbind(x, x) cf <- arburg(y, 2) expect_equal(ncol(cf$a), 3) expect_equal(nrow(cf$a), 2) expect_equal(length(cf$e), 2) expect_equal(ncol(cf$k), 2) expect_equal(nrow(cf$k), 2) expect_equal(cf$a[1, ], cf$a[2, ], tolerance = tol) expect_equal(cf$e[1], cf$e[2], tolerance = tol) expect_equal(cf$k[, 1], cf$k[, 1], tolerance = tol) }) # ----------------------------------------------------------------------- # levinson() test_that("parameters to levinson() are correct", { expect_error(levinson()) expect_error(levinson('invalid')) expect_error(levinson(1:10, -1)) expect_error(levinson(1:10, 'invalid')) expect_error(levinson(1:10, 7, 'invalid')) }) test_that("levinson() tests are correct", { cf <- levinson(rep(0L, 5), 1) expect_equal(cf$a, c(1, NaN)) expect_equal(cf$e, NaN) expect_equal(cf$k, NaN) cf <- levinson(c(1L, rep(0L, 4)), 1) expect_equal(cf$a, c(1, 0)) expect_equal(cf$e, 1) expect_equal(cf$k, 0) cf <- levinson(c(1L, 0L, 1L, 0L, 0L), 2) expect_equal(cf$a, c(1, 0, -1)) expect_equal(cf$e, 0) expect_equal(cf$k, c(0, -1)) x <- filter(1, c(1, -0.75, 0.5), 0.2 * rnorm(1024)) y <- cbind(x, x) cf <- levinson(y, 2) expect_equal(ncol(cf$a), 3) expect_equal(nrow(cf$a), 2) expect_equal(length(cf$e), 2) expect_equal(ncol(cf$k), 2) expect_equal(nrow(cf$k), 2) expect_equal(cf$a[1, ], cf$a[2, ], tolerance = tol) expect_equal(cf$e[1], cf$e[2], tolerance = tol) expect_equal(cf$k[, 1], cf$k[, 1], tolerance = tol) }) # ----------------------------------------------------------------------- # aryule() test_that("parameters to aryule() are correct", { expect_error(aryule()) expect_error(aryule('invalid')) expect_error(aryule(c(0,0))) expect_error(aryule(1:10, -1)) expect_error(aryule(1:10, 'invalid')) expect_error(aryule(1:10, 7, 'invalid')) }) test_that("aryule() tests are correct", { cf <- aryule(rep(0L, 5), 1) expect_equal(cf$a, c(1, NaN)) expect_equal(cf$e, NaN) expect_equal(cf$k, NaN) cf <- aryule(c(1L, rep(0L, 4)), 1) expect_equal(cf$a, c(1, 0)) expect_equal(cf$e, 0.2) expect_equal(cf$k, 0) cf <- aryule(c(1L, 0L, 1L, 0L, 0L), 2) expect_equal(cf$a, c(1, 0, -0.5)) expect_equal(cf$e, 0.3) expect_equal(cf$k, c(0, -0.5)) x <- filter(1, c(1, -0.75, 0.5), 0.2 * rnorm(1024)) y <- cbind(x, x) cf <- aryule(y, 2) expect_equal(ncol(cf$a), 3) expect_equal(nrow(cf$a), 2) expect_equal(length(cf$e), 2) expect_equal(ncol(cf$k), 2) expect_equal(nrow(cf$k), 2) expect_equal(cf$a[1, ], cf$a[2, ], tolerance = tol) expect_equal(cf$e[1], cf$e[2], tolerance = tol) expect_equal(cf$k[, 1], cf$k[, 1], tolernce = tol) }) gsignal/tests/testthat/test_Filter_Conversion_Functions.R0000644000176200001440000002234214473620311023550 0ustar liggesusers# gsignal Filter Conversion functions library(gsignal) library(testthat) tol <- 1e-6 # ----------------------------------------------------------------------- # sos2tf() test_that("parameters to sos2tf() are correct", { expect_error(sos2tf()) expect_error(sos2tf(1, 2, 3)) }) test_that("sos2tf() tests are correct", { sos <- rbind(c(1, 1, 1, 1, 0, -1), c(-2, 3, 1, 1, 10, 1)) ba <- sos2tf(sos) expect_equal(ba$b, c(-2, 1, 2, 4, 1)) expect_equal(ba$a, c(1, 10, 0, -10, -1)) ba <- sos2tf(sos, 2) expect_equal(ba$b, c(-4, 2, 4, 8, 2)) expect_equal(ba$a, c(1, 10, 0, -10, -1)) ba <- sos2tf(sos, c(2, 2, 2)) expect_equal(ba$b, c(-16, 8, 16, 32, 8)) expect_equal(ba$a, c(1, 10, 0, -10, -1)) }) # ----------------------------------------------------------------------- # sos2zp() test_that("parameters to sos2zp() are correct", { expect_error(sos2zp()) expect_error(sos2zp(1, 2, 3)) }) test_that("sos2zp() tests are correct", { sos <- rbind(c(1, 2, 3, 1, 0.2, 0.3), c(4, 5, 6, 1, 0.4, 0.5)) zref <- c(-1-1.41421356237310i, -1+1.41421356237310i, -0.625-1.05326872164704i, -0.625+1.05326872164704i) pref <- c(-0.2-0.678232998312527i, -0.2+0.678232998312527i, -0.1-0.538516480713450i, -0.1+0.538516480713450i) kref <- 4 zpg <- sos2zp(sos, 1) expect_equal(cplxpair(zpg$z, tol), as.vector(zref), tolerance = tol) expect_equal(cplxpair(zpg$p, tol), as.vector(pref), tolerance = tol) expect_equal(zpg$g, 4) }) # ----------------------------------------------------------------------- # tf2zp() test_that("parameters to tf2zp() are correct", { expect_error(tf2zp()) expect_error(tf2zp(1, 2, 3)) expect_error(tf2zp('invalid', 'invalid')) }) test_that("tf2zp() tests are correct", { b <- c(2, 3) a <- c(1, 1/sqrt(2), 1/4) zpk <- tf2zp(b, a) expect_equal(zpk$z, sort(pracma::roots(b))) expect_equal(zpk$p, sort(pracma::roots(a)), tolerance = tol) expect_equal(zpk$g, 2) }) # ----------------------------------------------------------------------- # zp2sos() test_that("parameters to zp2sos() are correct", { expect_error(zp2sos()) expect_error(zp2sos(1, 2, 3, 4)) expect_error(zp2sos('invalid', 'invalid')) }) test_that("zp2sos() tests are correct", { sosg <- zp2sos(c(0+1i, 0-1i), c(0+1i, 0-1i)) expect_equal(sosg$sos, matrix(c(1, 0, 1, 1, 0, 1), 1)) expect_equal(sosg$g, 1) sosg <- zp2sos(c(1+1i, 1-1i), c(1+1i, 1-1i)) expect_equal(sosg$sos, matrix(c(1, -2, 2, 1, -2, 2), 1)) expect_equal(sosg$g, 1) sosg <- zp2sos(c(1+1i, 1-1i), c(1+1i, 1-1i), 3) expect_equal(sosg$sos, matrix(c(1, -2, 2, 1, -2, 2), 1)) expect_equal(sosg$g, 3) # these are slightly different in Matlab (b[0] and b[1] swapped), # and produce errors in Octave expect_equal(as.vector(zp2sos(NULL, 0, 0)$sos), c(1, 0, 0, 1, 0, 0)) expect_equal(as.vector(zp2sos(NULL, 1, 0)$sos), c(1, 0, 0, 1, -1, 0)) expect_equal(as.vector(zp2sos(NULL, -1, 1)$sos), c(1, 0, 0, 1, 1, 0)) }) # ----------------------------------------------------------------------- # tf2sos() test_that("parameters to tf2sos() are correct", { expect_error(tf2sos()) expect_error(tf2sos(1, 2, 3)) expect_error(tf2sos('invalid', 'invalid')) }) test_that("tf2sos() tests are correct", { b <- c(1, 0, 0, 0, 0, 1) a <- c(1, 0, 0, 0, 0, .9) sosg <- tf2sos (b, a) sec1 <- c(1, 0.618034, 1, 1, 0.6051470, 0.9587315) sec2 <- c(1, -1.618034, 1, 1, -1.5842953, 0.9587315) sec3 <- c(1, 1.000000, 0, 1, 0.9791484, 0.0000000) expect_equal(sosg$sos, rbind(sec1, sec2, sec3, deparse.level = 0), tolerance = 1e-6) # these are slightly different in Matlab (b[0] and b[1] swapped), # and produce errors in Octave sosg <- tf2sos(c(0, 0), c(1,1)) expect_equal(as.vector(sosg$sos), c(1, 0, 0, 1, 1, 0)) expect_equal(sosg$g, 1) }) # ----------------------------------------------------------------------- # zp2tf() test_that("parameters to zp2tf() are correct", { expect_error(zp2tf()) expect_error(zp2tf(1, 2, 3, 4)) expect_error(zp2tf('invalid', 'invalid')) }) test_that("zp2tf() tests are correct", { ba <- zp2tf(c(0, 0), pracma::roots(c(1, 0.01, 1)), 1) expect_equal(ba$b, c(1, 0, 0)) expect_equal(ba$a, c(1, 0.01, 1)) # design 2-pole notch filter at pi/4 radians = 0.5/4 = 0.125 * fs w <- pi/4 # zeroes at r = 1 r <- 1 z1 <- r * exp(1i * w) z2 <- r * exp(1i * -w) # poles at r = 0.9 r <- 0.9 p1 <- r * exp(1i * w) p2 <- r * exp(1i * -w) zeros <- c(z1, z2) poles <- c(p1, p2) ba <- zp2tf(zeros, poles, 1) inv <- tf2zp(ba$b, ba$a) expect_equal(sort(inv$z), sort(zeros), tolerance = tol) expect_equal(sort(inv$p), sort(poles), tolerance = tol) expect_equal(inv$g, 1) }) # ----------------------------------------------------------------------- # residuez() test_that("parameters to residuez() are correct", { expect_error(residuez()) expect_error(residuez(1, 2, 3)) expect_error(residuez('invalid', 'invalid')) }) test_that("residuez() tests are correct", { b <- c(1, -2, 1); a <- c(1, -1) rpk <- residuez(b, a) expect_equal(rpk$r, 0) expect_equal(rpk$p, 1) expect_equal(rpk$k, c(1, -1)) b <- 1; a <- c(1, -1i) rpk <- residuez(b, a) expect_equal(rpk$r, 1) expect_equal(rpk$p, 1i) expect_null(rpk$k) b <- 1; a <- c(1, -1, 0.25) rpk <- residuez(b, a) s <- sort(rpk$r, index.return = TRUE) expect_equal(s$x, c(0, 1)) expect_equal(rpk$p[s$ix], c(0.5, 0.5)) expect_null(rpk$k) b <- 1; a <- c(1, -0.75, 0.125) rpk <- residuez(b, a) s <- sort(rpk$r, index.return = TRUE) expect_equal(s$x, c(-1, 2)) expect_equal(rpk$p[s$ix], c(0.25, 0.5)) expect_null(rpk$k) b <- c(1, 6, 2); a <- c(1, -2, 1) rpk <- residuez(b, a) s <- sort(rpk$r, index.return = TRUE) expect_equal(s$x, c(-10, 9)) expect_equal(rpk$p[s$ix], c(1, 1)) expect_equal(rpk$k, 2) b <- c(6, 2); a <- c(1, -2, 1) rpk <- residuez(b, a) s <- sort(rpk$r, index.return = TRUE) expect_equal(s$x, c(-2, 8)) expect_equal(rpk$p[s$ix], c(1, 1)) expect_null(rpk$k) b <- c(1, 6, 6, 2); a <- c(1, -2, 1) rpk <- residuez(b, a) s <- sort(rpk$r, index.return = TRUE) expect_equal(s$x, c(-24, 15)) expect_equal(rpk$p[s$ix], c(1, 1)) expect_equal(rpk$k, c(10, 2)) b <- c(1, 6, 6, 2); a <- c(1, -(2+1i), (1+2i), -1i) rpk <- residuez(b, a) s <- sort(Mod(rpk$r), index.return = TRUE) expect_equal(rpk$r[s$ix], c(-2+2.5i, 7.5+7.5i, -4.5-12i)) expect_equal(rpk$p[s$ix], c(1i, 1, 1)) expect_equal(rpk$k, 2i) b <- c(1, 0, 1); a <- c(1, 0, 0, 0, 0, -1) rpk <- residuez(b, a) s <- sort(Arg(rpk$p), index.return = TRUE) rise <- c(0.26180339887499 - 0.19021130325903i, 0.03819660112501 + 0.11755705045849i, 0.4, 0.03819660112501 - 0.11755705045849i, 0.26180339887499 + 0.19021130325903i) pise <- c(-0.80901699437495 - 0.58778525229247i, 0.30901699437495 - 0.95105651629515i, 1, 0.30901699437495 + 0.95105651629515i, -0.80901699437495 + 0.58778525229247i) expect_equal(rpk$r[s$ix], rise, tolerance = tol) expect_equal(rpk$p[s$ix], pise, tolerance = tol) expect_null(rpk$k) # Github Issue #15 rpk <-residuez(c(1+3i,-3i), c(1,-1)) expect_equal(rpk$r, 1) expect_equal(rpk$p, 1) expect_equal(rpk$k, 0+3i) rpk <-residuez(3, 2) expect_null(rpk$r) expect_null(rpk$p) expect_equal(rpk$k, 1.5) }) # ----------------------------------------------------------------------- # residued() test_that("parameters to residued() are correct", { expect_error(residued()) expect_error(residued(1, 2, 3)) expect_error(residued('invalid', 'invalid')) }) test_that("residued() tests are correct", { b <- 1; a <- c(1, -1) rpk <- residued(b, a) expect_equal(rpk, list(r = 1, p = 1, k = NULL)) rpk2 <- residuez(b, a) expect_equal(rpk, rpk2) #residuez and residued should be identical when length(b) < length(a) b <- c(1, -2, 1); a <- c(1, -1) rpk <- residued(b, a) expect_equal(rpk, list(r = 0, p = 1, k = c(1, -1))) b <- c(1, -2, 1); a <- c(1, -0.5) rpk <- residued(b, a) expect_equal(rpk, list(r = 0.25, p = 0.5, k = c(1, -1.5))) b <- 1; a <- c(1, -0.75, 0.125) rpk <- residued(b, a) rpk2 <- residuez(b, a) expect_equal(rpk, rpk2) #residuez and residued should be identical when length(b) < length(a) b <- 1; a <- c(1, -2, 1) rpk <- residued(b, a) rpk2 <- residuez(b, a) expect_equal(rpk, rpk2) #residuez and residued should be identical when length(b) < length(a) b <- c(6, 2); a <- c(1, -2, 1) rpk <- residued(b, a) rpk2 <- residuez(b, a) expect_equal(rpk, rpk2) #residuez and residued should be identical when length(b) < length(a) b <- c(1, 1, 1); a <- c(1, -2, 1) rpk <- residued(b, a) expect_equal(rpk$r, c(0, 3)) expect_equal(rpk$p, c(1, 1)) expect_equal(rpk$k, 1) b <- c(2, 6, 6, 2); a <- c(1, -2, 1) rpk <- residued(b, a) expect_equal(rpk$r, c(8, 16)) expect_equal(rpk$p, c(1, 1)) expect_equal(rpk$k, c(2, 10)) b <- c(1, 6, 2); a <- c(1, -2, 1) rpk <- residued(b, a) expect_equal(rpk$r, c(-1, 9)) expect_equal(rpk$p, c(1, 1)) expect_equal(rpk$k, 1) b <- c(1, 0, 0, 0, 1); a <- c(1, 0, 0, 0, -1) rpk <- residued(b, a) s <- sort(Arg(rpk$p), index.return = TRUE) expect_equal(rpk$r[s$ix], c(-1 / 2, -1i / 2, 1 / 2, 1i / 2)) expect_equal(rpk$p[s$ix], c(-1, -1i, 1, 1i)) expect_equal(rpk$k, 1) }) gsignal/tests/testthat.R0000644000176200001440000000007214420222025015013 0ustar liggesuserslibrary(testthat) library(gsignal) test_check("gsignal") gsignal/MD50000644000176200001440000004615114670417477012236 0ustar liggesusers5b4473596678d62d9d83096273422c8c *COPYING 1a25257934c020ddd86bc6f2a93ba287 *DESCRIPTION 7480ef5651f13acc24786b25612ad28b *NAMESPACE d3b67e06b36bea96ca8607494d73050c *NEWS.md b5075f65c4b3165847b284534ab12c15 *R/Arma.R 8e5216c00ea812b9b959d3b0493fb105 *R/FilterSpecs.R 3f5297ff2da7e318f7cfdf404750339e *R/Ma.R ce3ce85ff49463326e7811892b0194f4 *R/RcppExports.R da65e3c7b9f3b2d4ec885235600fe2cc *R/Sos.R 9748186b25703958e99f690d61ae5755 *R/Zpg.R 91bb7d34679bccc04b4552a73a37b1b6 *R/ar_psd.R eb436eff11489faa60bc0b862892b7cf *R/arburg.R a5bf99ea45a7c81ba417511e7a85b16f *R/aryule.R 6522947f9f831b050b4c3b32f23bc46c *R/barthannwin.R 3cc6fafaa00052f61ffa4af4bde46c72 *R/bartlett.R 1f51acbd8f3a82122f1671969dbdd0c2 *R/besselap.R a202d3efb96ce5b5b656636f7d3f792a *R/besself.R e12a20325b5678c859eba1a3739cd871 *R/bilinear.R d73e9659dfb3bf3d1ba5b8965b2aee17 *R/bitrevorder.R d522189f4a9c82f76a5081c15e371e52 *R/blackman.R 1e9d62f90867b1812f598020572451db *R/blackmanharris.R a8746ed505283b88f3f22095ecfc21be *R/blackmannuttall.R a982cbf91366f13620f458546fec6bf7 *R/bohmanwin.R e9fa47991df9adbd42508ca805bd2636 *R/boxcar.R 2d6794b5258cd5b8a9f680e2745c9c30 *R/buffer.R 2620039a7ea31f0e55621eb476c0da0c *R/buttap.R ff0893f78045e1afb153942bed71ea67 *R/butter.R ee218bb9e1415fd5be6a74777a1f30e8 *R/buttord.R 0eb0fabfe088d187d2e9f1f146a74775 *R/cceps.R 13d07cd151e50934838a64391a448b19 *R/cconv.R 89b678e50cca16377778de18122a669b *R/cheb.R b3bf53d6019c19dbd6eceeb6770a6e35 *R/cheb1ap.R d19d297b88af8b19faced6372faa4e1d *R/cheb1ord.R 47cc6cb289dfc748b2dc785e29a03a95 *R/cheb2ap.R fadacb6047c819ad22038da3f59f87d6 *R/cheb2ord.R 1d1f9e2246fd52c571a507185a534016 *R/chebwin.R 88ad5d4e3b2655ee2a87607861624787 *R/cheby1.R 92d0c86a821e4cd70fcfe52a776db810 *R/cheby2.R 0de3d576b150d78ec54b9790105c6581 *R/chirp.R e586c19629d4999b96989552901c2e91 *R/cl2bp.R 89202e961b5f5826e13a9de35392a5b2 *R/clustersegment.R bfe0a5858b2ff9abf8d490a502840f4f *R/cmorwavf.R ad5b9e65bc70bcdb6aef4383c23b0f70 *R/conv.R 007c0995e6a903a77529a2243bb0f149 *R/conv2.R a7cbb0b17640862d1f2c6aed15fbc63a *R/convmtx.R c8a5ffcae835c90b98dcc31e95137c0f *R/cplxpair.R e3f61b6ed862be64d7562915118b6b8e *R/cplxreal.R ce80a98f1bbee43485e5597aac178a12 *R/cpsd.R dd641cc7d56391799ab8f5765603a9f0 *R/czt.R 5ea0a350456f46d93460d2191e290da0 *R/dct.R 701b934743db6214b68ab38d27a84950 *R/dct2.R c3be67c44f25f2fb191e2212b88f72bf *R/dctmtx.R fd6e1a1807af92e2fa062702c8b978ae *R/decimate.R 3748bfc012632bc74572dbce61ddf7a7 *R/detrend.R ea64f3aeee4fad7d15d7372a749a9532 *R/dftmtx.R 1410fcaddda8bcc2983907f3b70652d9 *R/digitrevorder.R 52ac22afa7253eb4dc7992b581e96396 *R/diric.R 40e801640437b15c8321f931170d0c5e *R/downsample.R e56300f14a1feda177e0b15d84fd91f0 *R/dst.R f12fef899b82eb4d29758c9aef064c6c *R/dwt.R 2fdd2188f048b64b26960ba5990ca257 *R/ellip.R e559f971bf3b3ecba3e1550cb408c16a *R/ellipap.R 77441361845b37453ae8dfa7ba0c5aed *R/ellipord.R fd28b77173508794b60cd7f8546f5211 *R/fftconv.R ef975bfe542f331b93f99155559165fb *R/fftfilt.R 37baa9d6f59b7d5bc718e37dddce589d *R/fftshift.R df08b4a1bff99022a73750c4c0639637 *R/fht.R 12eaa9b5205b5d82fcc45baf7dde766d *R/filter.R d1ab0e10881e317e44322dab6785bda5 *R/filter2.R ca27b2777cc14d4f5f37775799c09283 *R/filter_zi.R efd756c2ebd4a4d4a5bad1cd2a7470d6 *R/filtfilt.R 2d5772bbf1df00ec59b1c6d65688d62a *R/filtic.R 46046d9c988a5c074e7bc0ad49f8b793 *R/findpeaks.R 4e724a12410a5d6f1c1adb9833330d64 *R/fir1.R a58909002fb999185c1f6578cd55bd82 *R/fir2.R 78099e0ce02c17fc1d76a8bd303eca39 *R/firls.R 0d27255f8f999ce8d45dba8d4f257e4b *R/flattopwin.R eee862359bf70e31646cf11bbcd7dba0 *R/fracshift.R b70dbe484978c989c36b7af79f305244 *R/freqs.R 78bb9597e489e07ee92d758a33924430 *R/freqz.R 8082f68570dd3b5e0d5992fd7acf3fb3 *R/fwhm.R d1182eac39f29739eaaf845c2b4dd260 *R/fwht.R 481397645470bf62ec5649d44a95a21b *R/gauspuls.R 56bedff577dd2992a7113cb2cfdd03de *R/gaussian.R bd076ddd5d7579ce844e3d8761e247a0 *R/gausswin.R 3e7038684c2e763d43c47982518af5ce *R/gmonopuls.R 65c53446361982137a39f9a68328a8ed *R/grpdelay.R 0d7f3b3517b9a24addd11574f82d6262 *R/gsignal-internal.R e37ee1ff206e6cc630c8efb22335206e *R/gsignal-package.R ef4dd46bc264539f30af9f7161804fbe *R/gsignal.R 0c3e7f636f6ea0395f056dfe6ce829a0 *R/hamming.R 8a9a4de10d07415399c4c9eba30a0454 *R/hanning.R 831f343744779c51d929791f62140438 *R/hilbert.R fee9ce9df6a95f8ecc291b85fd172f2d *R/idct.R aea0eff2095cdbbd150c23c3da1a4db4 *R/idct2.R 41a7748d5196b565bf195e69de564586 *R/idst.R 4486136951e7c16297d00e1048fc94ed *R/ifft.R c9d1434b91a7d206934f0f7fd0522249 *R/ifftshift.R 2ac8c1b2d9fb392d9a136a9fa14cbd02 *R/iirlp2mb.R f94239e8ce742e77884c9f0adf5bec86 *R/impinvar.R 00e7ce1cb81b116209fbb1230c420a24 *R/impz.R e050d22cd9eec556aedc960a13d03f52 *R/interp.R f5c9c2811a8bfd31c5cbd8030b4a24a7 *R/invfreq.R 8c326f7f36cda494953b7b7e7e2d15ba *R/invimpinvar.R b7620d5cfbc5caac7d74077964c6af1a *R/kaiser.R 0b67d700d0e91cbc99326d21c3e04971 *R/kaiserord.R d26107884b2b615175b4d9c08c35bedd *R/levinson.R d648df1dd2d6f699bc8dae240095395b *R/marcumq.R 626a5b264ff9ed1761aa40c4bb438ebb *R/medfilt1.R 746e324559fe8d543723d8fd2f70deef *R/mexihat.R ba9c73fd83b3cf84a7ce64b134ff5653 *R/meyeraux.R 51688598f393129c25f6bcb4237639a6 *R/morlet.R 35458e9bf41bad5a3d4c30dbb904a187 *R/movingrms.R a903d7c91a56690d21730f9d49251f77 *R/mpoles.R 975a151ab3c1a9cc31241e50d78e7905 *R/mscohere.R 056285c43d9974e775eb6299f53e7418 *R/ncauer.R 7109011ce74873284a24ca6232850d1e *R/nuttallwin.R ca8d1f665a446967659cd2f2e0cb58e6 *R/pad.R 7ee0ccacdb1a5778c4ce161d64085410 *R/parzenwin.R dd6c4903b05f13b3140674d542dc5221 *R/pburg.R 6144a8775b49385f0898e128a8dcba88 *R/peak2peak.R 4c96285a61841893ea92f56f036f5491 *R/peak2rms.R d874f3486f4ed226f8c79cba64d82b04 *R/pei_tseng_notch.R 92ab7aad76fcac24d37aae2627d793d3 *R/poly.R af2a380522450e7589f5cd4cfd1d768d *R/polyreduce.R deb4f0a95e45133407e70320801bc57b *R/polystab.R 34ff28238837631140e85134915a472f *R/pow2db.R 3536425249d6a93bf40d69155074681e *R/primitive.R a5ec1a217b955b20a9436898bcafbe06 *R/pulstran.R 1bd861e0fed94fc54876ba70b0f59270 *R/pwelch.R 4c246a5f0a30c87b1c49484357a12735 *R/pyulear.R 0df070b51ce77117c4fd9bf915a13f9b *R/qp_kaiser.R 5366b1d9459ead1e1b9ca08918117975 *R/rceps.R bbd37aed2228b45775341789f4ad7026 *R/rectpuls.R 1124808c2d61320d444c9a1eaef7bcf8 *R/rectwin.R 2a6ffa94899ccd41213d1d8537dfec6b *R/remez.R 01e897472ce06d552383fed3d0d5e64d *R/resample.R a8b52439650d8e149e5de3b345c15342 *R/residue.R be4eb9c23d895d85f9671fdf7575c2bb *R/residued.R 7753f67ecec95b3f0c2afdb087fde06c *R/residuez.R 6085db0e5bf255105312fcdea8aea533 *R/rms.R 82009b258c2130cfa05f550ed3083ffb *R/rssq.R 05368ea69192d1629bdfdf6a4f25a3b1 *R/sampled2continuous.R c39e13e64284df517699257f0a9ba495 *R/sawtooth.R 181b5b327e61e977e465993be70da596 *R/schtrig.R 862b7c526e7c3f7ff8a1b8b5de0453f0 *R/sftrans.R 19aa65b53a8e82b3736d56408679e503 *R/sgolay.R 8a40fc9c8cbe63f1b0273a4cd2bf8f66 *R/sgolayfilt.R b5095b365143dce1a2389c397f64d900 *R/shanwavf.R 0b9eea7b2b38086cb0f5973b0ebbe6f6 *R/shiftdata.R 32e31d2fe579a24ebb40c9a83283d184 *R/sigmoid_train.R 97d8a855f1bce66b43d357f0ef051559 *R/signals.R 1dc679e41b0619940ecdeed9bd34c64a *R/sinetone.R 88e157f8c48c5f1a4e9e870d3cae17d7 *R/sinewave.R 7acdfbfdef03f18651af06960a4e1548 *R/sos2tf.R 5325f94f566a9ef825cb266854672799 *R/sos2zp.R 79b7a72464b2c3899f9d55533a36437d *R/sosfilt.R c3cde47651a2da216a18b0a3632a35fe *R/specgram.R 8a0a556732ff0af957a5d1c98debea6f *R/square.R 2a39dd5fb89bbd3ef004e6de31d7831f *R/stft.R 12f777d03a719cec261b40e95531cb00 *R/tf2sos.R 80bbf81c7ecfce39b259798e23d2d347 *R/tf2zp.R db786bbb9274fe3a5cdc3c11ae8b5d66 *R/tfestimate.R 30bc2d7620063c2bc2ffe0aa22fc3b79 *R/triang.R 258ec1a00ed369f97a75c14a62d44321 *R/tripulse.R 3590c3f1026932de6f3bbf5fadbf937d *R/tukeywin.R 5bf4561081b64fa23572a1592f38e030 *R/udecode.R 08f235e6a591244c8bc3be7d0764d052 *R/uencode.R 3bb3ac63524a49e259fe11dc06babee1 *R/ultrwin.R d785418b22fd035e38952c39761b1e12 *R/unshiftdata.R e539d3fe8ef7da829951ee8dd05853ae *R/unwrap.R 417492381d4561f997d015b6d0de935f *R/upfirdn.R 72f77ad1f36eb995410d78534890c02c *R/upsample.R a1a6cb4cf6312d311559c8df540f9297 *R/upsamplefill.R 8247fe8dca44e12b865e3a43d68e872f *R/wconv.R 05da4282ccc8889e4e95f26fbf38e2d8 *R/welchwin.R 43a86d769b0a8ed270d2be6d1fae4e89 *R/wkeep.R 8e5c3cd5c7f0a8d7ea6edeb0cff1db72 *R/xcorr.R 9b8857ad782424ffc608cf3023ba963a *R/xcorr2.R 01b1b4d1a728d042e2c80c789408adb5 *R/xcov.R 51d1198f9fa685de28da0cd7b1f70989 *R/zerocrossing.R 96f002ad31c61197ffb1d6bc99f2f4e8 *R/zp2sos.R c46d587843af6075dc3582cf7c785a6a *R/zp2tf.R 1cc6c0d5a1ad4b161f29cb170c7a082a *R/zplane.R 35cb6ba75887cf29a887d50968e34fb1 *README.md aa5e5a2cbfaea3d9b6cdbe378ac48cee *build/partial.rdb 148fe3348b6e4efca1c4fbd134411d80 *build/vignette.rds e7193755ef523e165f889e21c38ae8ba *data/signals.rda bab6ee3b8b593cece7be9824b6cc7b9c *inst/CITATION 7fa0d1b6ccb27bb5377531f5bdc499d3 *inst/COPYRIGHTS cbda6fd85a38872970304dae1c8c5712 *inst/doc/gsignal.R e14f3ef83493eabdff9d3e636e132a47 *inst/doc/gsignal.Rmd 9344c5738e6ce2d0a36b4699761b84d5 *inst/doc/gsignal.html 6269bb074ba01ea484690fe98e458266 *man/Arma.Rd f1451339db6593b86b8205d8f4004c4b *man/FilterSpecs.Rd 9dbee4537f6944c063ff2a3db9f93a13 *man/Ma.Rd 31d18871a84f28978e002e4ce60ac3e1 *man/Sos.Rd ca6db7bbce0e80b207c92c75f3518a87 *man/Zpg.Rd 15a184e2717ba1d4be1901e40cbc3a48 *man/ar_psd.Rd 2ca6eb863d69bb7b98c4ce19c43b4780 *man/arburg.Rd 228445979b0b46f4ed59e14f41832528 *man/aryule.Rd 69a7f072d072e13b463c9ed9dc92242d *man/barthannwin.Rd abea68e1f4f84bc0af60e9e0eabc7fda *man/bartlett.Rd 7830ecf60b715adef81f11eb90867c3c *man/besselap.Rd e752325e73f62bf28f4367954c9bab79 *man/besself.Rd d9f177513e6dee2257c6550927948f9d *man/bilinear.Rd cf2b62cc3417d4b3baefd3c5983315a5 *man/bitrevorder.Rd 2f8d1c9de255685fa1e7866e4035aeb5 *man/blackman.Rd 8db87fb69e9424e812eba9e61c116ba4 *man/blackmanharris.Rd 3761b06788ffba2574d05d6dc122fc2d *man/blackmannuttall.Rd 3f38a0ecb5edee6d7ba320549985330c *man/bohmanwin.Rd 404d6d311102240356be815e69ea700f *man/boxcar.Rd 61ffdcfd9dea8ca3ff89d0b08446a1da *man/buffer.Rd bd884389e4b948903a762a6a7fed2639 *man/buttap.Rd 31856b368c926970c0475927cdb9df36 *man/butter.Rd b70837d43dab88355cc26f733e265dd6 *man/buttord.Rd f1f95f4ddb18b4331974e574c32fb7f6 *man/cceps.Rd d13260dea5e67c33ddfbec0d88a2b610 *man/cconv.Rd 7b36ecbf2f89b2892e78796c1da6c904 *man/cheb.Rd 981a3e49abedbeade11c9ea808e26ad0 *man/cheb1ap.Rd 5ca67e4e9978917d24c12b3b1652c6f9 *man/cheb1ord.Rd 46775f7cd72eb8a6380bd81fc6d4b4ec *man/cheb2ap.Rd 2aacb0e26597a5a96ceb1ba4c36e9eda *man/cheb2ord.Rd 65cca5d30c4e09e7491013f737996652 *man/chebwin.Rd 3fbc43e74621f0defdddd2d8f336b3f3 *man/cheby1.Rd 060a4d5553699a0cfd1b693ed4245005 *man/cheby2.Rd b24c2d70887cd920a613c6680b6ad419 *man/chirp.Rd 317e915c5de6a9af965263bbecda2643 *man/cl2bp.Rd 236b2b5464254ef02ac5a93531cdb3db *man/clustersegment.Rd 54e990d3b6d6061f8198855d59321530 *man/cmorwavf.Rd a6e9f3385f7eab37094d5732ce3e364b *man/conv.Rd 1fa089155eb06ef010374d8b76a989d5 *man/conv2.Rd 8d6411a053ad643d218a01a65a139b1a *man/convmtx.Rd 245916cc2d7ee703447365bb9813fcba *man/cplxpair.Rd 955277515e7906d4702e4a0550ed5e0f *man/cplxreal.Rd 3107b5c710068412890904c9eb95c9f2 *man/cpsd.Rd 95bc947c9cf536283387f4f910adca04 *man/czt.Rd 1838d75e121b6d9037e4417ba30508f3 *man/dct.Rd c6d3339ba47c8c274193485851035de4 *man/dct2.Rd 03919db76b3be9173d2a90486c6fce75 *man/dctmtx.Rd bd424cc64bd9f291393d6bb96b4986bc *man/decimate.Rd d1e43142683b1b51a4d46baf2e01f098 *man/detrend.Rd fd40f79c8731a505d2b480a84021982a *man/dftmtx.Rd d5fd044923c6d5df184212cc98b37db4 *man/digitrevorder.Rd ba673a4d4e48c9738c1296999a715526 *man/diric.Rd 9d38f5962ecdc53130691fb35b77572a *man/downsample.Rd 3ae60d127f7a8308b2636263a39e1568 *man/dst.Rd 63a9f5ce0a801cd3d947245035339f9b *man/dwt.Rd c63b84ff8b876b02705c15f34251382a *man/ellip.Rd cfe2a3fc113ee12ff45b59d344f2d7ea *man/ellipap.Rd d5226e33f6b587176bd790defaffeedb *man/ellipord.Rd a42e19e2768c3003c7f1a9b940cde849 *man/fftconv.Rd 56c265f68ec958e74e561618768a0ff1 *man/fftfilt.Rd 8410914f56e3c9b8bfbf852f0f45dc9a *man/fftshift.Rd dce073a96b254d4e65415a6270f2d73b *man/fht.Rd 4a57116e8be116311fb1e3f1cd1f3351 *man/figures/gsignal_logo.png 406218980066885e3aab2e2495bdd4e4 *man/filter.Rd 992feef344c23a9a9376b375b305ef05 *man/filter2.Rd 67e1b57585ab1a1a9853c2f9efc4e15e *man/filter_zi.Rd 38f907448d13ec76849004fe7f24f948 *man/filtfilt.Rd 25fd1cd40f00bd0d4c04098a4f607ad2 *man/filtic.Rd a40e7419a33a2e98449f368bed0b103e *man/findpeaks.Rd 36bfa562625fe77d52b8f0dcdb3cbf3c *man/fir1.Rd 1eb16d0581d1322783133977217182e1 *man/fir2.Rd 7291f094b2d3c2afd50a21a997b74b5c *man/firls.Rd d72fdeb054f6bb1bf8fdbf8878ad8518 *man/flattopwin.Rd a6bae9ffc38bff22e699ec836a500ad6 *man/fracshift.Rd 2766ce4a959b57b82b71bdace3c430f9 *man/freqs.Rd e2213ba71468197570d891089708e9aa *man/freqz.Rd 5114f15d313292a04ad51f8815708fa3 *man/fwhm.Rd 4c03f73c4894582d8f6a6604a44972e3 *man/fwht.Rd 6785ea0b1894457c71da453047fe7ed0 *man/gauspuls.Rd b215ed35f1abcb5557b4f7c4de8f68d1 *man/gaussian.Rd bfa777f6c19225db2c4c4d00b58b4842 *man/gausswin.Rd 8b80175aa5aefa5541e70f8942fa703e *man/gmonopuls.Rd f9685242939c6d97512a8b4fd904d220 *man/grpdelay.Rd a07da9075356be126effe4c9c1d46fc6 *man/gsignal-package.Rd 1303ffe28cbde85e046118760706426a *man/hamming.Rd 4d6df2b78247f1453d743ae57dc08154 *man/hann.Rd fd292070fdaae799e15d9d9563186597 *man/hilbert.Rd 75e61a8a4be57b381c5477965c4b3fff *man/idct.Rd f3fab9b8aef47327ae3802a501a43068 *man/idct2.Rd 291ddf9417dcd68ea047dba656707834 *man/idst.Rd 0653abcafc3a6fb6c5ad2d5e9129e43d *man/ifft.Rd beca981e6c34bf73b620fce239eff1e6 *man/ifftshift.Rd c6a92b365cdaf2ef404f4083f596a4e8 *man/iirlp2mb.Rd d4f3f2978543d0e200f32829c6aeefe3 *man/impinvar.Rd bf9e4527ff0fe8692fd89e14a3db5d54 *man/impz.Rd 9c34d32afc8dfea004f5d1d89750a658 *man/interp.Rd 267577022708707c48a31ff3fbf08a4b *man/invfreq.Rd 84d4b3aaf90c30910158efb1793f65c1 *man/invimpinvar.Rd b6dc62b6417d082bb14dd92859b22410 *man/kaiser.Rd c9846fd03cc3bc7b2314eb506640411a *man/kaiserord.Rd 622ae2542f349b97b5a5b98f82eb2cc5 *man/levinson.Rd 1a574d554c9cc50c26b9693913671c43 *man/marcumq.Rd 93f6c0c91a59d40b93059e6457fc5d25 *man/medfilt1.Rd 4dc612ad174eb5d72f84567f9cca216a *man/mexihat.Rd 833253efbec8eddeae5e5e877b5d5162 *man/meyeraux.Rd e2eebf616503f45923f2e14190292da5 *man/morlet.Rd 282045e2ea43257e7a672ea7f5229749 *man/movingrms.Rd c02b52fb021394ce49c5480849c6b452 *man/mpoles.Rd 251b60b714219e358cff1e1efe99d7c6 *man/mscohere.Rd 48bf1294da644cfeef41695b20c7e074 *man/ncauer.Rd 899f0f81928909f426e45897a6dec590 *man/nuttallwin.Rd 20fe8fe3f634e8552b4d2d5baff75c8e *man/pad.Rd 024a12390f12ad6fb9b73cee2109b507 *man/parzenwin.Rd 29e2259b23439edab15b4553142d7527 *man/pburg.Rd 237e3efc867eab1dc35318b6fc6df42d *man/peak2peak.Rd 2c0091bf8cae7d0c5981fdfae1c64333 *man/peak2rms.Rd 389efee74ead90cfe828b3cb873ea228 *man/pei_tseng_notch.Rd 88fa98bcb33e7d47b173c9b2751fe2ed *man/poly.Rd e447a0edbd779268e00bba839b8a4614 *man/polyreduce.Rd 8a25121bdd5675f4976d03da2e370e05 *man/polystab.Rd 9d851b4413db662528625c9727690df8 *man/pow2db.Rd b7b9ed44f05738ff27f4ce939cadc79e *man/primitive.Rd 5f4f8491c1707250c3f440fce39cce12 *man/pulstran.Rd e710bdb0c5ae82a428d289b9bc91d98b *man/pwelch.Rd 44b8b9f749cfa19a73cf6d1d16c5b2c0 *man/pyulear.Rd a6ecac90c9940a4ef70b570bf1db11c9 *man/qp_kaiser.Rd 552d2e8d27d72b8aaabd387aacc66938 *man/rceps.Rd 5c930c0ea4548e1e4eaa7cbbad3fdf51 *man/rectpuls.Rd cd4084948f6b702e91405078773aeb9d *man/rectwin.Rd e3a52499396a6814ec25539c0b0785fe *man/remez.Rd 78c4fe8622a11ecef9d7a1d7e7790248 *man/resample.Rd b201756684a65400952a1f6490732eb0 *man/residue.Rd d59e6fe6fa3536bab53c81a7dddefe36 *man/residued.Rd 34157e5d3d346e7278cc9dcdefc7f5f3 *man/residuez.Rd 60acdb0ee203e5ce210d867f91a06003 *man/rms.Rd 75345ea1760c78dca406f38fd25449ef *man/rssq.Rd c0b2322957fff6997eeaa64a3cabae4c *man/sampled2continuous.Rd 43fb90092cb3c766b37083d1804503a3 *man/sawtooth.Rd ab8ad48d59c2f27471e6d1310717cc15 *man/schtrig.Rd 8777ff3922c9710defe2cb36f791e6df *man/sftrans.Rd 7677c8dcb59175f4a0dd5334ed00d8fa *man/sgolay.Rd c072ff45021e5c9458907ef90f46ab94 *man/sgolayfilt.Rd 9a5ff647aefd209c26d68b23b012ed73 *man/shanwavf.Rd 28717ac2c497ec12c1f7378b5d85c455 *man/shiftdata.Rd 918c531b1c79c1d73f0385186cc18604 *man/sigmoid_train.Rd d2212f73f769b6e5931f9bca320cf5ae *man/signals.Rd 4f83934a38615a9fd41c8c1ca7719cd4 *man/sinetone.Rd f5f696272345391d501d2b58e991b473 *man/sinewave.Rd 022a681dc03c7d0886540102bea65b3f *man/sos2tf.Rd 773c58e3784671f7569fbcfe1141e4cb *man/sos2zp.Rd 1599410433f26459ca48948feb9f0838 *man/sosfilt.Rd d83e79b911440868bf530f32d3bb2fab *man/specgram.Rd 4798bde9ab0125860ce1a8d2f4c94347 *man/square.Rd 54cba184b5b2345ab956015e547a621a *man/stft.Rd ddb22171db6c444a6bf8f56d2ad706ed *man/tf2sos.Rd 22e9f3f3504f6408f654171cc385d890 *man/tf2zp.Rd 3e5218bb610f720eab923807f6b2b10e *man/tfestimate.Rd 1f9712ed38482efd1319461b6f235dc2 *man/triang.Rd efad36ff4f9ddb0317e75745686cc138 *man/tripuls.Rd acf0591c52da24d9b4e0cdb8d4efb10b *man/tukeywin.Rd ce7df5db37a0e16d2649403d4cbf81f7 *man/udecode.Rd 87ed96edf6826b10fb96378234ff1667 *man/uencode.Rd 3240d8876f9fd48bb82e62a7f3f6ea5b *man/ultrwin.Rd d44e0aa70f58ff38ffb374f03b0ea654 *man/unshiftdata.Rd 7860212af98831421d145bf8776cbed5 *man/unwrap.Rd 5cc17cd53470da294e05583c1b856487 *man/upfirdn.Rd b31bfe8123010e67bd2ab367731c2bcd *man/upsample.Rd e4823c600a5a7514435bcff24cd5132f *man/upsamplefill.Rd f1db9c24789f92310fac7879144f7688 *man/wconv.Rd e65a66af9a6998c6e84f190db48a9b16 *man/welchwin.Rd a6c2e2913507a7234ee773886f4b9970 *man/wkeep.Rd d84ad2ab256c6e9b1fe8caa5d17016ed *man/xcorr.Rd 03ab497c17fb769403cbba2b1bc443a4 *man/xcorr2.Rd e1cb03f964dbece30ceb34109fa269a4 *man/xcov.Rd 8809c3fbe18814eebeae68c5839e78e0 *man/zerocrossing.Rd 218cdb020f1c72d452e79a3380aee880 *man/zp2sos.Rd 5a1ed5d6130ae2cb811f55617bf57b79 *man/zp2tf.Rd a3d7c122b510bc17930bbce698c9501f *man/zplane.Rd 356729db64dda0e9aa8e5ab6d63da914 *src/RcppExports.cpp a24479b954aee1663a440d49a0d81b03 *src/conv2d.cpp 3e7839a58bef3b5339338bfca30a8730 *src/filter.cpp 4384964f8dfc43c3df346a6b024630e4 *src/fwht.cpp f7537e23eb58f32006594ef1640edd9f *src/remez.cpp 07786e73e9c8341abd2e2f07900d9ea6 *src/sosfilt.cpp dc8666b6fba349e6fe2401132425d8b1 *src/upfirdn.cpp 19a398d2b6c3b4f6f866ee337cc914ff *tests/testthat.R 85ec9349733cbfd7121484a85b8d0b62 *tests/testthat/Rplots.pdf e85ce14dd7fb5392d8b90c50dbf75dbc *tests/testthat/test_Correlation_and_Convolution_Functions.R cce1efebd219f942deb39e6a6bd04515 *tests/testthat/test_FIR_Filter_Design_Functions.R 5aecbc209777b0459e962bd0e8691f48 *tests/testthat/test_Filter_Analysis_Functions.R 0fe52b03e3bc1d0331fb55b869cc66d4 *tests/testthat/test_Filter_Conversion_Functions.R d1344639f1af486978efbafa2ac788d1 *tests/testthat/test_Filtering_Functions.R b58e610f14e2af60adbd0c46065a423c *tests/testthat/test_IIR_Filter_Design_Functions.R e3f9445f2c5b8e8e3a3e63816b50e239 *tests/testthat/test_Miscellaneous_Functions.R 2778148a4455a2196896d6b589253e42 *tests/testthat/test_Power_Spectrum_Analysis_Functions.R eee73ff4446968b95bcacc3c5134a9d5 *tests/testthat/test_Sample_Rate_Change_Functions.R a8b579e8d55f2bf5ae8a2af63f532515 *tests/testthat/test_Signal_Measurement.R 179a171383bdfcd7edc8aef91bec20b9 *tests/testthat/test_Signals.R 4383d9f7ed04fd57cf78ef7b30ab6f59 *tests/testthat/test_Standard_Functions.R 9dd84d7d35b8938f27086cc33a13a779 *tests/testthat/test_System_Identification_Functions.R c08839d2356cd747f15dd34d746389db *tests/testthat/test_Transforms_Functions.R e340b22a2f876e2408aa91f452d11850 *tests/testthat/test_Utility_Functions.R a09479df9edc1aeb1a3030e20df33f71 *tests/testthat/test_Window_Functions.R 26006a349b39cc0eca6a4c5ff9c64ad0 *tests/testthat/test_gsignal-internal.R e14f3ef83493eabdff9d3e636e132a47 *vignettes/gsignal.Rmd gsignal/R/0000755000176200001440000000000014670306232012102 5ustar liggesusersgsignal/R/dftmtx.R0000644000176200001440000000423014420222025013520 0ustar liggesusers# dftmtx.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2003 David Bateman # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201016 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Discrete Fourier Transform Matrix #' #' Compute the discrete Fourier transform matrix #' #' A discrete Fourier transform matrix is a complex matrix whose matrix product #' with a vector computes the discrete Fourier transform of the vector. #' \code{dftmtx} takes the FFT of the identity matrix to generate the transform #' matrix. For a column vector \code{x}, \code{y <- dftmtx(n) * x} is the same #' as \code{y <- fft(x, postpad(x, n)}. The inverse discrete Fourier transform #' matrix is \code{inv <- Conj(dftmtx(n)) / n}. #' #' In general this is less efficient than calling the \code{fft} and \code{ifft} #' functions directly. #' #' @param n Size of Fourier transformation matrix, specified as a positive #' integer. #' #' @return Fourier transform matrix. #' #' @examples #' x <- seq_len(256) #' y1 <- stats::fft(x) #' n <- length(x) #' y2 <- drop(x %*% dftmtx(n)) #' mx <- max(abs(y1 - y2)) #' #' @author David Bateman, \email{adb014@@gmail.com}.\cr Conversion to R by Geert #' van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link[stats]{fft}}, \code{\link{ifft}} #' #' @export dftmtx <- function(n) { if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer") } y <- stats::mvfft(diag(1, n)) y } gsignal/R/zp2sos.R0000644000176200001440000001236414420222025013461 0ustar liggesusers# zp2sos.R # Copyright (C) 2020 Geert van Boxtel # Original Octave version: # Copyright (C) 2005 Julius O. Smith III # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200331 GvB setup for gsignal v0.1.0 # 20200401 GvB handle NULL input # 20200403 GvB use 'relaxed' tolerance 1e-7 for cplxreal, # flipud sos for compatibility with Matlab/Octave # 20200406 GvB validated # 20210326 GvB renamed k to g; added 'order' argument; # return class 'Sos' argument #------------------------------------------------------------------------------ #' Zero-pole-gain to second-order section format #' #' Convert digital filter zero-pole-gain data to second-order section form. #' #' @param z complex vector of the zeros of the model (roots of \code{B(z)}) #' @param p complex vector of the poles of the model (roots of \code{A(z)}) #' @param g overall gain (\code{B(Inf)}). Default: 1 #' @param order row order, specified as: #' \describe{ #' \item{"up"}{order the sections so the first row contains the poles farthest #' from the unit circle.} #' \item{"down" (Default)}{order the sections so the first row of \code{sos} #' contains the poles closest to the unit circle.} #' } #' The ordering influences round-off noise and the probability of overflow. #' #' @return A list with the following list elements: #' \describe{ #' \item{sos}{Second-order section representation, specified as an nrow-by-6 #' matrix, whose rows contain the numerator and denominator coefficients of #' the second-order sections:\cr \code{sos <- rbind(cbind(B1, A1), cbind(...), #' cbind(Bn, An))}, where \code{B1 <- c(b0, b1, b2)}, and \code{A1 <- c(a0, #' a1, a2)} for section 1, etc. The b0 entry must be nonzero for each #' section.} #' \item{g}{Overall gain factor that effectively scales the output \code{b} #' vector (or any one of the input \code{Bi} vectors).} #' } #' #' @seealso \code{\link{as.Sos}}, \code{\link{filter}}, \code{\link{sosfilt}} #' #' @examples #' zpk <- tf2zp (c(1, 0, 0, 0, 0, 1), c(1, 0, 0, 0, 0, .9)) #' sosg <- zp2sos (zpk$z, zpk$p, zpk$g) #' #' @author Julius O. Smith III, \email{jos@@ccrma.stanford.edu}.\cr #' Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com} #' #' @export zp2sos <- function(z, p, g = 1, order = c("down", "up")) { order <- match.arg(order) if (!is.null(z)) { zcr <- cplxreal(z, tol = 1e-7) if (is.null(zcr$zc)) { zc <- nzc <- 0 } else { zc <- zcr$zc nzc <- length(zc) } if (is.null(zcr$zr)) { zr <- nzr <- 0 } else { zr <- zcr$zr nzr <- length(zr) } } else { zc <- zr <- 0 nzc <- nzr <- 0 } if (!is.null(p)) { pcr <- cplxreal(p, tol = 1e-7) if (is.null(pcr$zc)) { pc <- npc <- 0 } else { pc <- pcr$zc npc <- length(pc) } if (is.null(pcr$zr)) { pr <- npr <- 0 } else { pr <- pcr$zr npr <- length(pr) } } else { pc <- pr <- 0 npc <- npr <- 0 } # Pair up real zeros if (nzr > 0) { if (nzr %% 2 == 1) { zr <- c(zr, 0) nzr <- nzr + 1 } nzrsec <- nzr / 2 zrms <- -zr[seq(1, nzr - 1, 2)] - zr[seq(2, nzr, 2)] zrp <- zr[seq(1, nzr - 1, 2)] * zr[seq(2, nzr, 2)] } else { nzrsec <- 0 } # Pair up real poles: if (npr > 0) { if (npr %% 2 == 1) { pr <- c(pr, 0) npr <- npr + 1 } nprsec <- npr / 2 prms <- -pr[seq(1, npr - 1, 2)] - pr[seq(2, npr, 2)] prp <- pr[seq(1, npr - 1, 2)] * pr[seq(2, npr, 2)] } else { nprsec <- 0 } nsecs <- max(nzc + nzrsec, npc + nprsec) if (nsecs <= 0) nsecs <- 1 # Convert complex zeros and poles to real 2nd-order section form: zcm2r <- -2 * Re(zc) zca2 <- abs(zc)^2 pcm2r <- -2 * Re(pc) pca2 <- abs(pc)^2 sos <- matrix(0L, nsecs, 6) sos[, 1] <- rep(1L, nsecs) # all 2nd-order polynomials are monic sos[, 4] <- rep(1L, nsecs) nzrl <- nzc + nzrsec # index of last real zero section nprl <- npc + nprsec # index of last real pole section for (i in seq_len(nsecs)) { if (i <= nzc) { # lay down a complex zero pair: sos[i, 2:3] <- c(zcm2r[i], zca2[i]) } else if (i <= nzrl) { # lay down a pair of real zeros: sos[i, 2:3] <- c(zrms[i - nzc], zrp[i - nzc]) } if (i <= npc) { # lay down a complex pole pair: sos[i, 5:6] <- c(pcm2r[i], pca2[i]) } else if (i <= nprl) { # lay down a pair of real poles: sos[i, 5:6] <- c(prms[i - npc], prp[i - npc]) } } if (order == "down") { rv <- Sos(sos = sos, g = g) } else { rv <- Sos(sos = sos[rev(seq_len(nsecs)), ], g = g) } rv } gsignal/R/bohmanwin.R0000644000176200001440000000414614420222025014202 0ustar liggesusers# bohmanwin.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2007 Sylvain Pelissier # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191209 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Bohman window #' #' Return the filter coefficients of a Bohman window. #' #' A Bohman window is the convolution of two half-duration cosine lobes. In the #' time domain, it is the product of a triangular window and a single cycle of a #' cosine with a term added to set the first derivative to zero at the boundary. #' #' @param n Window length, specified as a positive integer. #' #' @return Bohman window, returned as a vector. If you specify a one-point #' window \code{(n = 1)}, the value 1 is returned. #' #' @examples #' #' b <- bohmanwin(64) #' plot (b, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' @seealso \code{\link{triang}} #' #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export bohmanwin <- function(n) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) { stop("n must be an integer strictly positive") } if (n == 1) { w <- 1 } else { N <- n - 1 k <- (-N / 2):(N / 2) w <- (1 - 2 * abs(k) / N) * cos(2 * pi * abs(k) / N) + (1 / pi) * sin(2 * pi * abs(k) / N) w[1] <- w[length(w)] <- 0 } w } gsignal/R/cconv.R0000644000176200001440000000656014420222025013332 0ustar liggesusers# cconv.R # Copyright (C) 2020 Geert van Boxtel # Octave version Copyright (C) 2018 Leonardo Araujo # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200209 GvB setup for gsignal v0.1.0 # 20200212 GvB use stats::nextn to ensure that the length is # a highly composite number #------------------------------------------------------------------------------ #' Circular convolution #' #' Compute the modulo-n circular convolution. #' #' Linear and circular convolution are fundamentally different operations. #' Linear convolution of an n-point vector x, and an l-point vector y, has #' length n + l - 1, and can be computed by the function \code{\link{conv}}, #' which uses \code{\link{filter}}. The circular convolution, by contrast, is #' equal to the inverse discrete Fourier transform (DFT) of the product of the #' vectors' DFTs. #' #' For the circular convolution of \code{x} and \code{y} to be equivalent to #' their linear convolution, the vectors must be padded with zeros to length at #' least \code{n + l - 1} before taking the DFT. After inverting the product of #' the DFTs, only the first \code{n + l - 1} elements should be retained. #' #' For long sequences circular convolution may be more efficient than linear #' convolution. You can also use \code{cconv} to compute the circular #' cross-correlation of two sequences. #' #' @param a,b Input, coerced to vectors, can be different lengths or data types. #' @param n Convolution length, specified as a positive integer. Default: #' \code{length(a) + length(b) - 1}. #' #' @return Circular convolution of input vectors, returned as a vector. #' #' @examples #' a <- c(1, 2, -1, 1) #' b <- c(1, 1, 2, 1, 2, 2, 1, 1) #' c <- cconv(a, b) # Circular convolution #' cref = conv(a, b) # Linear convolution #' all.equal(max(c - cref), 0) #' #' cconv(a, b, 6) #' #' @seealso \code{\link{conv}}, \code{\link[stats]{convolve}} #' #' @author Leonardo Araujo.\cr Conversion to R by Geert van Boxtel, #' \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export cconv <- function(a, b, n = length(a) + length(b) - 1) { a <- as.vector(a) b <- as.vector(b) if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer") } la <- length(a) lb <- length(b) if (la < lb) { a <- postpad(a, lb) } else if (lb < la) { b <- postpad(b, la) } N <- length(a) if (n < N) { an <- bn <- rep(0L, n) for (i in 0:(N - 1)) { modi <- i %% n an[modi + 1] <- an[modi + 1] + a[i + 1] bn[modi + 1] <- bn[modi + 1] + b[i + 1] } a <- an b <- bn } else if (n > N) { a <- postpad(a, n) b <- postpad(b, n) } y <- ifft(stats::fft(postpad(a, stats::nextn(length(a)))) * stats::fft(postpad(b, stats::nextn(length(b))))) y[1:n] } gsignal/R/xcov.R0000644000176200001440000000753414420222025013203 0ustar liggesusers# xcov.R # Copyright (C) 2020 Geert van Boxtel # Octave version: # Copyright (C) 1999-2001 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200313 GvB setup for gsignal v0.1.0 # 20210518 GvB adapted example #------------------------------------------------------------------------------ #' Cross-covariance #' #' Compute covariance at various lags (= correlation(x-mean(x), y-mean(y))). #' #' @param x Input, numeric or complex vector or matrix. Must not be missing. #' @param y Input, numeric or complex vector data. If \code{x} is a matrix (not #' a vector), \code{y} must be omitted. \code{y} may be omitted if \code{x} is #' a vector; in this case \code{xcov} estimates the autocovariance of #' \code{x}. #' @param maxlag Integer scalar. Maximum covariance lag. If omitted, the #' default value is \code{N-1}, where \code{N} is the greater of the lengths #' of \code{x} and \code{y} or, if \code{x} is a matrix, the number of rows in #' \code{x}. #' @param scale Character string. Specifies the type of scaling applied to the #' covariation vector (or matrix). matched to one of: #' \describe{ #' \item{"none"}{return the unscaled covariance, C} #' \item{"biased"}{return the biased average, C/N} #' \item{"unbiased"}{return the unbiased average, C(k)/(N-|k|)} #' \item{"coeff"}{return C/(covariance at lag 0)}, #' where \code{k} is the lag, and \code{N} is the length of \code{x} #' } #' If omitted, the default value is \code{"none"}. If \code{y} is supplied but #' does not have the same length as \code{x}, scale must be \code{"none"}. #' #' @return A list containing the following variables: #' \describe{ #' \item{C}{array of covariance estimates} #' \item{lags}{vector of covariance lags \code{[-maxlag:maxlag]}} #' } #' The array of covariance estimates has one of the following forms: #' \enumerate{ #' \item Cross-covariance estimate if X and Y are vectors. #' \item Autocovariance estimate if is a vector and Y is omitted. #' \item If \code{x} is a matrix, \code{C} is a matrix containing the #' cross-covariance estimates of each column with every other column. Lag #' varies with the first index so that \code{C} has \code{2 * maxlag + 1} rows #' and \eqn{P^2} columns where \code{P} is the number of columns in \code{x}. #' } #' @seealso \code{\link{xcorr}}. #' #' @examples #' \donttest{ #' N <- 128 #' fs <- 5 #' t <- seq(0, 1, length.out = N) #' x <- sin(2 * pi * fs * t) + runif(N) #' cl <- xcov(x, maxlag = 20, scale = 'coeff') #' plot (cl$lags, cl$C, type = "h", xlab = "", ylab = "") #' points (cl$lags, cl$C) #' abline(h = 0) #'} #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export xcov <- function(x, y = NULL, maxlag = if (is.matrix(x)) nrow(x) - 1 else max(length(x), length(y)) - 1, scale = c("none", "biased", "unbiased", "coeff")) { if (is.null(y)) { ret <- xcorr(x - colMeans(as.matrix(x)), maxlag = maxlag, scale = scale) } else { ret <- xcorr(x - colMeans(as.matrix(x)), y - colMeans(as.matrix(y)), maxlag = maxlag, scale = scale) } list(C = ret$R, lags = ret$lags) } gsignal/R/schtrig.R0000644000176200001440000001130114420222025013652 0ustar liggesusers# schtrig.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2012 Juan Pablo Carbajal # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201127 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Schmitt Trigger #' #' Multisignal Schmitt trigger with levels. #' #' The trigger works compares each column in \code{x} to the levels in #' \code{lvl}, when the value is higher than \code{max(lvl)}, the output #' \code{v} is high (i.e. 1); when the value is below \code{min(lvl)} the output #' is low (i.e. 0); and when the value is between the two levels the output #' retains its value. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param lvl threshold levels against which \code{x} is compared, specified as #' a vector. If this is a scalar, the thresholds are symmetric around 0, i.e. #' \code{c(-lvl, lvl)}. #' @param st trigger state, specified as a vector of length \code{ncol(x}. The #' trigger state is returned in the output list and may be passed again to a #' subsequent call to \code{schtrig}. Default: NULL. #' #' @return a \code{\link{list}} containing the following variables: #' \describe{ #' \item{v}{vector or matrix of 0's and 1's, according to whether \code{x} is #' above or below \code{lvl}, or the value of \code{x} if indeterminate} #' \item{rng}{ranges in which the output is high, so the indexes #' \code{rng[1,i]:rng[2,i]} point to the i-th segment of 1s in \code{v}. See #' \code{\link{clustersegment}} for a detailed explanation.} #' \item{st}{trigger state, returned as a vector with a length of the number #' of columns in \code{x}.} #' } #' #' @examples #' t <- seq(0, 1, length.out = 100) #' x <- sin(2 * pi * 2 * t) + sin(2 * pi * 5 * t) %*% matrix(c(0.8, 0.3), 1, 2) #' lvl <- c(0.8, 0.25) #' trig <- schtrig (x, lvl) #' #' op <- par(mfrow = c(2, 1)) #' plot(t, x[, 1], type = "l", xlab = "", ylab = "") #' abline(h = lvl, col = "blue") #' lines(t, trig$v[, 1], col = "red", lwd = 2) #' plot(t, x[, 2], type = "l", xlab = "", ylab = "") #' abline(h = lvl, col = "blue") #' lines(t, trig$v[, 2], col = "red", lwd = 2) #' par(op) #' #' @seealso \code{\link{clustersegment}} #' #' @author Juan Pablo Carbajal, \email{carbajal@@ifi.uzh.ch}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export schtrig <- function(x, lvl, st = NULL) { if (!is.numeric(x)) { stop("x must be a numeric vector or matrix") } if (is.vector(x)) { x <- matrix(x, ncol = 1) vec <- TRUE } else if (is.matrix(x)) { vec <- FALSE } else { stop("x must be a numeric vector or matrix") } nc <- ncol(x) nr <- nrow(x) if (!is.numeric(lvl) || !is.vector(lvl)) { stop("lvl must be a numeric vector") } if (length(lvl) == 1) { lvl <- abs(lvl) * c(1, -1) } else { lvl <- sort(lvl, decreasing = TRUE) } if (is.null(st)) { st <- rep(0, nc) } else if (!is.vector(st) || length(st) != nc) { stop(paste("st must be NULL a vector of length", nc)) } v <- matrix(NA, nr, nc) v[1, ] <- st ## Signal is above up level up <- x > lvl[1] v[up] <- 1 ## Signal is below down level dw <- x < lvl[2] v[dw] <- 0 ## Resolve intermediate states ## Find data between the levels idx <- is.na(v) rng <- clustersegment(t(idx)) if (!is.list(rng)) { crng <- list(rng) } else { crng <- rng } if (length(crng) > 0 && nrow(crng[[1]]) == 2) { for (i in seq_len(nc)) { ## Record the state at the beginning of the interval between levels prev <- crng[[i]][1, ] - 1 prev[prev < 1] <- 1 st <- v[prev, i] ## Copy the initial state to the interval ini_idx <- crng[[i]][1, ] end_idx <- crng[[i]][2, ] for (j in seq_along(ini_idx)) { v[ini_idx[j]:end_idx[j], i] <- st[j] } } } st <- v[nr, ] if (vec) { v <- as.vector(v) } list(v = v, rng = rng, st = st) } gsignal/R/sigmoid_train.R0000644000176200001440000001202514420222025015043 0ustar liggesusers# sigmoid_train.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2011-2013 Juan Pablo Carbajal # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191204 Geert van Boxtel First version for v0.1.0 # 20200322 Geert van Boxtel used NROW and NCOL; expand rc #------------------------------------------------------------------------------ #' Sigmoid Train #' #' Evaluate a train of sigmoid functions at \code{t}. #' #' The number and duration of each sigmoid is determined from ranges. Each row #' of \code{ranges} represents a real interval, e.g. if sigmoid \code{i} starts #' at \code{t = 0.1} and ends at \code{t = 0.5}, then \code{ranges[i, ] = c(0.1, #' 0.5)}. The input \code{rc} is an array that defines the rising and falling #' time constants of each sigmoid. Its size must equal the size of ranges. #' #' The individual sigmoids are returned in \code{s}. The combined sigmoid train #' is returned in the vector \code{y} of length equal to \code{t}, and such that #' \code{y = max(s)}. #' #' @param t Vector (or coerced to a vector) of time values at which the sigmoids #' are calculated. #' @param ranges Matrix or array with 2 columns containing the time values #' within \code{t} at which each sigmoid is evaluated. The number of sigmoids #' is determined by the number of rows in \code{ranges}. #' @param rc Time constant. Either a scalar or a matrix or array with 2 columns #' containing the rising and falling time constants of each sigmoid. If a #' matrix or array is passed in \code{rc}, its size must equal the size of #' \code{ranges}. If a single scalar is passed in \code{rc}, then all sigmoids #' have the same time constant and are symmetrical. #' #' @return A list consisting two variables; \code{y} the combined sigmoid train #' (length identical to \code{t}), and \code{s}, the individual sigmoids #' (number of rows equal to number of rows in \code{ranges} and \code{rc}. #' #' @examples #' #' t <- seq(0, 2, length.out = 500) #' ranges <- rbind(c(0.1, 0.4), c(0.6, 0.8), c(1, 2)) #' rc <- rbind(c(1e-2, 1e-3), c(1e-3, 2e-2), c(2e-2, 1e-2)) #' st <- sigmoid_train (t, ranges, rc) #' plot(t, st$y[1,], type="n", xlab = "Time(s)", ylab = "S(t)", #' main = "Vectorized use of sigmoid train") #' for (i in 1:3) rect(ranges[i, 1], 0, ranges[i, 2], 1, #' border = NA, col="pink") #' for (i in 1:3) lines(t, st$y[i,]) #' # The colored regions show the limits defined in range. #' #' t <- seq(0, 2, length.out = 500) #' ranges <- rbind(c(0.1, 0.4), c(0.6, 0.8), c(1, 2)) #' rc <- rbind(c(1e-2, 1e-3), c(1e-3, 2e-2), c(2e-2, 1e-2)) #' amp <- c(4, 2, 3) #' st <- sigmoid_train (t, ranges, rc) #' y <- amp %*% st$y #' plot(t, y[1,], type="l", xlab = 'time', ylab = 'signal', #' main = 'Varying amplitude sigmoid train', col="blue") #' lines(t, st$s, col = "orange") #' legend("topright", legend = c("Sigmoid train", "Components"), #' lty = 1, col = c("blue", "orange")) #' #' @author Juan Pablo Carbajal, \email{carbajal@@ifi.uzh.ch}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export sigmoid_train <- function(t, ranges, rc) { t <- as.vector(t) ## number of sigmoids if (is.vector(ranges)) { ranges <- as.matrix(t(ranges)) } nr <- NROW(ranges) nc <- NCOL(ranges) if (is.null(nr) || nr <= 0) stop("ranges must be a vector, or an array or matrix with at least 1 row") if (is.null(nc) || nc != 2) stop("ranges must be a vector, or an array or matrix with 2 columns") ## Parse time constants if (isScalar(rc)) { # All sigmoids have the same time constant and are symmetric rc <- rc * matrix(1L, nr, 2) } else if (is.vector(rc)) { rc <- as.matrix(t(rc)) } else if ((nrow(rc) == 1 || ncol(rc) == 1) && nr > 1) { # All sigmoids have different time constants but are symmetric if (nrow(rc) == 1) { rc <- t(rc) } if (nrow(rc) != nr) stop("length of time constant must equal number of ranges") rc <- cbind(rc, rc) } a_up <- apply(t(apply(t(ranges[, 1]), 2, function(x) x - t)), 2, function(x) x / rc[, 1]) a_dw <- apply(t(apply(t(ranges[, 2]), 2, function(x) x - t)), 2, function(x) x / rc[, 2]) ## Evaluate the sigmoids and mix them y <- 1 / (1 + exp(a_up)) * (1 - 1 / (1 + exp(a_dw))) if (nr == 1) { s <- y } else { s <- apply(y, 2, max) } list(y = y, s = s) } gsignal/R/interp.R0000644000176200001440000000573114420222025013522 0ustar liggesusers# interp.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2000 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201121 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Interpolation #' #' Increase sample rate by integer factor. #' #' @param x input data, specified as a numeric vector. #' @param q interpolation factor, specified as a positive integer. #' @param n Half the number of input samples used for interpolation, specified #' as a positive integer. For best results, use \code{n} no larger than 10. #' The low-pass interpolation filter has length \code{2 × n × q + 1}. Default: #' 4. #' @param Wc Normalized cutoff frequency of the input signal, specified as a #' positive real scalar not greater than 1 that represents a fraction of the #' Nyquist frequency. A value of 1 means that the signal occupies the full #' Nyquist interval. Default: 0.5. #' #' @return interpolated signal, returned as a vector. #' #' @examples #' # Generate a signal #' t <- seq(0, 2, 0.01) #' x <- chirp(t, 2, .5, 10,'quadratic') + sin(2 * pi * t * 0.4) #' w <- seq(1, 121, 4) #' plot(t[w] * 1000, x[w], type = "h", xlab = "", ylab = "") #' points(t[w] * 1000, x[w]) #' abline (h = 0) #' y <- interp(x[seq(1, length(x), 4)], 4, 4, 1) #' lines(t[1:121] * 1000, y[1:121], type = "l", col = "red") #' points(t[1:121] * 1000, y[1:121], col = "red", pch = '+') #' legend("topleft", legend = c("original", "interpolated"), #' lty = 1, pch = c(1, 3), col = c(1, 2)) #' #' @seealso \code{\link{decimate}}, \code{\link{resample}} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export interp <- function(x, q, n = 4, Wc = 0.5) { if (!is.numeric(x) || !is.vector(x)) { stop("x must be a numeric vector") } if (!(isPosscal(q) && isWhole(q))) { stop("q must be a positive integer") } if (!(isPosscal(n) && isWhole(n))) { stop("n must be a positive integer") } if (!isPosscal(Wc) || Wc > 1) { stop("n must be a numeric value between 0 and 1") } y <- rep(0, length(x) * q + q * n + 1) y[seq(1, length(x) * q, q)] <- x b <- fir1(2 * q * n + 1, Wc / q) y <- q * fftfilt(b, y) y[- (1:(q * n + 1))] # adjust for zero filter delay } gsignal/R/rssq.R0000644000176200001440000000572714420222025013216 0ustar liggesusers# rssq.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2018-2019 Mike Miller # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200111 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Root-sum-of-squares #' #' Compute the root-sum-of-squares (SSQ) of the object \code{x}. #' #' The input \code{x} can be a vector, a matrix or an array. If the input is a #' vector, a single value is returned representing the root-sum-of-squares of #' the vector. If the input is a matrix or an array, a vector or an array of #' values is returned representing the root-sum-of-squares of the dimensions of #' \code{x} indicated by the \code{MARGIN} argument. #' #' Support for complex valued input is provided. The sum of squares of complex #' numbers is defined by \code{sum(x * Conj(x))} #' #' @param x the data, expected to be a vector, a matrix, an array. #' @param MARGIN a vector giving the subscripts which the function will be #' applied over. E.g., for a matrix 1 indicates rows, 2 indicates columns, #' c(1, 2) indicates rows and columns. Where \code{x} has named dimnames, it #' can be a character vector selecting dimension names. Default: 2 (usually #' columns) #' #' @return Vector or array of values containing the root-sum-of-squares of the #' specified \code{MARGIN} of \code{x}. #' #' @examples #' ## numeric vector #' x <- c(1:5) #' p <- rssq(x) #' #' ## numeric matrix #' x <- matrix(c(1,2,3, 100, 150, 200, 1000, 1500, 2000), 3, 3) #' p <- rssq(x) #' p <- rssq(x, 1) #' #' ## numeric array #' x <- array(c(1, 1.5, 2, 100, 150, 200, 1000, 1500, #' 2000, 10000, 15000, 20000), c(2,3,2)) #' p <- rssq(x, 1) #' p <- rssq(x, 2) #' p <- rssq(x, 3) #' #' ## complex input #' x <- c(1+1i, 2+3i, 3+5i, 4+7i, 5+9i) #' p <- rssq(x) #' #' @author Mike Miller.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export rssq <- function(x, MARGIN = 2) { if (!(is.numeric(x) || is.complex(x)) || !(is.vector(x) || is.matrix(x) || is.array(x))) { stop("x must be a numeric or complex vector, matrix or array") } if (!isPosscal(MARGIN) || !isWhole(MARGIN)) { stop("MARGIN must be a positive scalar") } if (is.vector(x)) { x <- as.matrix(x) MARGIN <- 2 } y <- apply(x, MARGIN, function(x) sqrt(ssq(x))) y } gsignal/R/fwht.R0000644000176200001440000001034614420222025013167 0ustar liggesusers# fwht.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2013-2019 Mike Miller # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201023 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Fast Walsh-Hadamard Transform #' #' Compute the (inverse) Fast Walsh-Hadamard transform of a signal. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. \code{fwht} operates only on signals with length equal to a power #' of 2. If the length of \code{x} is less than a power of 2, its length is #' padded with zeros to the next greater power of two before processing. #' @param n transform length, specified as a positive integer scalar. Default: #' \code{NROW(x)}. #' @param ordering order of the Walsh-Hadamard transform coefficients, one of: #' \describe{ #' \item{"sequency"}{(Default) Coefficients in order of increasing sequency #' value, where each row has an additional zero crossing.} #' \item{"hadamard"}{Coefficients in normal Hadamard order} #' \item{"dyadic"}{Coefficients in Gray code order, where a single bit change #' occurs from one coefficient to the next} #' } #' #' @return (Inverse) Fast Walsh Hadamard transform, returned as a vector or #' matrix. #' #' @examples #' x <- c(19, -1, 11, -9, -7, 13, -15, 5) #' X <- fwht(x) #' all.equal(x, ifwht(X)) #' #' @author Mike Miller.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references \url{https://en.wikipedia.org/wiki/Hadamard_transform} #' @references \url{https://en.wikipedia.org/wiki/Fast_Walsh-Hadamard_transform} #' #' @rdname fwht #' @export ifwht <- function(x, n = NROW(x), ordering = c("sequency", "hadamard", "dyadic")) { # check parameters if (!(is.vector(x) || is.matrix(x)) || !is.numeric(x)) { stop("x must be a numeric or vector or matrix") } if (is.vector(x)) { vec <- TRUE x <- as.matrix(x, ncol = 1) } else { vec <- FALSE } nr <- nrow(x) if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer") } # force n to be a power of 2 n <- nextpow2(n) if (n != nr) { x <- postpad(x, n) } ordering <- match.arg(ordering) # Zero-based index for normal Hadamard ordering idx <- seq(0, n - 1) nbits <- floor(log2(max(idx))) + 1 # number of significant bits # Gray code permutation of index for alternate orderings idx_bin <- matrix(0, n, nbits) if (ordering == "dyadic") { for (i in seq_len(n)) { idx_bin[i, ] <- as.integer(intToBits(idx[i]))[1:nbits] idx[i] <- bin2dec(paste(idx_bin[i, ], collapse = "")) + 1 } } else if (ordering == "sequency") { for (i in seq_len(n)) { idx_bin[i, ] <- as.integer(rev(intToBits(idx[i])))[(32 - nbits + 1):32] idx_bin_a <- idx_bin[i, 1:(nbits - 1)] idx_bin_b <- idx_bin[i, 2:nbits] idx_bin[i, 2:nbits] <- (idx_bin_a + idx_bin_b) %% 2 idx[i] <- bin2dec(paste(rev(idx_bin[i, ]), collapse = "")) + 1 } } else { idx <- idx + 1 } # do the transform if (n < 2) { y <- x } else { y <- .Call("_gsignal_fwht", PACKAGE = "gsignal", x) } # apply ordering y <- y[idx, ] # cleanup and exit if (vec) { y <- as.vector(y) } y } #' @rdname fwht #' @export fwht <- function(x, n = NROW(x), ordering = c("sequency", "hadamard", "dyadic")) { if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer") } n <- nextpow2(n) y <- ifwht(x, n, ordering) y <- y / n y } gsignal/R/sgolayfilt.R0000644000176200001440000001156114420222025014374 0ustar liggesusers# sgolayfilt.R # Copyright (C) 2020 Geert van Boxtel # Original Matlab/Octave version: # Copyright (C) 2001 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200322 GvB setup for gsignal v0.1.0 # 20210405 GvB if x is a matrix, filter its columns # 20220328 GvB copy dimnames of x to output object # 20220511 GvB use inherits() instead of direct comparison of class name #------------------------------------------------------------------------------ #' Savitzky-Golay filtering #' #' Filter a signal with a Savitzky-Golay FIR filter. #' #' Savitzky-Golay smoothing filters are typically used to "smooth out" a noisy #' signal whose frequency span (without noise) is large. They are also called #' digital smoothing polynomial filters or least-squares smoothing filters. #' Savitzky-Golay filters perform better in some applications than standard #' averaging FIR filters, which tend to filter high-frequency content along with #' the noise. Savitzky-Golay filters are more effective at preserving high #' frequency signal components but less successful at rejecting noise. #' #' Savitzky-Golay filters are optimal in the sense that they minimize the #' least-squares error in fitting a polynomial to frames of noisy data. #' #' @param x the input signal to be filtered, specified as a vector or as a #' matrix. If \code{x} is a matrix, each column is filtered. #' @param p Polynomial filter order; must be smaller than \code{n}. #' @param n Filter length; must a an odd positive integer. #' @param m Return the m-th derivative of the filter coefficients. Default: 0 #' @param ts Scaling factor. Default: 1 #' @param filt Filter characteristics, usually the result of a call to #' \code{sgolay} #' @param ... Additional arguments (ignored) #' #' @return The filtered signal, of the same dimensions as the input signal. #' #' @examples #' # Compare a 5 sample averager, an order-5 butterworth lowpass #' # filter (cutoff 1/3) and sgolayfilt(x, 3, 5), the best cubic #' # estimated from 5 points. #' bf <- butter(5, 1/3) #' x <- c(rep(0, 15), rep(10, 10), rep(0, 15)) #' sg <- sgolayfilt(x) #' plot(sg, type="l", xlab = "", ylab = "") #' lines(filtfilt(rep(1, 5) / 5, 1, x), col = "red") # averaging filter #' lines(filtfilt(bf, x), col = "blue") # butterworth #' points(x, pch = "x") # original data #' legend("topleft", c("sgolay (3,5)", "5 sample average", "order 5 #' Butterworth", "original data"), lty=c(1, 1, 1, NA), #' pch = c(NA, NA, NA, "x"), col = c(1, "red", "blue", 1)) #' #' @seealso \code{\link{sgolay}} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R Tom Short,\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @rdname sgolayfilt #' @export filter.sgolayFilter <- function(filt, x, ...) { sgolayfilt(x, filt, ...) } #' @rdname sgolayfilt #' @export sgolayfilt <- function(x, p = 3, n = p + 3 - p %% 2, m = 0, ts = 1) { if (is.null(x)) { return(NULL) } if (!is.numeric(x)) { stop("x must be a numeric vector or matrix") } if (is.vector(x)) { x <- as.matrix(x, ncol = 1) vec <- TRUE } else { vec <- FALSE } nrx <- NROW(x) ncx <- NCOL(x) if (is.null(nrx) || nrx <= 0) { return(x) } y <- matrix(0, nrx, ncx) ## The first k rows of F are used to filter the first k points ## of the data set based on the first n points of the data set. ## The last k rows of F are used to filter the last k points ## of the data set based on the last n points of the dataset. ## The remaining data is filtered using the central row of F. ## As the filter coefficients are used in the reverse order of what ## seems the logical notation, reverse F[k+1,] so that antisymmetric ## sequences are used with the right sign. if (inherits(p, "sgolayFilter") || (!is.null(dim(p)) && dim(p) > 1)) { Fm <- p n <- nrow(Fm) } else { Fm <- sgolay(p, n, m, ts) } k <- floor(n / 2) z <- filter(Fm[(k + 1), n:1], 1, x) for (icol in seq_len(ncx)) { y[, icol] <- c(Fm[1:k, ] %*% x[1:n, icol], z[n:nrx, icol], Fm[(k + 2):n, ] %*% x[(nrx - n + 1):nrx, icol] ) } if (vec) { y <- as.vector(y) } dimnames(y) <- dimnames(x) y } gsignal/R/RcppExports.R0000644000176200001440000000143314670302641014517 0ustar liggesusers# Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 conv2df <- function(a, b) { .Call(`_gsignal_conv2df`, a, b) } conv2ds <- function(a, b) { .Call(`_gsignal_conv2ds`, a, b) } conv2dv <- function(a, b) { .Call(`_gsignal_conv2dv`, a, b) } rfilter <- function(b, a, x, zi) { .Call(`_gsignal_rfilter`, b, a, x, zi) } fwht <- function(x) { .Call(`_gsignal_fwht`, x) } remez <- function(h, numtaps, numband, bands, des, weight, type, griddensity) { .Call(`_gsignal_remez`, h, numtaps, numband, bands, des, weight, type, griddensity) } rsosfilt <- function(sos, x, zi) { .Call(`_gsignal_rsosfilt`, sos, x, zi) } upfirdn <- function(x, h, p, q) { .Call(`_gsignal_upfirdn`, x, h, p, q) } gsignal/R/tf2zp.R0000644000176200001440000000511214420222025013257 0ustar liggesusers# tf2zp.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200331 GvB setup for gsignal v0.1.0 # 20200401 GvB catch k == 0 # 20200403 GvB compute roots with the "eigen" method, and sort them # 20200406 GvB validated # 20210326 GvB renamed k to g, return object of class 'Zpg' # 20210506 GvB sort output z and p #------------------------------------------------------------------------------ #' Transfer function to zero-pole-gain form #' #' Convert digital filter transfer function parameters to zero-pole-gain form. #' #' @param b moving average (MA) polynomial coefficients, specified as a numeric #' vector or matrix. In case of a matrix, then each row corresponds to an #' output of the system. The number of columns of \code{b} must be less than #' or equal to the length of \code{a}. #' @param a autoregressive (AR) polynomial coefficients, specified as a vector. #' #'@return A list of class Zpg with the following list elements: #' \describe{ #' \item{z}{complex vector of the zeros of the model (roots of \code{B(z)})} #' \item{p}{complex vector of the poles of the model (roots of \code{A(z)})} #' \item{g}{overall gain (\code{B(Inf)})} #' } #' #' @seealso \code{\link{filter}} #' #' @examples #' b <- c(2, 3) #' a <- c(1, 1/sqrt(2), 1/4) #' zpk <- tf2zp(b, a) #' #' @author Geert van Boxtel, \email{gjmvanboxtel@@gmail.com} #' #' @export tf2zp <- function(b, a) { if (!(is.vector(b) || is.matrix(b))) { stop("b must be a vector or a matrix") } if (!is.vector(a)) { stop("a must be a vector") } if (NCOL(b) > length(a)) { stop("The number of columns of b must be <= length(a)") } if (length(b) > 0) { z <- pracma::roots(b) } else { z <- NULL } if (length(a) > 0) { p <- pracma::roots(a) } else { p <- NULL } if (a[1] != 0) { k <- b[1] / a[1] if (k <= 0) k <- 1 } else { k <- 1 } Zpg(z = sort(z), p = sort(p), g = k) } gsignal/R/upfirdn.R0000644000176200001440000000767514420222025013701 0ustar liggesusers# upfirdn.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200929 GvB setup for gsignal v0.1.0 # 20210517 GvB adapted examples # 20220328 GvB copy dimnames of x to output object # 20220511 GvB use inherits() instead of direct comparison of class name #------------------------------------------------------------------------------ #' Upsample, apply FIR filter, downsample #' #' Filter and resample a signal using polyphase interpolation. #' #' upfirdn performs a cascade of three operations: #' \enumerate{ #' \item Upsample the input data in the matrix \code{x} by a factor of the #' integer \code{p} (inserting zeros) #' \item FIR filter the upsampled signal data with the impulse response #' sequence given in the vector or matrix \code{h} #' \item Downsample the result by a factor of the integer \code{q} (throwing #' away samples) #' } #' #' The FIR filter is usually a lowpass filter, which you must design using #' another function such as \code{fir1}. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param h Impulse response of the FIR filter specified as a numeric vector or #' matrix. If it is a vector, then it represents one FIR filter to may be #' applied to multiple signals in \code{x}; if it is a matrix, then each #' column is a separate FIR impulse response. #' @param p Upsampling factor, specified as a positive integer (default: 1). #' @param q downsampling factor, specified as a positive integer (default: 1). #' #' @return output signal, returned as a vector or matrix. Each column has length #' \code{ceiling(((length(x) - 1) * p + length(h)) / q)}. #' #' @note This function uses a polyphase implementation, which is generally #' faster than using \code{filter} by a factor equal to the downsampling #' factor, since it only calculates the needed outputs. #' #' @seealso \code{\link{fir1}} #' #' @examples #' #' x <- c(1, 1, 1) #' h <- c(1, 1) #' #' ## FIR filter #' y <- upfirdn(x, h) #' #' ## FIR filter + upsampling #' y <- upfirdn(x, h, 5) #' #' ## FIR filter + downsampling #' y <- upfirdn(x, h, 1, 2) #' #' ## FIR filter + up/downsampling #' y <- upfirdn(x, h, 5, 2) #' #' @author Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export upfirdn <- function(x, h, p = 1, q = 1) { # x and h must be numeric if (!is.numeric(x) || ! is.numeric(h)) { stop("x and h must be numeric") } if (is.vector(x)) { # if x is a vector then h must be a vector too if (!(is.vector(h) || inherits(h, "Ma"))) { stop("h must be a numeric vector") } ns <- 1 x <- matrix(x, ncol = 1) h <- matrix(h, ncol = 1) vec <- TRUE } else if (is.matrix(x)) { ns <- ncol(x) if (is.vector(h)) { h <- matrix(rep(h, ns), ncol = ns, byrow = FALSE) } else if (!is.matrix(h)) { stop("h must be a numeric matrix") } vec <- FALSE } else { stop("x and h must be numeric vectors or matrices") } if (!(isPosscal(p) && isWhole(p)) || !(isPosscal(q) && isWhole(q))) { stop("p and q must be positive integers") } y <- .Call("_gsignal_upfirdn", PACKAGE = "gsignal", x, h, p, q) if (vec) { y <- as.vector(y) } dimnames(y) <- dimnames(x) y } gsignal/R/ifft.R0000644000176200001440000000603214420222025013144 0ustar liggesusers# ifft.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200113 GvB setup for gsignal v0.1.0 # 20200123 GvB adapted rest for Imaginary component == 0 using zapsmall # 20211031 GvB replaced zapsmall test by test for conjugate symmetry #------------------------------------------------------------------------------ #' Inverse Fast Fourier Transform #' #' Compute the inverse Fast Fourier Transform compatible with #' 'Matlab' and 'Octave'. #' #' The \code{'fft'} function in the \code{'stats'} package can compute the #' inverse FFT by specifying \code{inverse = TRUE}. However, that function does #' \emph{not} divide the result by \code{length(x)}, nor does it return real #' values when appropriate. The present function does both, and is this #' compatible with 'Matlab' and 'Octave' (and differs from the \code{'ifft'} #' function in the \code{'signal'} package, which does not return real values). #' #' @param x Real or complex vector, array, or matrix. #' #' @return When \code{x} is a vector, the value computed and returned by #' \code{ifft} is the univariate inverse discrete Fourier transform of the #' sequence of values in \code{x}. Specifically, \code{y <- ifft(x)} is #' defined as \code{stats::fft(x, inverse = TRUE) / length(x)}. The #' \code{stats::fft} function called with \code{inverse = TRUE} replaces #' \code{exp(-2 * pi...)} with \code{exp(2 * pi)} in the definition of the #' discrete Fourier transform (see \code{\link[stats]{fft}}). #' #' When \code{x} contains an array, \code{ifft} computes and returns the #' normalized inverse multivariate (spatial) transform. By contrast, #' \code{imvfft} takes a real or complex matrix as argument, and returns a #' similar shaped matrix, but with each column replaced by its normalized #' inverse discrete Fourier transform. This is useful for analyzing #' vector-valued series. #' #' @examples #' res <- ifft(stats::fft(1:5)) #' res <- ifft(stats::fft(c(1+5i, 2+3i, 3+2i, 4+6i, 5+2i))) #' res <- imvfft(stats::mvfft(matrix(1:20, 4, 5))) #' #' @seealso \code{\link[stats]{fft}} #' #' @author Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export ifft <- function(x) { y <- stats::fft(x, inverse = TRUE) / length(x) if (isConjSymm(x)) Re(y) else y } #' @rdname ifft #' @export imvfft <- function(x) { y <- stats::mvfft(x, inverse = TRUE) / nrow(x) if(all(apply(x, 2, isConjSymm))) Re(y) else y } gsignal/R/filtic.R0000644000176200001440000001167014420222025013472 0ustar liggesusers# filtic.R # Copyright (C) 2020 Geert van Boxtel # Octave version: # Copyright (C) 2004 David Billinghurst # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200317 GvB setup for gsignal v0.1.0 # 20210322 GvB adapted to accept missing x and y parameters (all 1's) # defined S3 methods and added method for Sos #------------------------------------------------------------------------------ #' Filter Initial Conditions #' #' Compute the initial conditions for a filter. #' #' This function computes the same values that would be obtained from the #' function \code{filter} given past inputs \code{x} and outputs \code{y}. #' #' The vectors \code{x} and \code{y} contain the most recent inputs and outputs #' respectively, with the newest values first: #' #' \code{x = c(x(-1), x(-2), ... x(-nb)); nb = length(b)-1}\cr #' \code{y = c(y(-1), y(-2), ... y(-na)); na = length(a)-a} #' #' If \code{length(x) < nb} then it is zero padded. If \code{length(y) < na} #' then it is zero padded. #' #' @param filt For the default case, the moving-average coefficients of an ARMA #' filter (normally called \code{b}), specified as a vector. Generically, #' \code{filt} specifies an arbitrary filter operation. #' @param a the autoregressive (recursive) coefficients of an ARMA filter. #' @param y output vector, with the most recent values first. #' @param x input vector, with the most recent values first. Default: 0 #' @param ... additional arguments (ignored). #' #' @return Initial conditions for filter specified by \code{filt}, input vector #' \code{x}, and output vector \code{y}, returned as a vector. #' #' @examples #' ## Simple low pass filter #' b <- c(0.25, 0.25) #' a <- c(1.0, -0.5) #' ic <- filtic(b, a, 1, 1) #' #' ## Simple high pass filter #' b <- c(0.25, -0.25) #' a <- c(1.0, 0.5) #' ic <- filtic(b, a, 0, 1) #' #' ## Example from Python scipy.signal.lfilter() documentation #' t <- seq(-1, 1, length.out = 201) #' x <- (sin(2 * pi * 0.75 * t * (1 - t) + 2.1) #' + 0.1 * sin(2 * pi * 1.25 * t + 1) #' + 0.18 * cos(2 * pi * 3.85 * t)) #' h <- butter(3, 0.05) #' l <- max(length(h$b), length(h$a)) - 1 #' zi <- filtic(h, rep(1, l), rep(1, l)) #' z <- filter(h, x, zi * x[1]) #' #' @seealso \code{\link{filter}}, \code{\link{sosfilt}}, \code{\link{filtfilt}}, #' \code{\link{filter_zi}} #' #' @author David Billinghurst, \email{David.Billinghurst@@riotinto.com}.\cr #' Adapted and converted to R by Geert van Boxtel #' \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @rdname filtic #' @export filtic <- function(filt, ...) UseMethod("filtic") #' @rdname filtic #' @method filtic default #' @export filtic.default <- function(filt, a, y, x = 0, ...) { b <- filt nz <- max(length(a), length(b)) - 1 zi <- numeric(nz) # Pad arrays a and b to length nz+1 if required if (length(a) < (nz + 1)) { a <- postpad(a, nz + 1) } if (length(b) < (nz + 1)) { b <- postpad(b, nz + 1) } # Pad arrays x and y to length nz if required if (length(x) < nz) { x <- postpad(x, nz) } if (length(y) < nz) { y <- postpad(y, nz) } for (i in seq(nz, 1, -1)) { for (j in i:(nz - 1)) { zi[j] <- b[j + 1] * x[i] - a[j + 1] * y[i] + zi[j + 1] } zi[nz] <- b[nz + 1] * x[i] - a[nz + 1] * y[i] } zi <- zi / a[1] zi } #' @rdname filtic #' @method filtic Arma #' @export filtic.Arma <- function(filt, y, x = 0, ...) # IIR filtic(filt$b, filt$a, y, x, ...) #' @rdname filtic #' @method filtic Ma #' @export filtic.Ma <- function(filt, y, x = 0, ...) # FIR filtic(unclass(filt), 1, y, x, ...) #' @rdname filtic #' @method filtic Sos #' @export filtic.Sos <- function(filt, y, x = 0, ...) { # Second-order sections if (filt$g != 1) { filt$sos[1, 1:3] <- filt$sos[1, 1:3] * filt$g } L <- NROW(filt$sos) zi <- matrix(0, L, 2) scale <- 1.0 for (l in seq_len(L)) { b <- filt$sos[l, 1:3] a <- filt$sos[l, 4:6] zi[l, ] <- scale * filtic.default(b, a, y, x) # If H(z) = B(z)/A(z) is this section's transfer function, then # b.sum()/a.sum() is H(1), the gain at omega=0. That's the steady # state value of this section's step response. scale <- scale * sum(b) / sum(a) } zi } #' @rdname filtic #' @method filtic Zpg #' @export filtic.Zpg <- function(filt, y, x = 0, ...) # zero-pole-gain form filtic(as.Arma(filt), y, x, ...) gsignal/R/decimate.R0000644000176200001440000000654014661366354014020 0ustar liggesusers# decimate.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2000 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201129 GvB setup for gsignal v0.1.0 # 20220328 GvB copy dimnames of x to output object # 20220513 GvB Github Issue #7 # 20240821 GvB Github Issue #17: replace fftfilt() with filtfilt() # when ftype == 'fir'; changed order of arguments #------------------------------------------------------------------------------ #' Decrease sample rate #' #' Downsample a signal by an integer factor. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param q decimation factor, specified as a positive integer. #' @param n Order of the filter used prior to the downsampling, specified as a #' positive integer. Default: 8 if \code{ftype} equals \code{"iir"}; 30 of #' \code{ftype} equals \code{"fir"}. #' @param ftype filter type; either \code{"fir"}, specifying a FIR filter of #' length \code{n} designed with the function \code{\link{fir1}}, or #' \code{"iir"} (default), specifying an IIR Chebyshev filter of order 8 using #' the function \code{\link{cheby1}}. #' #' @return downsampled signal, returned as a vector or matrix. #' #' @examples #' t <- seq(0, 2, 0.01) #' x <- chirp(t, 2, .5, 10, 'quadratic') + sin(2 * pi * t * 0.4) #' w <- 1:121 #' plot(t[w] * 1000, x[w], type = "h", col = "green") #' points(t[w] * 1000, x[w], col = "green") #' y = decimate(x, 4) #' lines(t[seq(1, 121, 4)] * 1000, y[1:31], type = "h", col = "red") #' points(t[seq(1, 121, 4)] * 1000, y[1:31], col = "red") #' #' @seealso \code{\link{cheby1}}, \code{\link{fir1}} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export decimate <- function(x, q, ftype = c("iir", "fir"), n = ifelse(ftype == "iir", 8, 30)) { if (!is.numeric(x)) { stop("x must be numeric") } if (is.vector(x)) { x <- matrix(x, ncol = 1) l <- length(x) vec <- TRUE } else if (is.matrix(x)) { vec <- FALSE l <- nrow(x) } else { stop("x must be a numeric vector or matrix") } ftype <- match.arg(ftype) if (!(isPosscal(q) && isWhole(q))) { stop("q must be a positive integer") } if (!(isPosscal(n) && isWhole(n))) { stop("n must be a positive integer") } if (ftype == "fir") { b <- fir1(n, 1 / q) y <- filtfilt(b, x) } else { ba <- cheby1(n, 0.05, 0.8 / q) y <- filtfilt(ba, x) } y <- y[seq(1, l, q), ] if (vec) { y <- as.vector(y) } dimnames(y) <- dimnames(x) y } gsignal/R/findpeaks.R0000644000176200001440000002503714670251410014175 0ustar liggesusers# findpeaks.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2012 Juan Pablo Carbajal # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200105 GvB setup for gsignal v0.1.0 # 20220511 GvB use inherits() instead of direct comparison of class name # 20240708 GvB pull request #19 from jefferis: line 174 changed # 20240909 GvB Issue #21 (bnicenboim); added test on success of call to # pracma::polyfit # 20240911 GvB Issue #22 (bnicenboim) corrected typos that resulted # in crash with weid error msg #------------------------------------------------------------------------------ #' Find local extrema #' #' Return peak values and their locations of the vector \code{data}. #' #' Peaks of a positive array of \code{data} are defined as local maxima. For #' double-sided data, they are maxima of the positive part and minima of the #' negative part. \code{data} is expected to be a one-dimensional vector. #' #' @param data the data, expected to be a vector or one-dimensional array. #' @param MinPeakHeight Minimum peak height (non-negative scalar). Only peaks #' that exceed this value will be returned. For data taking positive and #' negative values use the option \code{DoubleSided}. Default: #' \code{.Machine$double.eps}. #' @param MinPeakDistance Minimum separation between peaks (positive integer). #' Peaks separated by less than this distance are considered a single peak. #' This distance is also used to fit a second order polynomial to the peaks to #' estimate their width, therefore it acts as a smoothing parameter. The #' neighborhood size is equal to the value of \code{MinPeakDistance}. Default: #' 1. #' @param MinPeakWidth Minimum width of peaks (positive integer). The width of #' the peaks is estimated using a parabola fitted to the neighborhood of each #' peak. The width is calculated with the formula \eqn{a * (width - x0)^{2} = #' 1}, where a is the the concavity of the parabola and x0 its vertex. #' Default: 1. #' @param MaxPeakWidth Maximum width of peaks (positive integer). Default: #' \code{Inf}. #' @param DoubleSided Tells the function that data takes positive and negative #' values. The baseline for the peaks is taken as the mean value of the #' function. This is equivalent as passing the absolute value of the data #' after removing the mean. Default: FALSE #' #' @return A list containing the following elements: #' \describe{ #' \item{pks}{The value of data at the peaks.} #' \item{loc}{The index indicating the position of the peaks.} #' \item{parabol}{A list containing the parabola fitted to each returned peak. #' The list has two fields, \code{x} and \code{pp}. The field \code{pp} #' contains the coefficients of the 2nd degree polynomial and \code{x} the #' extrema of the interval where it was fitted.} #' \item{height}{The estimated height of the returned peaks (in units of #' data).} #' \item{baseline}{The height at which the roots of the returned peaks were #' calculated (in units of data).} #' \item{roots}{The abscissa values (in index units) at which the parabola #' fitted to each of the returned peaks realizes its width as defined below.} #' } #' #' @examples #' ### demo 1 #' t <- 2 * pi * seq(0, 1,length = 1024) #' y <- sin(3.14 * t) + 0.5 * cos(6.09 * t) + #' 0.1 * sin(10.11 * t + 1 / 6) + 0.1 * sin(15.3 * t + 1 / 3) #' #' data1 <- abs(y) # Positive values #' peaks1 <- findpeaks(data1) #' #' data2 <- y # Double-sided #' peaks2 <- findpeaks(data2, DoubleSided = TRUE) #' peaks3 <- findpeaks (data2, DoubleSided = TRUE, MinPeakHeight = 0.5) #' #' op <- par(mfrow=c(1,2)) #' plot(t, data1, type="l", xlab="", ylab="") #' points(t[peaks1$loc], peaks1$pks, col = "red", pch = 1) #' plot(t, data2, type = "l", xlab = "", ylab = "") #' points(t[peaks2$loc], peaks2$pks, col = "red", pch = 1) #' points(t[peaks3$loc], peaks3$pks, col = "red", pch = 4) #' legend ("topleft", "0: >2*sd, x: >0.5", bty = "n", #' text.col = "red") #' par (op) #' title("Finding the peaks of smooth data is not a big deal") #' #' ## demo 2 #' t <- 2 * pi * seq(0, 1, length = 1024) #' y <- sin(3.14 * t) + 0.5 * cos(6.09 * t) + 0.1 * #' sin(10.11 * t + 1 / 6) + 0.1 * sin(15.3 * t + 1 / 3) #' data <- abs(y + 0.1*rnorm(length(y),1)) # Positive values + noise #' peaks1 <- findpeaks(data, MinPeakHeight=1) #' dt <- t[2]-t[1] #' peaks2 <- findpeaks(data, MinPeakHeight=1, MinPeakDistance=round(0.5/dt)) #' op <- par(mfrow=c(1,2)) #' plot(t, data, type="l", xlab="", ylab="") #' points (t[peaks1$loc],peaks1$pks,col="red", pch=1) #' plot(t, data, type="l", xlab="", ylab="") #' points (t[peaks2$loc],peaks2$pks,col="red", pch=1) #' par (op) #' title(paste("Noisy data may need tuning of the parameters.\n", #' "In the 2nd example, MinPeakDistance is used\n", #' "as a smoother of the peaks")) #' #' @author Juan Pablo Carbajal, \email{carbajal@@ifi.uzh.ch}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export findpeaks <- function(data, MinPeakHeight = .Machine$double.eps, MinPeakDistance = 1, MinPeakWidth = 1, MaxPeakWidth = Inf, DoubleSided = FALSE) { # check function arguments ld <- length(data) if (!is.numeric(data) || !(is.vector(data) || is.array(data) || inherits(data, "ts")) || ld < 3) stop("data must be a numeric vector of at least 3 elements") if (!isPosscal(MinPeakHeight)) stop("MinPeakHeight must be a positive scalar") if (!isPosscal(MinPeakDistance)) stop("MinPeakDistance must be a positive scalar") if (!isPosscal(MinPeakWidth)) stop("MinPeakWidth must be a positive scalar") if (!is.logical(DoubleSided)) stop("DoubleSided should a a logical value TRUE or FALSE") wdata <- abs(detrend(data, 0)) if (DoubleSided) { tmp <- data data <- wdata wdata <- tmp } else { if (min(data, na.rm = TRUE) < 0) { stop("Data contains negative values. Use the 'DoubleSided' option?") } } # Rough estimates of first and second derivative df1 <- diff(data, differences = 1)[c(1, 1:(ld - 1))] df2 <- diff(data, differences = 2)[c(1, 1, 1:(ld - 2))] # check for changes of sign of 1st derivative and negativity of 2nd deriv. # <= in 1st derivative includes the case of oversampled signals. idx <- which(df1 * c(df1[2:length(df1)], 0) <= 0 & c(df2[2:length(df2)], 0) < 0) # Get peaks that are beyond given height tf <- which(data[idx] > MinPeakHeight) idx <- idx[tf] if (length(idx) <= 0) return(NULL) # sort according to magnitude tmp <- sort(data[idx], decreasing = TRUE, index = TRUE) idx_s <- idx[tmp$ix] ## Treat peaks separated less than MinPeakDistance as one D <- with(expand.grid(A = idx_s, B = t(idx_s)), abs(A - B)) dim(D) <- c(length(idx_s), length(idx_s)) diag(D) <- NA # eliminate diagonal comparison if (isTRUE(any(D < MinPeakDistance))) { i <- 1 node2visit <- seq_along(idx_s) visited <- NULL idx_pruned <- idx_s while (length(node2visit) > 0) { d <- D[node2visit[1], ] visited <- c(visited, node2visit[1]) node2visit <- node2visit[-1] neighs <- setdiff(which(d < MinPeakDistance), visited) if (length(neighs) > 0) { idx_pruned <- setdiff(idx_pruned, idx_s[neighs]) visited <- c(visited, neighs) node2visit <- setdiff(node2visit, visited) } } idx <- idx_pruned } idx <- sort(idx) extra_x <- extra_pp <- extra_roots <- extra_height <- extra_baseline <- data.frame() # Estimate widths of peaks and filter for: # width smaller than given. # wrong concavity. # not high enough # data at peak is lower than parabola by 1% idx_pruned <- idx n <- length(idx) for (i in 1:n) { ind <- floor(pmax(idx[i] - MinPeakDistance / 2, 1)) : ceiling(pmin(idx[i] + MinPeakDistance / 2, ld)) pp <- rep(0L, 3) if (isTRUE(any(data[idx[i] - 1] == data[idx[i]]))) { # sample on left same as peak: skip xm <- 0 pp <- rep(1L, 3) } else if (isTRUE(any(data[ind] > data[idx[i]]))) { # Matlab/Octave give warning if matrix is singular, # pracma produces an error # Catch error and skip peak in this case result <- try(pp <- pracma::polyfit(ind, data[ind], 2), silent = TRUE) if (inherits(result, 'try-error')) { xm <- 0 pp <- rep(1L, 3) } else { xm <- -pp[2]^2 / (2 * pp[1]) # position of extrema H <- pracma::polyval(pp, xm) # value at extrema } } else { # use it as vertex of parabola H <- data[idx[i]] xm <- idx[i] pp <- rep(1L, 3) pp[1] <- pracma::mldivide((ind - xm)^2, (data[ind] - H)) pp[2] <- -2 * pp[1] * xm pp[3] <- H + pp[1] * xm^2 } width <- sqrt(abs(1 / pp[1])) + xm if ((width > MaxPeakWidth || width < MinPeakWidth) || pp[1] > 0 || H < MinPeakHeight || data[idx[i]] < 0.99 * H || abs(idx[i] - xm) > MinPeakDistance / 2) { idx_pruned <- setdiff(idx_pruned, idx[i]) } else { extra_x <- rbind(extra_x, ind[c(1, length(ind))]) extra_pp <- rbind(extra_pp, pp) extra_roots <- rbind(extra_roots, xm + c(-width, width) / 2) extra_height <- rbind(extra_height, H) extra_baseline <- rbind(extra_baseline, mean(c(H, MinPeakHeight))) } } idx <- idx_pruned # check for double sided if (DoubleSided) { pks <- wdata[idx] } else { pks <- data[idx] } # return values colnames(extra_x) <- c("from", "to") colnames(extra_pp) <- c("b2", "b", "a") colnames(extra_roots) <- c("a0", "a1") list(pks = pks, loc = idx, parabol = list(x = as.list(extra_x), pp = as.list(extra_pp)), height = as.numeric(extra_height[, 1]), baseline = as.numeric(extra_baseline[, 1]), roots = as.list(extra_roots)) } gsignal/R/unwrap.R0000644000176200001440000000502714420222025013533 0ustar liggesusers# unwrap.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 2000-2017 Bill Lash # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200413 GvB setup for gsignal v0.1.0 # 20210425 GvB bugfix: handle NA, Nan, -Inf, Inf # unwrap vector or matrix along columns #------------------------------------------------------------------------------ #' Unwrap phase angles #' #' Unwrap radian phases by adding or subtracting multiples of \code{2 * pi}. #' #' @param x Input array, specified as a vector or a matrix. If \code{x} is a #' matrix, unwrapping along the columns of \code{x} is applied. #' @param tol Jump threshold to apply phase shift, specified as a scalar. A jump #' threshold less than \eqn{pi} has the same effect as the threshold #' \eqn{pi}. Default: \deqn{pi}. #' #' @return Unwrapped phase angle, returned as a vector, matrix, or #' multidimensional array. #' #' @examples #' ## Define spiral shape. #' t <- seq(0, 6 * pi, length.out = 201) #' x <- t / pi * cos(t) #' y <- t / pi * sin(t) #' plot(x, y, type = "l") #' ## find phase angle #' p = atan2(y, x) #' plot(t, p, type="l") #' ## unwrap it #' q = unwrap(p) #' plot(t, q, type ="l") #' #' @author Bill Lash.\cr #' Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com} #' #' @export unwrap <- function(x, tol = pi) { if (is.vector(x)) { x <- as.matrix(x, ncol = 1) vec <- TRUE } else { vec <- FALSE } nr <- nrow(x) nc <- ncol(x) if (!is.numeric (x)) { stop("x must be a numeric matrix or vector") } tol <- abs (tol) y <- x if (nr > 1) { rng <- 2 * pi for (col in seq_len(nc)) { valid <- which(is.finite(x[, col])) d <- diff(x[valid, col]) p <- round(abs(d) / rng) * rng * (((d > tol) > 0) - ((d < -tol) > 0)) r <- cumsum(p) y[valid, col] <- x[valid, col] - c(0, r) } } if (vec) { y <- as.vector(y) } y } gsignal/R/xcorr2.R0000644000176200001440000000760414420222025013441 0ustar liggesusers# xcorr2.R # Copyright (C) 2020 Geert van Boxtel # Octave version: # Copyright (C) 2000 Dave Cogdell # Copyright (C) 2000 Paul Kienzle # Copyright (C) 2012 Carne Draug # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 2020313 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' 2-D cross-correlation #' #' Compute the 2D cross-correlation of matrices \code{a} and \code{b}. #' #' If \code{b} is not specified, computes autocorrelation of \code{a}, #' i.e., same as \code{xcorr2 (a, a)}. #' #' @param a Input matrix, coerced to numeric. Must not be missing. #' @param b Input matrix, coerced to numeric. Default: \code{a}. #' @param scale Character string. Specifies the type of scaling applied to the #' correlation matrix. matched to one of: #' \describe{ #' \item{"none"}{no scaling} #' \item{"biased"}{Scales the raw cross-correlation by the maximum number of #' elements of \code{a} and \code{b} involved in the generation of any #' element of the output matrix.} #' \item{"unbiased"}{Scales the raw correlation by dividing each element in #' the cross-correlation matrix by the number of products \code{a} and #' \code{b} used to generate that element. } #' \item{"coeff"}{Scales the normalized cross-correlation on the range of [0 #' 1] so that a value of 1 corresponds to a correlation coefficient of 1. } #' } #' #' @return 2-D cross-correlation or autocorrelation matrix, returned as a matrix #' #' @seealso \code{\link{conv2}}, \code{\link{xcorr}}. #' #' @examples #' m1 <- matrix(c(17, 24, 1, 8, 15, #' 23, 5, 7, 14, 16, #' 4, 6, 13, 20, 22, #' 10, 12, 19, 21, 3, #' 11, 18, 25, 2, 9), 5, 5, byrow = TRUE) #' m2 <- matrix(c(8, 1, 6, #' 3, 5, 7, #' 4, 9, 2), 3, 3, byrow = TRUE) #' R <- xcorr2(m1, m2) #' #' @author Dave Cogdell, \email{cogdelld@@asme.org},\cr #' Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Carne Draug, \email{carandraug+dev@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export xcorr2 <- function(a, b = a, scale = c("none", "biased", "unbiased", "coeff")) { if (!is.matrix(a) || !is.matrix(b)) { stop("input matrices must must have 2 dimensions") } scale <- match.arg(scale) ## compute correlation ma <- nrow(a) na <- ncol(a) mb <- nrow(b) nb <- ncol(b) R <- conv2(a, Conj(b[rev(1:mb), rev(1:nb)])) # bias routines by Dave Cogdell (cogdelld@asme.org) # optimized by Paul Kienzle (pkienzle@users.sf.net) # coeff routine by Carnë Draug (carandraug+dev@gmail.com) if (scale == "biased") { R <- R / (min(ma, mb) * min(na, nb)) } else if (scale == "unbiased") { lo <- min(na, nb) hi <- max(na, nb) row <- c(1:(lo - 1), rep(lo, (hi - lo + 1)), rev(1:(lo - 1))) lo <- min(ma, mb) hi <- max(ma, mb) col <- c(1:(lo - 1), rep(lo, (hi - lo + 1)), rev(1:(lo - 1))) bias <- outer(col, row) R <- R / bias } else if (scale == "coeff") { a <- Re(a) b <- Re(b) a <- conv2(a^2, matrix(1L, nrow(b), ncol(b))) b <- ssq(as.vector(b)) R <- R / sqrt(a * b) } R } gsignal/R/stft.R0000644000176200001440000001605114420222025013176 0ustar liggesusers# stft.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 1995-2019 Andreas Weingessel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201206 GvB setup for gsignal v0.1.0 # 20210411 GvB v0.3.0 bugfix in output time points # 20221103 GvB correct typos in stft.R # (H. Dieter Wilhelm - Pull request #10) #------------------------------------------------------------------------------ #' Short-Term Fourier Transform #' #' Compute the short-term Fourier transform of a vector or matrix. #' #' @param x input data, specified as a numeric or complex vector or matrix. In #' case of a vector it represents a single signal; in case of a matrix each #' column is a signal. #' @param window If \code{window} is a vector, each segment has the same length #' as \code{window} and is multiplied by \code{window} before (optional) #' zero-padding and calculation of its periodogram. If \code{window} is a #' scalar, each segment has a length of \code{window} and a Hamming window is #' used. Default: \code{nextpow2(sqrt(NROW(x)))} (the square root of the #' length of \code{x} rounded up to the next power of two). The window length #' must be larger than 3. #' @param overlap segment overlap, specified as a numeric value expressed as a #' multiple of window or segment length. 0 <= overlap < 1. Default: 0.75. #' @param nfft Length of FFT, specified as an integer scalar. The default is the #' length of the \code{window} vector or has the same value as the scalar #' \code{window} argument. If \code{nfft} is larger than the segment length, #' (seg_len), the data segment is padded \code{nfft - seg_len} zeros. The #' default is no padding. Nfft values smaller than the length of the data #' segment (or window) are ignored. Note that the use of padding to increase #' the frequency resolution of the spectral estimate is controversial. #' @param fs sampling frequency (Hertz), specified as a positive scalar. #' Default: 1. #' #' @return A list containing the following elements: #' \describe{ #' \item{\code{f}}{vector of frequencies at which the STFT is estimated. #' If \code{x} is numeric, power from negative frequencies is added to the #' positive side of the spectrum, but not at zero or Nyquist (fs/2) #' frequencies. This keeps power equal in time and spectral domains. If #' \code{x} is complex, then the whole frequency range is returned.} #' \item{\code{t}}{vector of time points at which the STFT is estimated.} #' \item{\code{s}}{Short-time Fourier transform, returned as a matrix or #' a 3-D array. Time increases across the columns of \code{s} and frequency #' increases down the rows. The third dimension, if present, corresponds to #' the input channels.} #' } #' #' @examples #' fs <- 8000 #' y <- chirp(seq(0, 5 - 1/fs, by = 1/fs), 200, 2, 500, "logarithmic") #' ft <- stft (y, fs = fs) #' filled.contour(ft$t, ft$f, t(ft$s), xlab = "Time (s)", #' ylab = "Frequency (Hz)") #' #' @author Andreas Weingessel, \email{Andreas.Weingessel@@ci.tuwien.ac.at}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export stft <- function(x, window = nextpow2(sqrt(NROW(x))), overlap = 0.75, nfft = ifelse(isScalar(window), window, length(window)), fs = 1) { # check parameters if (!(is.vector(x) || is.matrix(x)) && !(is.numeric(x) || is.complex(x))) { stop("x must be a numeric or complex vector or matrix") } if (is.vector(x)) { x <- as.matrix(x, ncol = 1) } nr <- nrow(x) nc <- ncol(x) if (!is.vector(window) || !is.numeric(window)) { stop("window must be a numeric vector or scalar") } else { if (isPosscal(window)) { if (window <= 3) { stop("window must be a scalar > 3 or a vector with length > 3") } else { window <- hamming(window) } } else if (length(window) <= 3) { stop("window must be a scalar > 3 or a vector with length > 3") } } if (!isScalar(overlap) || !(overlap >= 0 && overlap < 1)) { stop("overlap must be a numeric value >= 0 and < 1") } if (!isPosscal(nfft) || !isWhole(nfft)) { stop("nfft must be a positive integer") } if (!isPosscal(fs) || fs <= 0) { stop("fs must be a numeric value > 0") } # initialize variables seg_len <- length(window) overlap <- trunc(seg_len * overlap) nfft <- nextpow2(max(nfft, seg_len)) win_meansq <- as.vector(window %*% window / seg_len) num_win <- floor((nr - overlap) / (seg_len - overlap)) if (overlap >= seg_len) { stop("overlap must be smaller than window length") } # Pad data with zeros if shorter than segment. This should not happen. if (nr < seg_len) { x <- c(x, rep(0, seg_len - nr)) nr <- seg_len } # MAIN CALCULATIONS # Calculate and accumulate periodograms Pxx <- array(0, dim = c(nfft, num_win, nc)) t <- rep(0, num_win) n_ffts <- 0 for (start_seg in seq(1, nr - seg_len + 1, seg_len - overlap)) { end_seg <- start_seg + seg_len - 1 xx <- window * x[start_seg:end_seg, ] if (nc == 1) { fft_x <- stats::fft(xx) } else { fft_x <- stats::mvfft(xx) } # accumulate periodogram n_ffts <- n_ffts + 1 Pxx[1:nfft, n_ffts, 1:nc] <- Re(fft_x * Conj(fft_x)) t[n_ffts] <- 0.5 * (end_seg - start_seg + 1) / fs } # Convert two-sided spectra to one-sided spectra if the input is numeric # For one-sided spectra, contributions from negative frequencies are added # to the positive side of the spectrum -- but not at zero or Nyquist # (half sampling) frequencies. This keeps power equal in time and spectral # domains, as required by Parseval theorem. if (is.numeric(x)) { if (nfft %% 2 == 0) { # one-sided, nfft is even psd_len <- nfft / 2 + 1 Pxx <- apply(Pxx, c(2, 3), function(x) x[1:psd_len] + c(0, x[seq(nfft, psd_len + 1, -1)], 0)) } else { # one-sided, nfft is odd psd_len <- (nfft + 1) / 2 Pxx <- apply(Pxx, c(2, 3), function(x) x[1:psd_len] + c(0, x[seq(nfft, psd_len + 1, -1)])) } } else { psd_len <- nfft } # end MAIN CALCULATIONS ## SCALING AND OUTPUT scale <- n_ffts * seg_len * fs * win_meansq s <- Pxx / scale f <- seq(0, psd_len - 1) * (fs / nfft) t <- seq(0, (nr / fs) - 1 / fs, length.out = num_win) if (nc == 1) { s <- s[, , 1] } list(f = f, t = t, s = s) } gsignal/R/Arma.R0000644000176200001440000000776314420222025013110 0ustar liggesusers# Arma.R # Copyright (C) 2020 Geert van Boxtel # Original 'signal' version: # Copyright (C) 2006 EPRI Solutions, Inc. # by Tom Short, tshort@eprisolutions.com # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200127 GvB setup for gsignal v0.1.0 # 20200402 GvB Adapted to Octave filter conversion functions # 20200425 GvB as.Arma.Zpg(): adapted zero pole gain to z p g # 20210603 GvB as.Arma.Sos(): g = x$g instead of g = 1 #------------------------------------------------------------------------------ #' Autoregressive moving average (ARMA) model #' #' Create an ARMA model representing a filter or system model, or #' convert other forms to an ARMA model. #' #' The ARMA model is defined by: #' \deqn{a(L)y(t) = b(L)x(t)} #' The ARMA model can define an analog or digital model. The AR and MA #' polynomial coefficients follow the convention in 'Matlab' and 'Octave' where #' the coefficients are in decreasing order of the polynomial (the opposite of #' the definitions for \code{\link[stats]{filter}}filter and #' \code{\link[base]{polyroot}}). For an analog model, #' \if{latex}{ #' \deqn{H(s) = (b_1 s^{(m-1)} + b_2 s^{(m-2)} + \ldots + b_m) / (a_1 s^{(n-1)} #' + a_2 s^{(n-2)} + \ldots + a_n)} #' } #' \if{html}{\preformatted{ #' H(s) = (b[1]*s^(m-1) + b[2]*s^(m-2) + ... + b[m]) / (a[1]*s^(n-1) + #' a[2]*s^(n-2) + ... + a[n]) #' }} #' For a z-plane digital model, #' \if{latex}{ #' \deqn{H(z) = (b_1 + b_2 z^{-1} + \ldots + b_m z^{(-m+1)}) / (a_1 + a_2 #' z^{-1} + \ldots + a_n z^{(-n+1)})} #' } #' \if{html}{\preformatted{ #' H(z) = (b[1] + b[2]*z^(-1) + … + b[m]*z^(-m+1)) / (a[1] + a[2]*z^(-1) + … + #' a[n]*z^(-n+1)) #' }} #' #' #' \code{as.Arma} converts from other forms, including \code{Zpg} and \code{Ma}. #' #' @param b moving average (MA) polynomial coefficients. #' @param a autoregressive (AR) polynomial coefficients. #' @param x model or filter to be converted to an ARMA representation. #' @param ... additional arguments (ignored). #' #' @return A list of class \code{'Arma'} with the following list elements: #' \describe{ #' \item{b}{moving average (MA) polynomial coefficients} #' \item{a}{autoregressive (AR) polynomial coefficients} #' } #' #' @seealso See also \code{\link{Zpg}}, \code{\link{Ma}}, \code{\link{filter}}, #' and various filter-generation functions like \code{\link{butter}} and #' \code{\link{cheby1}} that return Arma models. #' #' @examples #' filt <- Arma(b = c(1, 2, 1)/3, a = c(1, 1)) #' zplane(filt) #' #' @author Tom Short, \email{tshort@@eprisolutions.com},\cr #' adapted by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com}. #' #' @rdname Arma #' @export Arma <- function(b, a) { res <- list(b = b, a = a) class(res) <- "Arma" res } #' @rdname Arma #' @export as.Arma <- function(x, ...) UseMethod("as.Arma") #' @rdname Arma #' @usage #' ## S3 method for class 'Arma' #' as.Arma(x, ...) #' @export as.Arma.Arma <- function(x, ...) x #' @rdname Arma #' @usage #' ## S3 method for class 'Ma' #' as.Arma(x, ...) #' @export as.Arma.Ma <- function(x, ...) { Arma(b = unclass(x), a = 1) } #' @rdname Arma #' @usage #' ## S3 method for class 'Sos' #' as.Arma(x, ...) #' @export as.Arma.Sos <- function(x, ...) { ba <- sos2tf(x$sos, x$g) Arma(ba$b, ba$a) } #' @rdname Arma #' @usage #' ## S3 method for class 'Zpg' #' as.Arma(x, ...) #' @export as.Arma.Zpg <- function(x, ...) { ba <- zp2tf(x$z, x$p, x$g) Arma(ba$b, ba$a) } gsignal/R/residuez.R0000644000176200001440000000507614473617210014071 0ustar liggesusers# residuez.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 2005 Julius O. Smith III # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200804 GvB setup for gsignal v0.1.0 # 20230830 GvB solved Github Issue #15 by loeriver: # - Removed Conj() on rev(rpk$k) # - check is.null(rpk$p) #------------------------------------------------------------------------------ #' Z-transform partial fraction expansion #' #' Finds the residues, poles, and direct term of a Partial Fraction Expansion of #' the ratio of two polynomials. #' #' \code{residuez} converts a discrete time system, expressed as the ratio of #' two polynomials, to partial fraction expansion, or residue, form. #' #' @param b coefficients of numerator polynomial #' @param a coefficients of denominator polynomial #' #' @return A list containing #' \describe{ #' \item{r}{vector of filter pole residues of the partial fraction} #' \item{p}{vector of partial fraction poles} #' \item{k}{vector containing FIR part, if any (empty if \code{length(b) < #' length(a)})} #' } #' #' @seealso \code{\link{residue}}, \code{\link{residued}} #' #' @examples #' b0 <- 0.05634 #' b1 <- c(1, 1) #' b2 <- c(1, -1.0166, 1) #' a1 <- c(1, -0.683) #' a2 <- c(1, -1.4461, 0.7957) #' b <- b0 * conv(b1, b2) #' a <- conv(a1, a2) #' res <- residuez(b, a) #' #' @author Julius O. Smith III, \email{jos@@ccrma.stanford.edu}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com} #' #' @export residuez <- function(b, a) { if (!is.vector(b) || !is.vector(a)) { stop("b and a must be vectors") } rpk <- residue(rev(b), rev(a)) if (!is.null(rpk$p)) { p <- 1 / rpk$p m <- mpoles(p) r <- rpk$r * ((-p)^m) } else { r <- NULL p <- NULL } if (!is.null(rpk$k)) { k <- rev(rpk$k) } else { k <- NULL } r <- zapIm(r) p <- zapIm(p) list(r = r, p = p, k = k) } gsignal/R/medfilt1.R0000644000176200001440000000770414420222025013730 0ustar liggesusers# medfilt1.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200320 GvB setup for gsignal v0.1.0 # 20210405 GvB changed 'dim' argument to MARGIN #------------------------------------------------------------------------------ #' 1-D median filtering #' #' Apply a running median of odd span to the input \code{x} #' #' This function computes a running median over the input \code{x}, using the #' \code{\link[stats]{runmed}} function. Because of that, it works a little #' differently than the 'Matlab' or 'Octave' versions (i.e., it does not produce #' exactly the same values). #' #' \describe{ #' \item{missing values}{The 'Mablab' and 'Octave' functions have a #' \code{'nanflag'} option that allows to include or remove missing values. If #' inclusion is specifies, then the function returns a signal so that the median #' of any segment containing NAs is also NA. Because the \code{'runmed'} function #' does not include an \code{na.omit} option, implementing this functionality #' would lead to a considerable speed loss. Instead, a \code{na.omit} parameter #' was implemented that allows either omitting NAs or interpolating them with a #' spline function.} #' \item{endpoint filtering}{Instead of the \code{'zeropad'} and #' \code{'truncate'} options to the \code{'padding'} argument in the 'Matlab' #' and 'Octave' functions, the present version uses the standard #' \code{endrule} parameter of the \code{'runmed'} function, with options #' \code{keep}, \code{constant}, or \code{median}.} #'} #' #' @param x Input signal, specified as a numeric vector, matrix or array. #' @param n positive integer width of the median window; must be odd. Default: 3 #' @param MARGIN Vector giving the subscripts which the function will be applied #' over. E.g., for a matrix 1 indicates rows, 2 indicates columns, c(1, 2) #' indicates rows and columns. Where X has named dimnames, it can be a #' character vector selecting dimension names. Default: 2 (columns). #' @param na.omit logical indicating whether to omit missing values, #' or interpolate then using a cubic spline function #' (\code{\link[stats]{splinefun}}). Default: FALSE #' @param ... other arguments passed to \code{runmed} #' #' @return Filtered signal, returned as a numeric vector, matrix, or array, of #' the same size as \code{x}. #' #' @examples #' ## noise suppression #' fs <- 100 #' t <- seq(0, 1, 1/fs) #' x <- sin(2 * pi * t * 3) + 0.25 * sin(2 * pi * t * 40) #' plot(t, x, type = "l", xlab = "", ylab = "") #' y <- medfilt1(x, 11) #' lines (t, y, col = "red") #' legend("topright", c("Original", "Filtered"), lty = 1, col = 1:2) #' #' @seealso \code{\link[stats]{runmed}}, \code{\link[stats]{splinefun}} #' #' @author Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export medfilt1 <- function(x, n = 3, MARGIN = 2, na.omit = FALSE, ...) { mf <- function(x, n, na.omit, ...) { if (n %% 2 != 1 || n > length(x)) { stop("n must be odd and smaller than the length of x") } if (any(is.na(x))) { if (na.omit) { x <- na.omit(x) } else { spl <- stats::splinefun(seq_along(x), x) x <- spl(seq_along(x)) } } y <- stats::runmed(x, n, ...) as.vector(y) } if (is.vector(x)) { y <- mf(x, n, na.omit, ...) } else { y <- apply(x, MARGIN, mf, n, na.omit, ...) } y } gsignal/R/gauspuls.R0000644000176200001440000000514314420222025014061 0ustar liggesusers# gauspuls.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2007 Sylvain Pelissier # Copyright (C) 2018-2019 Mike Miller # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191124 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Gaussian-modulated sinusoidal RF pulse #' #' Generate a Gaussian modulated sinusoidal pulse sampled at times \code{t}. #' #' @param t Vector of time values at which the unit-amplitude Gaussian RF pulse #' is calculated. #' @param fc Center frequency of the Gaussian-modulated sinusoidal pulses, #' specified as a real positive scalar expressed in Hz. Default: 1000 #' @param bw Fractional bandwidth of the Gaussian-modulated sinusoidal pulses, #' specified as a real positive scalar. #' #' @return Inphase Gaussian-modulated sinusoidal pulse, returned as a vector of #' unit amplitude at the times indicated by the time vector t. #' #' @examples #' #' fs <- 11025 # arbitrary sample rate #' t <- seq(-10, 10, 1/fs) #' yi1 <- gauspuls(t, 0.1, 1) #' yi2 <- gauspuls(t, 0.1, 2) #' plot(t, yi1, type="l", xlab = "Time", ylab = "Amplitude") #' lines(t, yi2, col = "red") #' #' fs <- 11025 # arbitrary sample rate #' f0 <- 100 # pulse train sample rate #' x <- pulstran (seq(0, 4/f0, 1/fs), seq(0, 4/f0, 1/f0), "gauspuls") #' plot (0:(length(x)-1) * 1000/fs, x, type="l", #' xlab = "Time (ms)", ylab = "Amplitude", #' main = "Gaussian pulse train at 10 ms intervals") #' #' @author Sylvain Pelissier, Mike Miller.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export gauspuls <- function(t, fc = 1e3, bw = 0.5) { if (!isPosscal(fc)) stop("fc must be a non-negative real scalar") if (!isPosscal(bw) || bw <= 0) stop("bw must be a positive real scalar") fv <- - (bw^2 * fc^2) / (8 * log(10 ^ (-6 / 20))) tv <- 1 / (4 * pi^2 * fv) y <- exp(-t * t / (2 * tv)) * cos(2 * pi * fc * t) y } gsignal/R/levinson.R0000644000176200001440000001157514420222025014061 0ustar liggesusers# levinson.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 1999 Paul Kienzle # Copyright (C) 2006 Peter V. Lanspeary # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201105 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Durbin-Levinson Recursion #' #' Use the Durbin-Levinson algorithm to compute the coefficients of an #' autoregressive linear process. #' #' \code{levinson} uses the Durbin-Levinson algorithm to solve: #' \deqn{toeplitz(acf(1:p)) * x = -acf(2:p+1)} The solution \code{c(1, x)} is #' the denominator of an all pole filter approximation to the signal \code{x} #' which generated the autocorrelation function acf. #' #' From ref [2]: Levinson recursion or Levinson–Durbin recursion is a procedure #' in linear algebra to recursively calculate the solution to an equation #' involving a Toeplitz matrix. Other methods to process data include Schur #' decomposition and Cholesky decomposition. In comparison to these, Levinson #' recursion (particularly split Levinson recursion) tends to be faster #' computationally, but more sensitive to computational inaccuracies like #' round-off errors. #' #' @param acf autocorrelation function for lags 0 to \code{p}, specified as a #' vector or matrix. If r is a matrix, the function finds the coefficients for #' each column of \code{acf} and returns them in the rows of \code{a}. #' @param p model order, specified as a positive integer. Default: #' \code{NROW(acf) - 1}. #' #' @return A \code{list} containing the following elements: #' \describe{ #' \item{a}{vector or matrix containing \code{(p+1)} autoregression #' coefficients. If \code{x} is a matrix, then each row of a corresponds to #' a column of \code{x}. \code{a} has \code{p + 1} columns.} #' \item{e}{white noise input variance, returned as a vector. If \code{x} is #' a matrix, then each element of e corresponds to a column of \code{x}.} #' \item{k}{Reflection coefficients defining the lattice-filter embodiment #' of the model returned as vector or a matrix. If \code{x} is a matrix, #' then each column of \code{k} corresponds to a column of \code{x}. #' \code{k} has \code{p} rows.} #' } #' #' @examples #' ## Estimate the coefficients of an autoregressive process given by #' ## x(n) = 0.1x(n-1) - 0.8x(n-2) - 0.27x(n-3) + w(n). #' a <- c(1, 0.1, -0.8, -0.27) #' v <- 0.4 #' w <- sqrt(v) * rnorm(15000) #' x <- filter(1, a, w) #' xc <- xcorr(x, scale = 'biased') #' acf <- xc$R[-which(xc$lags < 0)] #' lev <- levinson(acf, length(a) - 1) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Peter V. Lanspeary, \email{pvl@@mecheng.adelaide.edu.au}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references [1] Steven M. Kay and Stanley Lawrence Marple Jr. (1981). #' Spectrum analysis – a modern perspective. Proceedings of the IEEE, Vol 69, #' 1380-1419.\cr #' [2] \url{https://en.wikipedia.org/wiki/Levinson_recursion} #' #' @export levinson <- function(acf, p = NROW(acf)) { # check parameters if (!(is.vector(acf) || is.matrix(acf))) { stop("acf must be a vector or matrix") } if (is.vector(acf)) { vec <- TRUE acf <- as.matrix(acf, ncol = 1) } else { vec <- FALSE } nr <- nrow(acf) nc <- ncol(acf) if (nr < 2) { stop("acf must be a vector or matrix of length > 1") } if (!isScalar(p) || !isWhole(p) || !is.numeric(p) || p <= 0.5) { stop("p must be a positive integer > 0") } # end of parameter checking aggr_a <- aggr_v <- aggr_k <- NULL for (icol in seq_len(nc)) { ref <- rep(0L, p) g <- -acf[2] / acf[1] a <- g v <- Re((1 - g * Conj(g)) * acf[1]) ref[1] <- g if (p > 1) { for (t in 2:p) { g <- as.vector(- (acf[t + 1] + a %*% acf[seq(t, 2, -1)]) / v) a <- c((a + g * Conj(a[seq(t - 1, 1, -1)])), g) v <- v * (1 - Re(g * Conj(g))) ref[t] <- g } } aggr_a <- rbind(aggr_a, c(1, a)) aggr_v <- c(aggr_v, v) aggr_k <- rbind(aggr_k, ref) } if (vec) { rv <- list(a = as.vector(aggr_a), e = aggr_v, k = as.vector(aggr_k)) } else { rv <- list(a = aggr_a, e = aggr_v, k = t(aggr_k)) } rv } gsignal/R/upsample.R0000644000176200001440000000507614420222025014051 0ustar liggesusers# upsample.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2007 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201121 GvB setup for gsignal v0.1.0 # 20220328 GvB copy dimnaes of x to output object #------------------------------------------------------------------------------ #' Increase sample rate #' #' Upsample a signal by an integer factor. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param n upsampling factor, specified as a positive integer. The signal is #' upsampled by inserting \code{n - 1} zeros between samples. #' @param phase offset, specified as a positive integer from \code{0} to \code{n #' - 1}. Default: 0. #' #' @return Upsampled signal, returned as a vector or matrix. #' #' @examples #' x <- seq_len(4) #' u <- upsample(x, 3) #' u <- upsample(x, 3, 2) #' #' x <- matrix(seq_len(6), 3, byrow = TRUE) #' u <- upsample(x, 3) #' #' @seealso \code{\link{downsample}}, \code{\link{interp}}, #' \code{\link{decimate}}, \code{\link{resample}} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export upsample <- function(x, n, phase = 0) { if (is.vector(x)) { ns <- 1 lx <- length(x) x <- matrix(x, ncol = 1) vec <- TRUE } else if (is.matrix(x)) { ns <- ncol(x) lx <- nrow(x) vec <- FALSE } else { stop("x must be a numeric vector or matrix") } if (!(isPosscal(n) && isWhole(n))) { stop("n must be a positive integer") } if (!(isPosscal(phase) && isWhole(phase)) || phase > n - 1) { stop("phase must be a positive integer between 0 and n - 1") } y <- matrix(0, n * lx, ns) y[seq(phase + 1, length(y), n)] <- x if (vec) { y <- as.vector(y) } dimnames(y) <- dimnames(x) y } gsignal/R/convmtx.R0000644000176200001440000000460114420222025013712 0ustar liggesusers# convmtx.R # Copyright (C) 2020 Geert van Boxtel # Octave version Copyright (C) 2003 David Bateman # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200212 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Convolution matrix #' #' Returns the convolution matrix for a filter kernel. #' #' Computing a convolution using \code{conv} when the signals are vectors is #' generally more efficient than using \code{convmtx}. For multichannel signals, #' however, when a large number of vectors are to be convolved with the same #' filter kernel, \code{convmtx} might be more efficient. #' #' The code \code{cm <- convmtx(h, n)} computes the convolution matrix of the #' filter kernel \code{h} with a vector of length \code{n}. Then, \code{cm %*% #' x} gives the convolution of \code{h} and \code{x}. #' #' @param h Input, coerced to a vector, representing the filter kernel #' @param n Length of vector(s) that \code{h} is to be convolved with. #' #' @return Convolution matrix of input \code{h} for a vector of length \code{n}. #' If \code{h} is a vector of length \code{m}, then the convolution matrix has #' \code{m + n - 1} rows and \code{n} columns. #' #' @examples #' N <- 1000 #' a <- runif(N) #' b <- runif(N) #' cm <- convmtx(b, N) #' d <- cm %*% a #' #' cref = conv(a, b) #' all.equal(max(d - cref), 0) #' #' @seealso \code{\link{conv}} #' #' @author David Bateman \email{adb014@@gmail.com}.\cr Conversion to R by Geert #' van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export convmtx <- function(h, n) { h <- as.vector(h) if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer.") } y <- pracma::Toeplitz(c(h, rep(0L, (n - 1))), c(h[1], rep(0L, (n - 1)))) y } gsignal/R/fftshift.R0000644000176200001440000000721214420222025014032 0ustar liggesusers# fftshift.R # Copyright (C) 2020 Geert van Boxtel # Original Octave version: # Author: Vincent Cautaerts # Created: July 1997 # Adapted-By: jwe # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200823 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Zero-frequency shift #' #' Perform a shift in order to move the frequency 0 to the center of the input. #' #' If \code{x} is a vector of \code{N} elements corresponding to \code{N} time #' samples spaced by \code{dt}, then \code{fftshift(x)} corresponds to #' frequencies \code{f = c(-seq(ceiling((N-1)/2), 1, -1), 0, (1:floor((N-1)/2))) #' * df}, where \code{df = 1 / (N * dt)}. In other words, the left and right #' halves of \code{x} are swapped. #' #' If \code{x} is a matrix, then \code{fftshift} operates on the rows or columns #' of \code{x}, according to the \code{MARGIN} argument, i.e. it swaps the the #' upper and lower halves of the matrix \code{(MARGIN = 1)}, or the left and #' right halves of the matrix \code{(MARGIN = 2)}. Specifying \code{MARGIN = #' c(1, 2)} swaps along both dimensions, i.e., swaps the first quadrant with the #' fourth, and the second with the third. #' #' @param x input data, specified as a vector or matrix. #' @param MARGIN dimension to operate along, 1 = row, 2 = columns (default). #' Specifying \code{MARGIN = c(1, 2)} centers along both rows and columns. #' Ignored when \code{x} is a vector. #' #' @return vector or matrix with centered frequency. #' #' @examples #' Xeven <- 1:6 #' ev <- fftshift(Xeven) # returns 4 5 6 1 2 3 #' #' Xodd <- 1:7 #' odd <- fftshift(Xodd) # returns 5 6 7 1 2 3 4 #' #' fs <- 100 # sampling frequency #' t <- seq(0, 10 - 1/fs, 1/fs) # time vector #' S <- cos(2 * pi * 15 * t) #' n <- length(S) #' X <- fft(S) #' f <- (0:(n - 1)) * (fs / n); # frequency range #' power <- abs(X)^2 / n # power #' plot(f, power, type="l") #' Y <- fftshift(X) #' fsh <- ((-n/2):(n/2-1)) * (fs / n) # zero-centered frequency range #' powersh <- abs(Y)^2 / n # zero-centered power #' plot(fsh, powersh, type = "l") #' #' @seealso \code{ifftshift} #' #' @author Vincent Cautaerts, \email{vincent@@comf5.comm.eng.osaka-u.ac.jp},\cr #' adapted by John W. Eaton.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export fftshift <- function(x, MARGIN = 2) { y <- x if (is.vector(y)) { xl <- length(y) if (xl > 1) { xx <- ceiling(xl / 2) y <- x[c((xx + 1):xl, 1:xx)] } } else if (is.matrix(y)) { if (! (1 %in% MARGIN || 2 %in% MARGIN)) { stop("MARGIN must be 1, 2, or both") } if (1 %in% MARGIN) { nr <- NROW(y) if (nr > 1) { xx <- ceiling(nr / 2) y <- y[c((xx + 1):nr, 1:xx), ] } } if (2 %in% MARGIN) { nc <- NCOL(y) if (nc > 1) { xx <- ceiling(nc / 2) y <- y[, c((xx + 1):nc, 1:xx)] } } } else { stop("x must be a vector or matrix") } y } gsignal/R/firls.R0000644000176200001440000000733114473631351013354 0ustar liggesusers# firls.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2006 Quentin Spencer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200706 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Least-squares linear-phase FIR filter design #' #' Produce a linear phase filter such that the integral of the weighted mean #' squared error in the specified bands is minimized. #' #' @param n filter order (1 less than the length of the filter). Must be even. #' If odd, it is incremented by one. #' @param f vector of frequency points in the range from 0 to 1, where 1 #' corresponds to the Nyquist frequency. Each band is specified by two #' frequencies, so the vector must have an even length. . #' @param a vector of the same length as \code{f} containing the desired #' amplitude at each of the points specified in \code{f}. #' @param w weighting function that contains one value for each band that #' weights the mean squared error in that band. \code{w} must be half the #' length of \code{f}. #' #' @return The FIR filter coefficients, a vector of length \code{n + 1}, of #' class \code{Ma}. #' #' @examples #' freqz(firls(255, c(0, 0.25, 0.3, 1), c(1, 1, 0, 0))) #' #' @seealso \code{\link{Ma}}, \code{\link{filter}}, \code{\link{fftfilt}}, #' \code{\link{fir1}} #' #' @author Quentin Spencer, \email{qspencer@@ieee.org}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export firls <- function(n, f, a, w = rep(1L, length(a) / 2)) { # filter length must be a scalar > 0 if (!isPosscal(n) || !isWhole(n) || n <= 0) { stop("n must be an integer > 0") } # f, a, w must be real-valued vectors if (!is.vector(f) || !is.numeric(f) || !is.vector(a) || !is.numeric(a) || !is.vector(w) || !is.numeric(w)) { stop("f, a, and w must be real-valued vectors") } # test for lengths of f, a, and w if (length(f) != length(a)) { stop("f and a must have equal lengths") } else if (2 * length(w) != length(a)) { stop("w must contain one weight per band") } n <- n + n %% 2 M <- n / 2 ww <- kronecker(w, c(-1, 1)) omega <- f * pi i1 <- seq(1, length(omega), 2) i2 <- seq(2, length(omega), 2) ## Generate the matrix Q (see [1]) cos_ints <- rbind(omega, sin((1:n) %o% omega)) q <- c(1, 1 / (1:n)) * (cos_ints %*% ww) Q <- stats::toeplitz(q[1:(M + 1)]) + pracma::hankel(q[1:(M + 1)], q[(M + 1):length(q)]) ## Derive the vector b (see [1]) cos_ints2 <- rbind(omega[i1]^2 - omega[i2]^2, cos((1:M) %o% omega[i2]) - cos((1:M) %o% omega[i1])) / (c(2, 1:M) %o% (omega[i2] - omega[i1])) d <- as.vector(rbind(-w * a[i1], w * a[i2])) b <- c(1, 1 / (1:M)) * ((kronecker(cos_ints2, cbind(1, 1)) + cos_ints[1:(M + 1), ]) %*% d) ## Having computed the components Q and b of the matrix equation, ## solve for the filter coefficients. aa <- pracma::mldivide(Q, b, pinv = FALSE) laa <- length(aa) coef <- c(aa[seq(laa, 2, -1)], 2 * aa[1], aa[2:laa]) Ma(coef) } gsignal/R/idst.R0000644000176200001440000000500214420222025013153 0ustar liggesusers# idst.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Author: Paul Kienzle (2006) # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201016 GvB setup for gsignal v0.1.0 # 20210506 GvB use matrix() instead of as.matrix() #------------------------------------------------------------------------------ #' Inverse Discrete Sine Transform #' #' Compute the inverse discrete sine transform of a signal. #' #' The discrete sine transform (DST) is closely related to the discrete Fourier #' transform. but using a purely real matrix. It is equivalent to the imaginary #' parts of a DFT of roughly twice the length. #' #' @param x input discrete cosine transform, specified as a numeric vector or #' matrix. In case of a vector it represents a single signal; in case of a #' matrix each column is a signal. #' @param n transform length, specified as a positive integer scalar. Default: #' \code{NROW(x)}. #' #' @return Inverse discrete sine transform, returned as a vector or matrix. #' #' @examples #' x <- seq_len(100) + 50 * cos(seq_len(100) * 2 * pi / 40) #' X <- dst(x) #' xx <- idst(X) #' all.equal(x, xx) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{dst}} #' #' @export idst <- function(x, n = NROW(x)) { if (!(is.vector(x) || is.matrix(x)) || !(is.numeric(x) || is.complex(x))) { stop("x must be a numeric or complex vector or matrix") } else { realx <- is.numeric(x) } if (is.vector(x)) { vec <- TRUE x <- matrix(x, ncol = 1) } else { vec <- FALSE } nr <- nrow(x) if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer") } if (n != nr) { x <- postpad(x, n) } y <- dst(x, n) * 2 / (n + 1) if (realx) { y <- Re(y) } if (vec) { y <- as.vector(y) } y } gsignal/R/rectwin.R0000644000176200001440000000337714420222025013700 0ustar liggesusers# rectwin.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2007 Sylvain Pelissier # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191215 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Rectangular window #' #' Return the filter coefficients of a rectangular window of length \code{n}. #' #' The output of the rectwin function with input \code{n} can also be created #' using the \code{rep} function: w <- rep(1L, n) #' #' @param n Window length, specified as a positive integer. #' #' @return rectangular window, returned as a vector. #' #' @examples #' #' r <- rectwin(64) #' plot (r, type = "l", xlab = "Samples", ylab =" Amplitude", ylim = c(0, 1)) #' #' @seealso \code{\link{boxcar}} #' #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export rectwin <- function(n) { if (!isPosscal(n) || !isWhole(n) || n <= 0) stop("n must be an integer strictly positive") w <- rep(1L, n) w } gsignal/R/pburg.R0000644000176200001440000001113414420222025013332 0ustar liggesusers# pburg.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 2006 Peter V. Lanspeary # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201104 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Autoregressive PSD estimate - Burg's method #' #' Calculate Burg maximum-entropy power spectral density. #' #' @param x input data, specified as a numeric or complex vector or matrix. In #' case of a vector it represents a single signal; in case of a matrix each #' column is a signal. #' @param p model order; number of poles in the AR model or limit to the number #' of poles if a valid criterion is provided. Must be < length(x) - 2. #' @param criterion model-selection criterion. Limits the number of poles so #' that spurious poles are not added when the whitened data has no more #' information in it. Recognized values are: #' \describe{ #' \item{"AKICc"}{approximate corrected Kullback information criterion #' (recommended)} #' \item{"KIC"}{Kullback information criterion} #' \item{"AICc"}{corrected Akaike information criterion} #' \item{"AIC"}{Akaike information criterion} #' \item{"FPE"}{final prediction error} #' } #' The default is to NOT use a model-selection criterion (NULL) #' @param freq vector of frequencies at which power spectral density is #' calculated, or a scalar indicating the number of uniformly distributed #' frequency values at which spectral density is calculated. Default: 256. #' @param fs sampling frequency (Hz). Default: 1 #' @param range character string. one of: #' \describe{ #' \item{\code{"half"} or \code{"onesided"}}{frequency range of the spectrum #' is from zero up to but not including \code{fs / 2}. Power from negative #' frequencies is added to the positive side of the spectrum.} #' \item{\code{"whole"} or \code{"twosided"}}{frequency range of the spectrum #' is \code{-fs / 2} to \code{fs / 2}, with negative frequencies stored in #' "wrap around order" after the positive frequencies; e.g. frequencies for a #' 10-point \code{"twosided"} spectrum are 0 0.1 0.2 0.3 0.4 0.5 -0.4 -0.3 #' -0.2. -0.1.} #' \item{\code{"shift"} or \code{"centerdc"}}{same as \code{"whole"} but with #' the first half of the spectrum swapped with second half to put the #' zero-frequency value in the middle. If \code{freq} is a vector, #' \code{"shift"} is ignored.} #' } #' Default: If model coefficients \code{a} are real, the default range is #' \code{"half"}, otherwise the default range is \code{"whole"}. #' @param method method used to calculate the power spectral density, either #' \code{"fft"} (use the Fast Fourier Transform) or \code{"poly"} (calculate #' the power spectrum as a polynomial). This argument is ignored if the #' \code{freq} argument is a vector. The default is \code{"poly"} unless the #' \code{freq} argument is an integer power of 2. #' #' @return An object of class "ar_psd" , which is a list containing two #' elements, \code{freq} and \code{psd} containing the frequency values and #' the estimates of power-spectral density, respectively. #' #' @note This function is a wrapper for \code{arburg} and \code{ar_psd}. #' #' @examples #' A <- Arma(1, c(1, -2.7607, 3.8106, -2.6535, 0.9238)) #' y <- filter(A, 0.2 * rnorm(1024)) #' plot(pb <- pburg(y, 4)) #' #' @author Peter V. Lanspeary, \email{pvl@@mecheng.adelaide.edu.au}.\cr #' Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com} #' #' @seealso \code{\link{ar_psd}}, \code{\link{arburg}} #' #' @export pburg <- function(x, p, criterion = NULL, freq = 256, fs = 1, range = NULL, method = if (length(freq) == 1 && bitwAnd(freq, freq - 1) == 0) "fft" else "poly") { coefs <- arburg(x, p, criterion) if (is.null(range)) { range <- ifelse(is.numeric(coefs$a), "half", "whole") } rv <- ar_psd(coefs$a, coefs$e, freq, fs, range, method) rv } gsignal/R/zerocrossing.R0000644000176200001440000000515114420222025014744 0ustar liggesusers# zerocrossing.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2008 Carlo de Falco # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201128 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Zero Crossing #' #' Estimate zero crossing points of waveform. #' #' @param x the x-coordinates of points in the function. #' @param y the y-coordinates of points in the function. #' #' @return Zero-crossing points #' #' @examples #' x <- seq(0, 1, length.out = 100) #' y <- runif(100) - 0.5 #' x0 <- zerocrossing(x, y) #' plot(x, y, type ="l", xlab = "", ylab = "") #' points(x0, rep(0, length(x0)), col = "red") #' #' @author Carlo de Falco, \email{carlo.defalco@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export zerocrossing <- function(x, y) { if (!is.vector(x) || !is.vector(y) || !is.numeric(x) || !is.numeric(y)) { stop("x and y must be numeric vectors") } len <- length(x) if (length(y) != len) { stop("x and y must be vectors of the same length") } crossing_intervals <- (y[1:(len - 1)] * y[2:len] <= 0) left_ends <- (x[1:(len - 1)])[crossing_intervals] right_ends <- (x[2:len])[crossing_intervals] left_vals <- (y[1:(len - 1)])[crossing_intervals] right_vals <- (y[2:len])[crossing_intervals] mid_points <- (left_ends + right_ends) / 2 zero_intervals <- which(left_vals == right_vals) retval1 <- mid_points[zero_intervals] left_ends <- left_ends[!left_ends %in% zero_intervals] right_ends <- right_ends[!right_ends %in% zero_intervals] left_vals <- left_vals[!left_vals %in% zero_intervals] right_vals <- right_vals[!right_vals %in% zero_intervals] retval2 <- left_ends - (right_ends - left_ends) * left_vals / (right_vals - left_vals) retval <- union(retval1, retval2) retval } gsignal/R/tripulse.R0000644000176200001440000000626014420222025014066 0ustar liggesusers# tripuls.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2001 Paul Kienzle # Copyright (C) 2018-2019 Mike Miller # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191127 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Sampled aperiodic triangle #' #' Generate a triangular pulse over the interval \code{-w / 2} to \code{w / 2}, #' sampled at times \code{t}. #' #' \code{y <- tripuls(t)} returns a continuous, aperiodic, symmetric, #' unity-height triangular pulse at the times indicated in array \code{t}, #' centered about \code{t = 0} and with a default width of 1. #' #' \code{y <- tripuls(t, w)} generates a triangular pulse of width \code{w}. #' #' \code{y <- tripuls(t, w, skew)} generates a triangular pulse with skew #' \code{skew}, where \eqn{-1 \le skew \le 1}. When \code{skew} is 0, a #' symmetric triangular pulse is generated. #' #' @param t Sample times of triangle wave specified by a vector. #' @param w Width of the triangular pulse to be generated. Default: 1. #' @param skew Skew, a value between -1 and 1, indicating the relative placement #' of the peak within the width. -1 indicates that the peak should be at #' \code{-w / 2}, and 1 indicates that the peak should be at \code{w / 2}. #' Default: 0 (no skew). #' #' @return Triangular pulse, returned as a vector. #' #' @examples #' #' fs <- 10e3 #' t <- seq(-0.1, 0.1, 1/fs) #' w <- 40e-3 #' y <- tripuls(t, w) #' plot(t, y, type="l", xlab = "", ylab = "", #' main = "Symmetric triangular pulse") #' #' ## displace into paste and future #' tpast <- -45e-3 #' spast <- -0.45 #' ypast <- tripuls(t-tpast, w, spast) #' tfutr <- 60e-3 #' sfutr <- 1 #' yfutr <- tripuls(t-tfutr, w/2, sfutr) #' plot (t, y, type = "l", xlab = "", ylab = "", ylim = c(0, 1)) #' lines(t, ypast, col = "red") #' lines(t, yfutr, col = "blue") #' #' @author Paul Kienzle, Mike Miller.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export tripuls <- function(t, w = 1, skew = 0) { if (length(t) <= 0) stop("t must be a vector with length > 0") if (!isScalar(w)) stop("w must be a scalar") if (!isScalar(skew) || skew < -1 || skew > 1) stop("skew must be a scalar between 0 and 1") y <- rep(0L, length(t)) peak <- skew * w / 2 idx <- which((t >= -w / 2) & (t <= peak)) if (length(idx) > 0) { y[idx] <- (t[idx] + w / 2) / (peak + w / 2) } idx <- which((t > peak) & (t < w / 2)) if (length(idx) > 0) { y[idx] <- (t[idx] - w / 2) / (peak - w / 2) } y } gsignal/R/bilinear.R0000644000176200001440000001174114420222025014004 0ustar liggesusers# bilinear.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1999 Paul Kienzle # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200501 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Bilinear transformation #' #' Transform a s-plane (analog) filter specification into a z-plane (digital) #' specification. #' #' Given a piecewise flat filter design, you can transform it from the s-plane #' to the z-plane while maintaining the band edges by means of the bilinear #' transform. This maps the left hand side of the s-plane into the interior of #' the unit circle. The mapping is highly non-linear, so you must design your #' filter with band edges in the s-plane positioned at \eqn{2/T tan(wT / 2)} so #' that they will be positioned at \code{w} after the bilinear transform is #' complete. #' #' The bilinear transform is: #' \deqn{z = (1 + sT / 2) / (1 - sT / 2)} #' \deqn{s = (T / 2) (z - 1) / (z + 1)} #' #' Please note that a pole and a zero at the same place exactly cancel. This is #' significant since the bilinear transform creates numerous extra poles and #' zeros, most of which cancel. Those which do not cancel have a “fill-in” #' effect, extending the shorter of the sets to have the same number of as the #' longer of the sets of poles and zeros (or at least split the difference in #' the case of the band pass filter). There may be other opportunistic #' cancellations, but it will not check for them. #' #' Also note that any pole on the unit circle or beyond will result in an #' unstable filter. Because of cancellation, this will only happen if the number #' of poles is smaller than the number of zeros. The analytic design methods all #' yield more poles than zeros, so this will not be a problem. #' #' @param Sz In the generic case, a model to be transformed. In the default #' case, a vector containing the zeros in a pole-zero-gain model. #' @param Sp a vector containing the poles in a pole-zero-gain model. #' @param Sg a vector containing the gain in a pole-zero-gain model. #' @param T the sampling frequency represented in the z plane. Default: #' \code{2 * tan(1 / 2)}. #' @param ... arguments passed to the generic function. #' #' @return For the default case or for bilinear.Zpg, an object of class #' \code{'Zpg'}, containing the list elements: #' \describe{ #' \item{z}{complex vector of the zeros of the transformed model} #' \item{p}{complex vector of the poles of the transformed model} #' \item{g}{gain of the transformed model} #' } #' For bilinear.Arma, an object of class \code{'Arma'}, containing the list #' elements: #' \describe{ #' \item{b}{moving average (MA) polynomial coefficients} #' \item{a}{autoregressive (AR) polynomial coefficients} #' } #' #' @examples #' ## 6th order Bessel low-pass analog filter #' zp <- besselap(6) #' w <- seq(0, 4, length.out = 128) #' freqs(zp, w) #' zzp <- bilinear(zp) #' freqz(zzp) #' #' @references \url{https://en.wikipedia.org/wiki/Bilinear_transform} #' #' @author Paul Kienzle \email{pkienzle@@users.sf.net}. Conversion to R by Tom #' Short, adapted by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @rdname bilinear #' @export bilinear <- function(Sz, ...) UseMethod("bilinear") #' @rdname bilinear #' @export bilinear.Zpg <- function(Sz, T = 2 * tan(1 / 2), ...) bilinear(Sz$z, Sz$p, Sz$g, T) #' @rdname bilinear #' @export bilinear.Arma <- function(Sz, T = 2 * tan(1 / 2), ...) as.Arma(bilinear(as.Zpg(Sz), T)) #' @rdname bilinear #' @export bilinear.default <- function(Sz, Sp, Sg, T = 2 * tan(1 / 2), ...) { p <- length(Sp) z <- length(Sz) if (z > p || p == 0) stop("must have at least as many poles as zeros in s-plane") ## ---------------- ------------------------- ------------------------ ## Bilinear zero: (2+xT)/(2-xT) pole: (2+xT)/(2-xT) ## 2 z-1 pole: -1 zero: -1 ## S -> - --- gain: (2-xT)/T gain: (2-xT)/T ## T z+1 ## ---------------- ------------------------- ------------------------ Zg <- Re(Sg * prod((2 - Sz * T) / T) / prod((2 - Sp * T) / T)) Zp <- (2 + Sp * T) / (2 - Sp * T) if (is.null(Sz)) Zz <- rep.int(-1, length(Zp)) else { Zz <- (2 + Sz * T) / (2 - Sz * T) Zz <- c(Zz, rep.int(-1, p - z)) } Zpg(z = Zz, p = Zp, g = Zg) } gsignal/R/sos2tf.R0000644000176200001440000000567014420222025013443 0ustar liggesusers# sos2tf.R # Copyright (C) 2020 Geert van Boxtel # Original Octave version: # Copyright (C) 2005 Julius O. Smith III # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200330 GvB setup for gsignal v0.1.0 # 20200406 GvB validated # 20210306 GvB initialize a, b with sos[1, ] instead of 1 (bug in Octave # signal?) # 20210326 GvB return object of class 'Arma' # 20210506 GvB use matrix() instead of as.matrix() #------------------------------------------------------------------------------ #' Sos to transfer function #' #' Convert digital filter second-order section data to transfer function form. #' #' @param sos Second-order section representation, specified as an nrow-by-6 #' matrix, whose rows contain the numerator and denominator coefficients of #' the second-order sections:\cr \code{sos <- rbind(cbind(B1, A1), cbind(...), #' cbind(Bn, An))}, where \code{B1 <- c(b0, b1, b2)}, and \code{A1 <- c(a0, #' a1, a2)} for section 1, etc. The b0 entry must be nonzero for each section. #' @param g Overall gain factor that effectively scales the output \code{b} #' vector (or any one of the input \code{Bi} vectors). Default: 1. #' #' @return An object of class "Arma" with the following list elements: #' \describe{ #' \item{b}{moving average (MA) polynomial coefficients} #' \item{a}{autoregressive (AR) polynomial coefficients} #' } #' #' @seealso \code{\link{as.Arma}}, \code{\link{filter}} #' #' @examples #' sos <- rbind(c(1, 1, 1, 1, 0, -1), c(-2, 3, 1, 1, 10, 1)) #' ba <- sos2tf(sos) #' #' @author Julius O. Smith III, \email{jos@@ccrma.stanford.edu}.\cr #' Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com}. #' #' @export sos2tf <- function(sos, g = 1) { sos <- matrix(sos, ncol = 6) n <- nrow(sos) m <- ncol(sos) if (n <= 0) { stop("sos must have at least 1 row") } if (m != 6) { stop("sos must be a nrow-by-6 matrix") } b <- sos[1, 1:3] a <- sos[1, 4:6] if (n > 1) { for (i in 2:n) { b <- conv(b, sos[i, 1:3]) a <- conv(a, sos[i, 4:6]) } } nb <- length(b) while (nb > 0 && b[nb] == 0) { b <- b[1:(nb - 1)] nb <- length(b) } na <- length(a) while (na > 0 && a[na] == 0) { a <- a[1:(na - 1)] na <- length(a) } b <- b * prod(g) Arma(b = b, a = a) } gsignal/R/pad.R0000644000176200001440000001126214420222025012761 0ustar liggesusers# pad.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200121 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Pad data #' #' Pre- or postpad the data object \code{x} with the value \code{c} until it is #' of length \code{l}. #' #' @param x Vector or matrix to be padded #' @param l Length of output data along the padding dimension. If \code{length #' (x) > l}, elements from the beginning (\code{dimension = "pre"}) or the end #' (\code{direction = "post"}) of \code{x} are removed until a vector of #' length \code{l} is obtained. If \code{direction = "both"}, values are #' removed from both ends, and in case of an uneven length the smallest number #' of elements is removed from the beginning of vector. #' @param c Value to be used for the padding (scalar). Must be of the same type #' as the elements in \code{x}. Default: 0 #' @param MARGIN A vector giving the subscripts which the function will be #' applied over. E.g., for a matrix 1 indicates rows, 2 indicates columns, #' c(1, 2) indicates rows and columns. Where \code{x} has named dimnames, it #' can be a character vector selecting dimension names. If \code{MARGIN} is #' larger than the dimensions of \code{x}, the result will have \code{MARGIN} #' dimensions. Default: 2 (columns). #' @param direction Where to pad the array along each dimension. One of the #' following: #' \describe{ #' \item{"pre"}{Before the first element} #' \item{"post"}{After the last element} #' \item{"both"}{(default) Before the first and after the last element} #' } #' #' @return Padded data, returned as a vector or matrix. #' #' @examples #' v <- 1:24 #' res <- postpad(v, 30) #' res <- postpad(v, 20) #' res <- prepad(v, 30) #' res <- prepad(v, 20) #' #' m <- matrix(1:24, 4, 6) #' res <- postpad(m, 8, 100) #' res <- postpad(m, 8, 100, MARGIN = 1) #' res <- prepad(m, 8, 100) #' res <- prepad(m, 8, 100, MARGIN = 1) #' #' res <- postpad(m, 2) #' res <- postpad(m, 2, MARGIN = 1) #' res <- prepad(m, 2) #' res <- prepad(m, 2, MARGIN = 1) #' #' @author Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' @export pad <- function(x, l, c = 0, MARGIN = 2, direction = c("both", "pre", "post")) { vec <- FALSE if (is.vector(x)) vec <- TRUE if (vec) { x <- as.matrix(x) MARGIN <- 2 } xdim <- dim(x) ld <- length(xdim) if (!isPosscal(l) && !isWhole(l)) { stop("l must be a positive integer") } if (!isScalar(c)) { stop("c must be a scalar") } # handle character dimnames (adapted from apply source code) if (is.character(MARGIN)) { if (is.null(dnn <- names(dimnames(x)))) stop("'x' must have named dimnames") MARGIN <- match(MARGIN, dnn) if (anyNA(MARGIN)) stop("not all elements of 'MARGIN' are names of dimensions") } else if (!isPosscal(MARGIN) || MARGIN > ld || MARGIN < 1 || MARGIN > 2) { stop("'MARGIN' must be a positive integer and a valid margin (1 or 2)") } pd <- function(x, l, c, dir) { lx <- length(x) if (l == lx) { y <- x } else { if (dir == "pre") { if (l > lx) { y <- c(rep(c, l - lx), x) } else { y <- x[(lx - l + 1):lx] } } else if (dir == "post") { if (l > lx) { y <- c(x, rep(c, l - lx)) } else { y <- x[1:l] } } else if (dir == "both") { r1 <- floor(abs(lx - l) / 2) r2 <- ceiling(abs(lx - l) / 2) if (l > lx) { y <- c(rep(c, r1), x, rep(c, r2)) } else { y <- x[(r1 + 1):(lx - r2)] } } } y } direction <- match.arg(direction) y <- unlist(apply(X = x, MARGIN = MARGIN, FUN = pd, l = l, c = c, dir = direction)) if (MARGIN == 1) y <- t(y) if (vec) y <- as.vector(y) y } #' @rdname pad #' @export prepad <- function(x, l, c = 0, MARGIN = 2) { pad(x, l, c, MARGIN, direction = "pre") } #' @rdname pad #' @export postpad <- function(x, l, c = 0, MARGIN = 2) { pad(x, l, c, MARGIN, direction = "post") } gsignal/R/rceps.R0000644000176200001440000001314214420222025013330 0ustar liggesusers# rceps.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 1999 Paul Kienzle # Copyright (C) 2019 Mike Miller # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200827 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Real cepstrum #' #' Return the real cepstrum and minimum-phase reconstruction of a signal #' #' Cepstral analysis is a nonlinear signal processing technique that is applied #' most commonly in speech and image processing, or as a tool to #' investigate periodic structures within frequency spectra, for instance #' resulting from echos/reflections in the signal or to the occurrence of #' harmonic frequencies (partials, overtones). #' #' The cepstrum is used in many variants. Most important are the power cepstrum, #' the complex cepstrum, and real cepstrum. The function \code{rceps} implements #' the real cepstrum by computing the inverse of the log-transformed FFT while #' discarding phase, i.e., #' #' \deqn{rceps(x) <- ifft(log(Mag(fft(x))))} #' #' The real cepstrum is related to the power spectrum by the relation \eqn{pceps #' = 4 * rceps^2}. #' #' The function \code{rceps()} can also return a minimum-phase reconstruction of #' the original signal. The concept of minimum phase originates from filtering #' theory, and denotes a filter transfer function with all of its poles and #' zeroes in the Z-transform domain lie inside the unit circle on the complex #' plane. Such a transfer function represents a stable filter. #' #' A minimum-phase signal is a signal that has its energy concentrated #' near the front of the signal (near time 0). Such signals have many #' applications, e.g. in seismology and speech analysis. #' #' @param x input data, specified as a real vector. #' @param minphase logical (default: \code{FALSE}) indication whether to compute #' minimum-phase reconstructed signal #' #' @return If \code{minphase} equals \code{FALSE}, the real cepstrum is returned #' as a vector. If \code{minphase} equals \code{TRUE}, a list is returned #' containing two vectors; \code{y} containing the real cepstrum, and #' \code{ym} containing the minimum-phase reconstructed signal #' #' @examples #' ## Simulate a speech signal with a 70 Hz glottal wave #' f0 <- 70; fs = 10000 # 100 Hz fundamental, 10 kHz sampling rate #' a <- Re(poly(0.985 * exp(1i * pi * c(0.1, -0.1, 0.3, -0.3)))) #' s <- 0.05 * runif(1024) #' s[floor(seq(1, length(s), fs / f0))] <- 1 #' x <- filter(1, a, s) #' #' ## compute real cepstrum and min-phase of x #' cep <- rceps(x, TRUE) #' hx <- freqz(x, fs = fs) #' hxm <- freqz (cep$ym, fs = fs) #' len <- 1000 * trunc(min(length(x), length(cep$ym)) / 1000) #' time <- 0:(len-1) * 1000 / fs #' #' op <- par(mfcol = c(2, 2)) #' plot(time, x[1:len], type = "l", ylim = c(-10, 10), #' xlab = "Time (ms)", ylab = "Amplitude", #' main = "Original and reconstructed signals") #' lines(time, cep$ym[1:len], col = "red") #' legend("topright", legend = c("original", "reconstructed"), #' lty = 1, col = c(1, 2)) #' #' plot(time, cep$y[1:len], type = "l", #' xlab = "Quefrency (ms)", ylab = "Amplitude", #' main = "Real cepstrum") #' #' plot (hx$w, log(abs(hx$h)), type = "l", #' xlab = "Frequency (Hz)", ylab = "Magnitude", #' main = "Magnitudes are identical") #' lines(hxm$w, log(abs(hxm$h)), col = "red") #' legend("topright", legend = c("original", "reconstructed"), #' lty = 1, col = c(1, 2)) #' #' phx <- unwrap(Arg(hx$h)) #' phym <- unwrap(Arg(hxm$h)) #' range <- c(round(min(phx, phym)), round(max(phx, phym))) #' plot (hx$w, phx, type = "l", ylim = range, #' xlab = "Frequency (Hz)", ylab = "Phase", #' main = "Unwrapped phase") #' lines(hxm$w, phym, col = "red") #' legend("bottomright", legend = c("original", "reconstructed"), #' lty = 1, col = c(1, 2)) #' par(op) #' #' ## confirm the magnitude spectrum is identical in the signal #' ## and the reconstruction and that there are peaks in the #' ## cepstrum at 14 ms intervals corresponding to an F0 of 70 Hz. #' #' @references \url{https://en.wikipedia.org/wiki/Minimum_phase} #' #' @seealso \code{\link{cceps}} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Mike Miller.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export rceps <- function(x, minphase = FALSE) { if (!is.vector(x) || !is.numeric(x)) { stop("x must be a numeric vector") } if (!(is.logical(minphase) && length(minphase) == 1)) { stop("minphase must be a logical value (TRUE or FALSE)") } X <- abs(stats::fft(x)) if (min(X) == 0) { stop("signal has Fourier coefficients equal to 0") } y <- Re(ifft(log(X))) if (minphase) { n <- length(x) if (n %% 2 == 1) { ym <- c(y[1], 2 * y[2:(trunc(n / 2) + 1)], rep(0, trunc(n / 2))) } else { ym <- c(y[1], 2 * y[2:(n / 2)], y[n / 2 + 1], rep(0, n / 2 - 1)) } ym <- Re(ifft(exp(stats::fft(ym)))) } if (minphase) { rv <- list(y = y, ym = ym) } else { rv <- y } rv } gsignal/R/zplane.R0000644000176200001440000000651714420222025013515 0ustar liggesusers# zplane.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 1999, 2001 Paul Kienzle # Copyright (C) 2004 Stefan van der Walt # Copyright (C) 2019 Mike Miller # R signal version: # Copyright (C) 2006 EPRI Solutions, Inc. # by Tom Short, tshort@eprisolutions.com # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200425 GvB setup for gsignal v0.1.0 # 20201214 GvB changes to S3 setup: do them all via as.Zpg #------------------------------------------------------------------------------ #' Zero-pole plot #' #' Plot the poles and zeros of a filter or model on the complex Z-plane #' #' Poles are marked with an \code{x}, and zeros are marked with an \code{o}. #' #' @note When results of \code{zplane} are printed, \code{plot} will be called. #' As with lattice plots, automatic printing does not work inside loops and #' function calls, so explicit calls to print or plot are needed there. #' #' @param filt for the default case, the moving-average coefficients of an ARMA #' model or filter. Generically, \code{filt} specifies an arbitrary model or #' filter operation. #' @param a the autoregressive (recursive) coefficients of an ARMA filter. #' @param ... additional arguments are passed through to plot. #' #' @return No value is returned. #' #' @examples #' ## elliptic low-pass filter #' elp <- ellip(4, 0.5, 20, 0.4) #' zplane(elp) #' #' @references \url{https://en.wikipedia.org/wiki/Pole-zero_plot} #' #' @seealso \code{\link{freqz}} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Stefan van der Walt \email{stefan@@sun.ac.za},\cr #' Mike Miller.\cr #' Conversion to R by Tom Short,\cr #' adapted by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com} #' #' @rdname zplane #' @export zplane <- function(filt, ...) UseMethod("zplane") #' @rdname zplane #' @export zplane.Arma <- function(filt, ...) # IIR zplane(as.Zpg(filt), ...) #' @rdname zplane #' @export zplane.Ma <- function(filt, ...) # FIR zplane(as.Zpg(filt), ...) #' @rdname zplane #' @export zplane.Sos <- function(filt, ...) zplane(as.Zpg(filt), ...) #' @rdname zplane #' @export zplane.Zpg <- function(filt, ...) { x <- filt r <- exp(2i * pi * (0:100) / 100) xlim <- range(c(-1.1, 1.1, Re(x$p), Re(x$z))) ylim <- range(c(-1.1, 1.1, Im(x$p), Im(x$z))) graphics::plot(Re(r), Im(r), col = "red", xlab = "", ylab = "", xlim = xlim, ylim = ylim, type = "l", asp = 1, ...) graphics::points(Re(x$p), Im(x$p), pch = 4) graphics::points(Re(x$z), Im(x$z), pch = 1) } #' @rdname zplane #' @export zplane.default <- function(filt, a, ...) { zplane(Zpg(pracma::roots(as.numeric(filt)), pracma::roots(as.numeric(a)), 1), ...) } gsignal/R/sos2zp.R0000644000176200001440000000571014420222025013456 0ustar liggesusers# sos2zp.R # Copyright (C) 2020 Geert van Boxtel # Original Octave version: # Copyright (C) 2005 Julius O. Smith III # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200330 GvB setup for gsignal v0.1.0 # 20200405 GvB replaced roots() by pracma::roots() # 20200406 GvB validated # 20210326 GvB return object of class 'Zpg' # 20210506 GvB use matrix() instead of as.matrix(), sort output #------------------------------------------------------------------------------ #' Sos to zero-pole-gain #' #' Convert digital filter second-order section data to zero-pole-gain form. #' #' @param sos Second-order section representation, specified as an nrow-by-6 #' matrix, whose rows contain the numerator and denominator coefficients of #' the second-order sections:\cr \code{sos <- rbind(cbind(B1, A1), cbind(...), #' cbind(Bn, An))}, where \code{B1 <- c(b0, b1, b2)}, and \code{A1 <- c(a0, #' a1, a2)} for section 1, etc. The b0 entry must be nonzero for each section. #' @param g Overall gain factor that effectively scales the output \code{b} #' vector (or any one of the input \code{B_i} vectors). Default: 1. #' #'@return A list of class "Zpg" with the following list elements: #' \describe{ #' \item{z}{complex vector of the zeros of the model (roots of \code{B(z)})} #' \item{p}{complex vector of the poles of the model (roots of \code{A(z)})} #' \item{k}{overall gain (\code{B(Inf)})} #' } #' #' @seealso \code{\link{filter}} #' #' @examples #' sos <- rbind(c(1, 0, 1, 1, 0, -0.81), c(1, 0, 0, 1, 0, 0.49)) #' zpk <- sos2zp(sos) #' #' @author Julius O. Smith III \email{jos@@ccrma.stanford.edu}.\cr #' Conversion to R by, Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com} #' #' @export sos2zp <- function(sos, g = 1) { sos <- matrix(sos, ncol = 6) n <- nrow(sos) m <- ncol(sos) if (m != 6) { stop("sos must be a nrow-by-6 matrix") } gains <- sos[, 1] # All b0 coeffs g <- prod(gains) * g # pole-zero gain if (g == 0) { stop("one or more section gains is zero") } sos[, 1:3] <- sos[, 1:3] / c(gains, gains, gains) z <- p <- rep(0L, 2 * n) for (i in seq_len(n)) { ndx <- (2 * i - 1):(2 * i) zi <- pracma::roots(sos[i, 1:3]) z[ndx] <- zi pi <- pracma::roots(sos[i, 4:6]) p[ndx] <- pi } Zpg(z = sort(z), p = sort(p), g = g) } gsignal/R/cmorwavf.R0000644000176200001440000001416714420222025014050 0ustar liggesusers# cmorwavf.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2007 Sylvain Pelissier # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191122 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Complex Morlet Wavelet #' #' Compute the complex Morlet wavelet on a grid. #' #' The Morlet (or Gabor) wavelet is a wavelet composed of a complex exponential #' (carrier) multiplied by a Gaussian window (envelope). The wavelet exists as a #' complex version or a purely real-valued version. Some distinguish between the #' "real Morlet" versus the "complex Morlet". Others consider the complex #' version to be the "Gabor wavelet", while the real-valued version is the #' "Morlet wavelet". This function returns the complex Morlet wavelet, with #' time-decay parameter \code{fb}, and center frequency \code{fc}. The general #' expression for the complex Morlet wavelet is #' \if{latex}{ #' \deqn{\Psi(x) = ((\pi fb)^{-0.5}) \cdot e^{(2 \pi i fc x)} \cdot e^{-(x^2) #' / fb}} #' } #' \if{html}{\preformatted{ #' Psi(x) = ((pi * fb)^-0.5) * exp(2 * pi * i * fc * x) * exp(-(x^2) / fb) #' }} #' #' \code{x} is evaluated on an \code{n}-point regular grid in the interval (lb, #' ub). #' #' \code{fb} controls the decay in the time domain and the corresponding energy #' spread (bandwidth) in the frequency domain. #' \code{fb} is the inverse of the variance in the frequency domain. Increasing #' \code{fb} makes the wavelet energy more concentrated around the center #' frequency and results in slower decay of the wavelet in the time domain. #' Decreasing \code{fb} results in faster decay of the wavelet in the time #' domain and less energy spread in the frequency domain. The value of \code{fb} #' does not affect the center frequency. When converting from scale to #' frequency, only the center frequency affects the frequency values. The energy #' spread or bandwidth parameter affects how localized the wavelet is in the #' frequency domain. See the examples. #' #' @param lb,ub Lower and upper bounds of the interval to evaluate the complex #' Morlet waveform on. Default: -8 to 8. #' @param n Number of points on the grid between \code{lb} and \code{ub} (length #' of the wavelet). Default: 1000. #' @param fb Time-decay parameter of the wavelet (bandwidth in the frequency #' domain). Must be a positive scalar. Default: 5. #' @param fc Center frequency of the wavelet. Must be a positive scalar. #' Default: 1. #' #' @return A list containing 2 variables; \code{x}, the grid on which the #' complex Morlet wavelet was evaluated, and \code{psi} (\eqn{\Psi}), the #' evaluated wavelet on the grid \code{x}. #' #' @examples #' #' ## Construct a complex-valued Morlet wavelet with a bandwidth parameter #' ## of 1.5 and a center frequency of 1. Set the effective support to [-8,8] #' ## and the length of the wavelet to 1000. #' cmw <- cmorwavf(-8, 8, 1000, 1.5, 1) #' #' # Plot the real and imaginary parts of the wavelet. #' op <- par(mfrow = c(2, 1)) #' plot(cmw$x, Re(cmw$psi), type = "l", main = "Real Part") #' plot(cmw$x, Im(cmw$psi), type = "l", main = "Imaginary Part") #' par(op) #' #' ## This example shows how the complex Morlet wavelet shape in the frequency #' ## domain is affected by the value of the bandwidth parameter (fb). Both #' ## wavelets have a center frequency of 1. One wavelet has an fb value of #' ## 0.5 and the other wavelet has a value of 8. #' #' op <- par(mfrow = c(2,1)) #' cmw1 <- cmorwavf(fb = 0.5) #' cmw2 <- cmorwavf(fb = 8) #' #' # time domain plot #' plot(cmw1$x, Re(cmw1$psi), type = "l", xlab = "Time", ylab = "", #' main = "Time domain, Real part") #' lines(cmw2$x, Re(cmw2$psi), col = "red") #' legend("topright", legend = c("fb = 0.5", "fb = 8"), lty= 1, col = c(1,2)) #' #' # frequency domain plot #' f <- seq(-5, 5, .01) #' Fc <- 1 #' Fb1 <- 0.5 #' Fb2 <- 8 #' PSI1 <- exp(-pi^2 * Fb1 * (f-Fc)^2) #' PSI2 <- exp(-pi^2 * Fb2 * (f-Fc)^2) #' plot(f, PSI1, type="l", xlab = "Frequency", ylab = "", #' main = "Frequency domain") #' lines(f, PSI2, col = "red") #' legend("topright", legend = c("fb = 0.5", "fb = 8"), #' lty= 1, col = c(1,2)) #' par(op) #' #' ## The fb bandwidth parameter for the complex Morlet wavelet is the #' ## inverse of the variance in frequency. Therefore, increasing Fb results #' ## in a narrower concentration of energy around the center frequency. #' #' ## alternative to the above frequency plot: #' fs <- length(cmw1$x) / sum(abs(range(cmw1$x))) #' hz <- seq(0, fs/2, len=floor(length(cmw1$psi)/2)+1) #' PSI1 <- fft(cmw1$psi) / length(cmw1$psi) #' PSI2 <- fft(cmw2$psi) / length(cmw2$psi) #' plot(hz, 2 * abs(PSI1)[1:length(hz)], type="l", xlab = "Frequency", #' ylab = "", main = "Frequency domain", xlim=c(0,5)) #' lines(hz, 2 * abs(PSI2)[1:length(hz)], col = 2) #' legend("topright", legend = c("fb = 0.5", "fb = 8"), lty= 1, col = c(1,2)) #' #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export cmorwavf <- function(lb = -8, ub = 8, n = 1000, fb = 5, fc = 1) { if (!isPosscal(n) || !isWhole(n) || n <= 0) stop("n must be an integer strictly positive") if (!isPosscal(fb) || fb <= 0) stop("fb must be a positive scalar > 0") if (!isPosscal(fc) || fc <= 0) stop("fc must be a positive scalar > 0") x <- seq(lb, ub, length.out = n) psi <- ((pi * fb) ^ (-0.5)) * exp(2 * 1i * pi * fc * x) * exp(-x^2 / fb) list(x = x, psi = psi) } gsignal/R/peak2rms.R0000644000176200001440000000611314420222025013740 0ustar liggesusers# peak2rms.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2015 Andreas Weber # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200111 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Peak-magnitude-to-RMS ratio #' #' Compute the ratio of the largest absolute value to the root-mean-square (RMS) #' value of the object \code{x}. #' #' The input \code{x} can be a vector, a matrix or an array. If the input is a #' vector, a single value is returned representing the peak-magnitude-to-RMS #' ratio of the vector. If the input is a matrix or an array, a vector or an #' array of values is returned representing the peak-magnitude-to-RMS ratios of #' the dimensions of \code{x} indicated by the \code{MARGIN} argument. #' #' Support for complex valued input is provided. #' #' @param x the data, expected to be a vector, a matrix, an array. #' @param MARGIN a vector giving the subscripts which the function will be #' applied over. E.g., for a matrix 1 indicates rows, 2 indicates columns, #' c(1, 2) indicates rows and columns. Where \code{x} has named dimnames, it #' can be a character vector selecting dimension names. Default: 2 (usually #' columns) #' #' @return Vector or array of values containing the peak-magnitude-to-RMS ratios #' of the specified \code{MARGIN} of \code{x}. #' #' @examples #' ## numeric vector #' x <- c(1:5) #' p <- peak2rms(x) #' #' ## numeric matrix #' x <- matrix(c(1,2,3, 100, 150, 200, 1000, 1500, 2000), 3, 3) #' p <- peak2rms(x) #' p <- peak2rms(x, 1) #' #' ## numeric array #' x <- array(c(1, 1.5, 2, 100, 150, 200, 1000, 1500, 2000, #' 10000, 15000, 20000), c(2,3,2)) #' p <- peak2rms(x, 1) #' p <- peak2rms(x, 2) #' p <- peak2rms(x, 3) #' #' ## complex input #' x <- c(1+1i, 2+3i, 3+5i, 4+7i, 5+9i) #' p <- peak2rms(x) #' #' @author Andreas Weber, \email{octave@@tech-chat.de}.\cr #' Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export peak2rms <- function (x, MARGIN = 2) { if (!(is.numeric(x) || is.complex(x)) || !(is.vector(x) || is.matrix(x) || is.array(x))) { stop ("x must be a numeric or complex vector, matrix or array") } if(!isPosscal(MARGIN) || !isWhole(MARGIN)) { stop ("MARGIN must be a positive scalar") } if (is.vector(x)) { x <- as.matrix(x) MARGIN <- 2 } p2r <- function (a) max(abs(a)) / rmsq(a) y <- apply(x, MARGIN, p2r) y } gsignal/R/blackmanharris.R0000644000176200001440000000566114420222025015204 0ustar liggesusers# blackmanharris.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2007 Sylvain Pelissier # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191210 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Blackman-Harris window #' #' Return the filter coefficients of a minimum four-term Blackman-Harris window. #' #' The Blackman window is a member of the family of cosine sum windows. It is a #' generalization of the Hamming family, produced by adding more shifted sinc #' functions, meant to minimize side-lobe levels. #' #' @param n Window length, specified as a positive integer. #' @param method Character string. Window sampling method, specified as: #' \describe{ #' \item{"symmetric" (Default)}{Use this option when using windows for filter #' design.} #' \item{"periodic"}{This option is useful for spectral analysis because it #' enables a windowed signal to have the perfect periodic extension implicit #' in the discrete Fourier transform. When "periodic" is specified, the #' function computes a window of length \code{n + 1} and returns the first #' \code{n} points.} #' } #' #' @return Blackman-Harris window, returned as a vector. #' #' @examples #' #' b <- blackmanharris(64) #' plot (b, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' bs = blackmanharris(64,'symmetric') #' bp = blackmanharris(63,'periodic') #' plot (bs, type = "l", xlab = "Samples", ylab =" Amplitude") #' lines(bp, col="red") #' #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export blackmanharris <- function(n, method = c("symmetric", "periodic")) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) { stop("n must be an integer strictly positive") } method <- match.arg(method) if (method == "periodic") { N <- n } else if (method == "symmetric") { N <- n - 1 } else { stop("method must be either 'periodic' or 'symmetric'") } if (n == 1) { w <- 1 } else { a0 <- 0.35875 a1 <- 0.48829 a2 <- 0.14128 a3 <- 0.01168 k <- 0:(n - 1) w <- a0 - a1 * cos(2 * pi * k / N) + a2 * cos(4 * pi * k / N) - a3 * cos(6 * pi * k / N) } w } gsignal/R/ultrwin.R0000644000176200001440000001107014420222025013716 0ustar liggesusers# ultrwin.R # Copyright (C) 2019 Geert van Boxtel # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191215 Geert van Boxtel First version for v0.1.0 # 20210715 Geert van Boxtel Rewritten from scratch v0.3-3 #--------------------------------------------------------------------------------------------------------------------------------- #' Ultraspherical window #' #' Return the coefficients of an ultraspherical window #' #' @param n Window length, specified as a positive integer. #' @param mu parameter that controls the side-lobe roll-off ratio. Default: 3. #' @param xmu parameters that provides a trade-off between the ripple ratio and #' a width characteristic. Default: 1 #' #' @return ultraspherical window, returned as a vector. #' #' @examples #' #' w <- ultrwin(101, 3, 1) #' plot (w, type = "l", xlab = "Samples", ylab =" Amplitude") #' freqz(w) #' #' w2 <- ultrwin(101, 2, 1) #' f2 <- freqz(w2) #' w3 <- ultrwin(101, 3, 1) #' f3 <- freqz(w3) #' w4 <- ultrwin(101, 4, 1) #' f4 <- freqz(w4) #' op <- par(mfrow = c(2, 1)) #' plot(w2, type = "l", col = "black", xlab = "", ylab = "") #' lines(w3, col = "red") #' lines(w4, col = "blue") #' legend("topright", legend = 2:4, col = c("black", "red", "blue"), lty = 1) #' plot (f2$w, 20 * log10(abs(f2$h)), type = "l", col = "black", #' xlab = "", ylab = "", ylim = c(-100, 50)) #' lines(f3$w, 20 * log10(abs(f3$h)), col = "red") #' lines(f4$w, 20 * log10(abs(f4$h)), col = "blue") #' legend("topright", legend = 2:4, col = c("black", "red", "blue"), lty = 1) #' par(op) #' title(main = "Effect of increasing the values of mu (xmu = 1)") #' #' w1 <- ultrwin(101, 2, 1) #' f1 <- freqz(w1) #' w2 <- ultrwin(101, 2, 1.001) #' f2 <- freqz(w2) #' w3 <- ultrwin(101, 2, 1.002) #' f3 <- freqz(w3) #' op <- par(mfrow = c(2, 1)) #' plot(w1, type = "l", col = "black", xlab = "", ylab = "") #' lines(w2, col = "red") #' lines(w3, col = "blue") #' legend("topright", legend = 2:4, col = c("black", "red", "blue"), lty = 1) #' plot (f1$w, 20 * log10(abs(f1$h)), type = "l", col = "black", #' xlab = "", ylab = "", ylim = c(-100, 50)) #' lines(f2$w, 20 * log10(abs(f2$h)), col = "red") #' lines(f3$w, 20 * log10(abs(f3$h)), col = "blue") #' legend("topright", legend = c(1, 1.001, 1.002), #' col = c("black", "red", "blue"), lty = 1) #' par(op) #' title(main = "Effect of increasing the values of xmu (mu = 2)") #' #' @note The Dolph-Chebyshev and Saramaki windows are special cases of the #' Ultraspherical window, with mu set to 0 and 1, respectively. #' #' @author Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references [1] Bergen, S.W.A., and Antoniou, A. Design of Ultraspherical #' Window Functions with Prescribed Spectral Characteristics. EURASIP Journal #' on Applied Signal Processing 2004:13, 2053–2065. # #' @export ultrwin <- function (n, mu = 3, xmu = 1) { if (!isPosscal(n) || !isWhole(n) || n <= 0) stop ("n must be a positive integer") if (!isScalar(mu) || !is.double(mu)) stop ("mu must be a real scalar") if (!isScalar(xmu) || !is.double(xmu)) stop ("xmu must be a real scalar") if (n == 1) { w <- 1 } else { m <- (n - 1) / 2 if (n%%2) { a <- 0 } else { a <- 0.5 } b <- 1 - xmu^(-2) w <- rep(0, n) for (k in seq(0, m)) { nn = k - m #cat("k+1=",k+1,"nn=",nn,"nn-k=",n-k,"\n") w[k + 1] <- usc(nn, m, b, mu, xmu) w[n - k] <- w[k + 1] } } w <- w / usc(a, m, b, mu, xmu) w } # function to calculate the ultraspherical coefficients # not exported to the namespace usc <- function(n, m, b, mu, xmu) { sum <- 0 for (mm in seq(0, (m - abs(n)))) { sum <- sum + choose(mu + m - abs(n) - 1, m - abs(n) - mm) * choose(m + abs(n), mm) * b^(mm) } if (mu == 0) { cf <- xmu^(2 * m) / (m + abs(n)) * choose(mu + m + abs(n) - 1, m + abs(n) - 1) * sum } else { cf <- mu * xmu^(2 * m) / (m + abs(n)) * choose(mu + m + abs(n) - 1, m + abs(n) - 1) * sum } cf } gsignal/R/buttord.R0000644000176200001440000002065114420222025013702 0ustar liggesusers# buttord.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1999 Paul Kienzle # Copyright (C) 2018 Charles Praplan # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200513 Geert van Boxtel First version for v0.1.0 # 20200708 GvB renamed IIRfspec to FilterSpecs #------------------------------------------------------------------------------ #' Butterworth filter order and cutoff frequency #' #' Compute the minimum filter order of a Butterworth filter with the desired #' response characteristics. #' #' Deriving the order and cutoff is based on: #' \if{latex}{ #' \deqn{|H(W)|^{2} = 1/[1 + (W / Wc)^{(2N)}] = 10^{(-R / 10)}} #' } #' \if{html}{\preformatted{ #' 2 (2N) (-R / 10) #' |H(W)| = 1/[1 + (W / Wc) ] = 10 #' #' }} #' #' With some algebra, you can solve simultaneously for \code{Wc} and \code{N} #' given \code{Ws}, \code{Rs} and Wp,Rp. Rounding N to the next greater integer, #' one can recalculate the allowable range for \code{Wc} (filter characteristic #' touching the pass band edge or the stop band edge). #' #' For other types of filter, before making the above calculation, the #' requirements must be transformed to lowpass requirements. After the #' calculation, \code{Wc} must be transformed back to the original filter type. #' #' @param Wp,Ws pass-band and stop-band edges. For a low-pass or high-pass #' filter, \code{Wp} and \code{Ws} are scalars. For a band-pass or #' band-rejection filter, both are vectors of length 2. For a low-pass filter, #' \code{Wp < Ws}. For a high-pass filter, \code{Ws > Wp}. For a band-pass #' \code{(Ws[1] < Wp[1] < Wp[2] < Ws[2])} or band-reject \code{(Wp[1] < Ws[1] #' < Ws[2] < Wp[2])} filter design, \code{Wp} gives the edges of the pass #' band, and \code{Ws} gives the edges of the stop band. For digital filters, #' frequencies are normalized to [0, 1], corresponding to the range [0, fs/2]. #' In case of an analog filter, all frequencies are specified in radians per #' second. #' @param Rp allowable decibels of ripple in the pass band. #' @param Rs minimum attenuation in the stop band in dB. #' @param plane "z" for a digital filter or "s" for an analog filter. #' #' @return A list of class \code{\link{FilterSpecs}} with the following list #' elements: #' \describe{ #' \item{n}{filter order} #' \item{Wc}{cutoff frequency} #' \item{type}{filter type, normally one of "low", "high", "stop", or "pass".} #' } #' #' @examples #' ## low-pass 30 Hz filter #' fs <- 128 #' butspec <- buttord(30/(fs/2), 40/(fs/2), 0.5, 40) #' but <- butter(butspec) #' freqz(but, fs = fs) #' #' @author Paul Kienzle,\cr #' adapted by Charles Praplan.\cr #' Conversion to R by Tom Short,\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{butter}}, \code{\link{FilterSpecs}} #' #' @export buttord <- function(Wp, Ws, Rp, Rs, plane = c("z", "s")) { #input validation plane <- match.arg(plane) if (! (is.vector(Wp) && is.vector(Ws) && (length(Wp) == length(Ws)))) { stop("Wp and Ws must both be scalars or vectors of length 2") } if (! ((length(Wp) == 1) || (length(Wp) == 2))) { stop("Wp and Ws must both be scalars or vectors of length 2") } if (plane == "z" && !(is.numeric(Wp) && all(Wp >= 0) && all(Wp <= 1))) { stop("all elements of Wp must be in the range [0,1]") } if (plane == "z" && !(is.numeric(Ws) && all(Ws >= 0) && all(Ws <= 1))) { stop("all elements of Ws must be in the range [0,1]") } if (plane == "s" && !(is.numeric(Wp) && all(Wp >= 0))) { stop("all elements of Wp must be non-negative") } if (plane == "s" && !(is.numeric(Ws) && all(Ws >= 0))) { stop("all elements of Ws must be non-negative") } if ((length(Wp) == 2) && (Wp[2] <= Wp[1])) { stop("Wp[1] must be smaller than Wp[2]") } if ((length(Ws) == 2) && (Ws[2] <= Ws[1])) { stop("Ws[1] must be smaller than Ws[2]") } if ((length(Wp) == 2) && (all(Wp > Ws) || all(Ws > Wp))) { stop("Wp must be contained by Ws or Ws must be contained by Wp") } if (plane == "s") { # No prewarp in case of analog filter Wpw <- Wp Wsw <- Ws } else { ## sampling frequency of 2 Hz T <- 2 Wpw <- (2 / T) * tan(pi * Wp / T) # prewarp Wsw <- (2 / T) * tan(pi * Ws / T) # prewarp } ## pass/stop band to low pass filter transform: if (length(Wpw) == 2 && length(Wsw) == 2) { ## Band-pass filter if (Wpw[1] > Wsw[1]) { ## Modify band edges if not symmetrical. For a band-pass filter, ## the lower or upper stopband limit is moved, resulting in a smaller ## stopband than the caller requested. if (Wpw[1] * Wpw[2] < Wsw[1] * Wsw[2]) { Wsw[2] <- Wpw[1] * Wpw[2] / Wsw[1] } else { Wsw[1] <- Wpw[1] * Wpw[2] / Wsw[2] } w02 <- Wpw[1] * Wpw[2] wp <- Wpw[2] - Wpw[1] ws <- Wsw[2] - Wsw[1] ## Band-stop / band-reject / notch filter } else { ## Modify band edges if not symmetrical. For a band-stop filter, ## the lower or upper passband limit is moved, resulting in a smaller ## rejection band than the caller requested. if (Wpw[1] * Wpw[2] > Wsw[1] * Wsw[2]) { Wpw[2] <- Wsw[1] * Wsw[2] / Wpw[1] } else { Wpw[1] <- Wsw[1] * Wsw[2] / Wpw[2] } w02 <- Wpw[1] * Wpw[2] wp <- w02 / (Wpw[2] - Wpw[1]) ws <- w02 / (Wsw[2] - Wsw[1]) } ws <- ws / wp wp <- 1 ## High-pass filter } else if (Wpw > Wsw) { wp <- Wsw ws <- Wpw ## Low-pass filter } else { wp <- Wpw ws <- Wsw } ## compute minimum n which satisfies all band edge conditions qs <- log(10 ^ (Rs / 10) - 1) qp <- log(10 ^ (Rp / 10) - 1) n <- ceiling(max(0.5 * (qs - qp) / log(ws / wp))) ## compute -3dB cutoff given Wp, Rp and n if (length(Wpw) == 2 && length(Wsw) == 2) { ## Band-pass filter if (Wpw[1] > Wsw[1]) { type <- "pass" w_prime_p <- exp(log(Wpw) - qp / 2 / n) # same formula as for LP w_prime_s <- exp(log(Wsw) - qs / 2 / n) # " ## Band-stop / band-reject / notch filter } else { type <- "stop" w_prime_p <- exp(log(Wpw) + qp / 2 / n) # same formula as for HP w_prime_s <- exp(log(Wsw) + qs / 2 / n) # " } ## -3dB cutoff freq to match pass band w0 <- sqrt(prod(Wpw)) Q <- w0 / diff(Wpw) # BW at -Rp dB not at -3dB wc <- Wpw W_prime <- w_prime_p[1] / wc[1] # same with w_prime(2)/wc(2) wa <- abs(W_prime + sqrt(W_prime^2 + 4 * Q ^ 2)) / (2 * Q / w0) wb <- abs(W_prime - sqrt(W_prime^2 + 4 * Q ^ 2)) / (2 * Q / w0) Wcw_p <- c(wb, wa) ## -3dB cutoff freq to match stop band w0 <- sqrt(prod(Wsw)) Q <- w0 / diff(Wsw) # BW at -Rs dB not at -3dB wc <- Wsw W_prime <- w_prime_s[1] / wc[1] # same with w_prime(2)/wc(2) wa <- abs(W_prime + sqrt(W_prime^2 + 4 * Q ^ 2)) / (2 * Q / w0) wb <- abs(W_prime - sqrt(W_prime^2 + 4 * Q ^ 2)) / (2 * Q / w0) Wcw_s <- c(wb, wa) ## High-pass filter } else if (Wpw > Wsw) { type <- "high" ## -3dB cutoff freq to match pass band Wcw_p <- exp(log(Wpw) + qp / 2 / n) ## -3dB cutoff freq to match stop band Wcw_s <- exp(log(Wsw) + qs / 2 / n) ## Low-pass filter } else { type <- "low" ## -3dB cutoff freq to match pass band Wcw_p <- exp(log(Wpw) - qp / 2 / n) ## -3dB cutoff freq to match stop band Wcw_s <- exp(log(Wsw) - qs / 2 / n) } if (plane == "s") { # No prewarp in case of analog filter Wc_p <- Wcw_p Wc_s <- Wcw_s } else { # Inverse frequency warping for discrete-time filter Wc_p <- atan(Wcw_p * (T / 2)) * (T / pi) Wc_s <- atan(Wcw_s * (T / 2)) * (T / pi) } FilterSpecs(n = n, Wc = Wc_p, type = type, Wc_s = Wc_s, plane = plane) } gsignal/R/gmonopuls.R0000644000176200001440000000410214420222025014233 0ustar liggesusers# gmonopuls.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2007 Sylvain Pelissier # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191125 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Gaussian monopulse #' #' Returns samples of the unit-amplitude Gaussian monopulse. #' #' @param t Vector of time values at which the unit-amplitude Gaussian monopulse #' is calculated. #' @param fc Center frequency of the Gaussian monopulses, specified as a real #' positive scalar expressed in Hz. Default: 1000 #' #' @return Samples of the Gaussian monopulse, returned as a vector of unit #' amplitude at the times indicated by the time vector \code{t}. #' #' @examples #' fs <- 11025 # arbitrary sample rate #' t <- seq(-10, 10, 1/fs) #' y1 <- gmonopuls(t, 0.1) #' y2 <- gmonopuls(t, 0.2) #' plot(t, y1, type="l", xlab = "Time", ylab = "Amplitude") #' lines(t, y2, col = "red") #' legend("topright", legend = c("fc = 0.1", "fc = 0.2"), #' lty = 1, col = c(1, 2)) #' #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export gmonopuls <- function(t, fc = 1e3) { if (!isPosscal(fc)) stop("fc must be a non-negative real scalar") y <- 2 * sqrt(exp(1)) * pi * t * fc * exp(-2 * (pi * t * fc)^2) y } gsignal/R/fir1.R0000644000176200001440000001230214661365726013101 0ustar liggesusers# fir1.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2000 Paul Kienzle # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200704 Geert van Boxtel First version for v0.1.0 # 20240821 Geert van Boxtel Bugfix determining w_o #------------------------------------------------------------------------------ #' Window-based FIR filter design #' #' FIR filter coefficients for a filter with the given order and frequency #' cutoff. #' #' @param n filter order (1 less than the length of the filter). #' @param w band edges, strictly increasing vector in the range c(0, 1), where 1 #' is the Nyquist frequency. A scalar for highpass or lowpass filters, a #' vector pair for bandpass or bandstop, or a vector for an alternating #' pass/stop filter. #' @param type character specifying filter type, one of \code{"low"} for a #' low-pass filter, \code{"high"} for a high-pass filter, \code{"stop"} for a #' stop-band (band-reject) filter, \code{"pass"} for a pass-band filter, #' \code{"DC-0"} for a bandpass as the first band of a multiband filter, or #' \code{"DC-1"} for a bandstop as the first band of a multiband filter. #' Default: \code{"low"}. #' @param window smoothing window. The returned filter is the same shape as the #' smoothing window. Default: \code{hamming(n + 1)}. #' @param scale whether to normalize or not. Use \code{TRUE} (default) or #' \code{"scale"} to set the magnitude of the center of the first passband to #' 1, and \code{FALSE} or \code{"noscale"} to not normalize. #' #' @return The FIR filter coefficients, a vector of length \code{n + 1}, of #' class \code{Ma}. #' #' @references \url{https://en.wikipedia.org/wiki/Fir_filter} #' #' @examples #' freqz(fir1(40, 0.3)) #' freqz(fir1(10, c(0.3, 0.5), "stop")) #' freqz(fir1(10, c(0.3, 0.5), "pass")) #' #' @seealso \code{\link{Ma}}, \code{\link{filter}}, \code{\link{fftfilt}}, #' \code{\link{fir2}} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}, #' Conversion to R Tom Short,\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export fir1 <- function(n, w, type = c("low", "high", "stop", "pass", "DC-0", "DC-1"), window = hamming(n + 1), scale = TRUE) { type <- match.arg(type) if (!is.logical(scale)) { scale <- match.arg(scale, c("scale", "noscale")) scale <- scale == "scale" } if (is.function(window)) { window <- window(n + 1) } else if (is.character(window)) { window <- do.call(window, list(n + 1)) } ## Assign default window, filter type and scale. ## If single band edge, the first band defaults to a pass band to ## create a lowpass filter. If multiple band edges, the first band ## defaults to a stop band so that the two band case defaults to a ## band pass filter. Ick. ftype <- tolower(type) %in% c("low", "stop", "dc-1") ## build response function according to fir2 requirements bands <- length(w) + 1 f <- numeric(2 * bands) f[2 * bands] <- 1 f[seq(2, 2 * bands - 1, by = 2)] <- w f[seq(3, 2 * bands - 1, by = 2)] <- w m <- numeric(2 * bands) m[seq(1, 2 * bands, by = 2)] <- (1:bands - (1 - ftype)) %% 2 m[seq(2, 2 * bands, by = 2)] <- m[seq(1, 2 * bands, by = 2)] ## Increment the order if the final band is a pass band. Something ## about having a nyquist frequency of zero causing problems. if (n %% 2 == 1 && m[2 * bands] == 1) { warning("n must be even for highpass and bandstop filters. Incrementing.") n <- n + 1 if (is.vector(window) && is.double(window)) { ## End the window using interpolation M <- length(window) if (M == 1) window <- c(window, window) else window <- pracma::interp1(seq(0, 1, length = M), window, seq(0, 1, length = M + 1), if (M < 4) "linear" else "spline") } } ## compute the filter b <- fir2(n, f, m, 512, 2, window) ## normalize filter magnitude if (scale) { ## find the middle of the first band edge ## find the frequency of the normalizing gain if (m[1] == 1) { ## if the first band is a passband, use DC gain w_o <- 0 } else if (f[4] == 1) { ## for a highpass filter, ## use the gain at half the sample frequency w_o <- 1 } else{ ## otherwise, use the gain at the center ## frequency of the first passband w_o <- f[3] + (f[4] - f[3]) / 2 } ## compute |h(w_o)|^-1 renorm <- 1 / abs(pracma::polyval(as.vector(b), exp(-1i * pi * w_o))) ## normalize the filter b <- renorm * b } Ma(b) } gsignal/R/chirp.R0000644000176200001440000001120014420222025013312 0ustar liggesusers# chirp.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 1999-2000 Paul Kienzle , # Copyright (C) 2018-2019 Mike Miller # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191122 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Chirp signal #' #' Evaluate a chirp signal (frequency swept cosine wave). #' #' A chirp is a signal in which the frequency changes with time, commonly used #' in sonar, radar, and laser. The name is a reference to the chirping sound #' made by birds. #' #' The chirp can have one of three shapes: #' \describe{ #' \item{"linear"}{Specifies an instantaneous frequency sweep \eqn{f_i(t)} #' given by \eqn{f_i(t) = f_0 + \beta t}, where \eqn{\beta = (f_1 - f_0) / #' t_1} and the default value for \eqn{f_0} is 0. The coefficient \eqn{\beta} #' ensures that the desired frequency breakpoint \eqn{f_1} at time \eqn{t_1} #' is maintained.} #' \item{"quadratic"}{Specifies an instantaneous frequency sweep \eqn{f_i(t)} #' given by \eqn{f_i(t) = f_0 + \beta t^2}, where \eqn{\beta = (f_1 - f_0) / #' t_1^2} and the default value for \eqn{f_0} is 0. If \eqn{f_0 > f_1} #' (downsweep), the default shape is convex. If \eqn{f_0 < f_1} (upsweep), the #' default shape is concave.} #' \item{"logarithmic"}{Specifies an instantaneous frequency sweep #' \eqn{f_i(t)} given by \eqn{f_i(t) = f_0 \times \beta t}, where \eqn{\beta = #' \left( \frac {f_1}{f_0} \right) ^ \frac{1}{t1}} and the default value for #' \eqn{f_0} is \eqn{10^{-6}}.} #' } #' #' @param t Time array, specified as a vector. #' @param f0 Initial instantaneous frequency at time 0, specified as a positive #' scalar expressed in Hz. Default: 0 Hz for linear and quadratic shapes; 1e-6 #' for logarithmic shape. #' @param t1 Reference time, specified as a positive scalar expressed in #' seconds. Default: 1 sec. #' @param f1 Instantaneous frequency at time t1, specified as a positive scalar #' expressed in Hz. Default: 100 Hz. #' @param shape Sweep method, specified as \code{"linear"}, \code{"quadratic"}, #' or \code{"logarithmic"} (see Details). Default: \code{"linear"}. #' @param phase Initial phase, specified as a positive scalar expressed in #' degrees. Default: 0. #' @return Chirp signal, returned as an array of the same length as \code{t}. #' #' @examples #' # Shows linear sweep of 100 Hz/sec starting at zero for 5 sec #' # since the sample rate is 1000 Hz, this should be a diagonal #' # from bottom left to top right. #' t <- seq(0, 5, 0.001) #' y <- chirp (t) #' specgram (y, 256, 1000) #' #' # Shows a quadratic chirp of 400 Hz at t=0 and 100 Hz at t=10 #' # Time goes from -2 to 15 seconds. #' specgram(chirp(seq(-2, 15, by = 0.001), 400, 10, 100, "quadratic")) #' #' # Shows a logarithmic chirp of 200 Hz at t = 0 and 500 Hz at t = 2 #' # Time goes from 0 to 5 seconds at 8000 Hz. #' specgram(chirp(seq(0, 5, by = 1/8000), 200, 2, 500, "logarithmic"), #' fs = 8000) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Mike Miller.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export chirp <- function(t, f0, t1 = 1, f1 = 100, shape = c("linear", "quadratic", "logarithmic"), phase = 0) { shape <- match.arg(shape) # The default value for f0 depends on the shape if (missing(f0)) { if (shape == "logarithmic") { f0 <- 1e-6 } else { f0 <- 0 } } phase <- 2 * pi * phase / 360 if (shape == "linear") { a <- pi * (f1 - f0) / t1 b <- 2 * pi * f0 y <- cos(a * t^2 + b * t + phase) } else if (shape == "quadratic") { a <- (2 / 3 * pi * (f1 - f0) / t1 / t1) b <- 2 * pi * f0 y <- cos(a * t^3 + b * t + phase) } else if (shape == "logarithmic") { a <- 2 * pi * f0 * t1 / log(f1 / f0) x <- (f1 / f0) ^ (1 / t1) y <- cos(a * x^t + phase) } else { stop(paste("invalid frequency sweep shape", shape)) } y } gsignal/R/barthannwin.R0000644000176200001440000000456414420222025014537 0ustar liggesusers# barthannwin.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1995-2017 Andreas Weingessel # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191210 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Modified Bartlett-Hann window #' #' Return the filter coefficients of a modified Bartlett-Hann window. #' #' Like Bartlett, Hann, and Hamming windows, the Bartlett-Hann window has a #' mainlobe at the origin and asymptotically decaying sidelobes on both sides. #' It is a linear combination of weighted Bartlett and Hann windows with near #' sidelobes lower than both Bartlett and Hann and with far sidelobes lower than #' both Bartlett and Hamming windows. The mainlobe width of the modified #' Bartlett-Hann window is not increased relative to either Bartlett or Hann #' window mainlobes. #' #' @param n Window length, specified as a positive integer. #' #' @return Modified Bartlett-Hann window, returned as a vector. If you specify a #' one-point window \code{(n = 1)}, the value 1 is returned. #' #' @examples #' #' t <- barthannwin(64) #' plot (t, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' @author Andreas Weingessel, \email{Andreas.Weingessel@@ci.tuwien.ac.at}. #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{bartlett}}, \code{\link{hann}}, \code{\link{hamming}} # #' @export barthannwin <- function(n) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) { stop("n must be an integer strictly positive") } if (n == 1) { w <- 1 } else { N <- n - 1 m <- 0:N w <- 0.62 - 0.48 * abs(m / (n - 1) - 0.5) + 0.38 * cos(2 * pi * (m / (n - 1) - 0.5)) } w } gsignal/R/upsamplefill.R0000644000176200001440000000613714420222025014717 0ustar liggesusers# upsamplefill.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2013 Juan Pablo Carbajal # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201128 GvB setup for gsignal v0.1.0 # 20220328 GvB copy dimnames of x to output object #------------------------------------------------------------------------------ #' Upsample and Fill #' #' Upsample and fill with given values or copies of the vector elements. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param v vector of values to be placed between the elements of \code{x}. #' @param copy logical. If TRUE then \code{v} should be a scalar #' (\code{length(v) == 1)} and each value in \code{x} are repeated \code{v} #' times. If FALSE (default), the values in the vector \code{v} are placed #' between the elements of \code{x}. #' #' @return upsampled vector or matrix #' #' @examples #' u <- upsamplefill(diag(2), 2, TRUE) #' u <- upsamplefill(diag(2), rep(-1, 3)) #' #' @seealso \code{\link{upsample}} #' #' @author Juan Pablo Carbajal, \email{carbajal@@ifi.uzh.ch}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export upsamplefill <- function(x, v, copy = FALSE) { if (!is.numeric(x)) { stop("x must be a numeric vector or matrix") } if (is.vector(x)) { x <- matrix(x, ncol = 1) vec <- TRUE } else if (is.matrix(x)) { vec <- FALSE } else { stop("x must be a numeric vector or matrix") } nc <- ncol(x) nr <- nrow(x) if (!is.numeric(v) || !is.vector(v)) { stop("v must be a numeric vector") } if (!is.logical(copy)) { stop("copy must be a logical value TRUE or FALSE") } if (copy) { v <- v[1] if (v < 0) { stop("v must be a scalar value >= 0") } y <- pracma::kron(x, rep(1, v + 1)) } else { n <- length(v) + 1 N <- n * nr if (any(c(nr, nc) == 1)) { N <- N * nc idx <- seq(1, N, n) idx_c <- setdiff(seq(1, N), seq(1, N, n)) y <- rep(0, N) y[idx] <- x y[idx_c] <- pracma::repmat(v, 1, max(nr, nc)) } else { idx <- seq(1, N, n) idx_c <- setdiff(seq(1, N), seq(1, N, n)) y <- matrix(0, N, nc) y[idx, ] <- x y[idx_c, ] <- pracma::repmat(v, nr, nc) } } if (vec) { y <- as.vector(y) } dimnames(y) <- dimnames(x) y } gsignal/R/arburg.R0000644000176200001440000002145614420222025013505 0ustar liggesusers# arburg.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 2006 Peter V. Lanspeary # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201104 GvB setup for gsignal v0.1.0 # 20210507 GvB bugfix in inner product to compute v #------------------------------------------------------------------------------ #' Autoregressive model coefficients - Burg's method #' #' Calculate the coefficients of an autoregressive model using the whitening #' lattice-filter method of Burg (1968)[1]. #' #' The inverse of the autoregressive model is a moving-average filter which #' reduces \code{x} to white noise. The power spectrum of the AR model is an #' estimate of the maximum entropy power spectrum of the data. The function #' \code{ar_psd} calculates the power spectrum of the AR model. #' #' For data input \code{x(n)} and white noise \code{e(n)}, the autoregressive #' model is #' \if{latex}{ #' \deqn{x(n) = \sqrt{v} \cdot e(n) + \sum_{k=1}^{p+1} a(k) \cdot x(n-k)} #' } #' \if{html}{\preformatted{ #' p+1 #' x(n) = sqrt(v).e(n) + SUM a(k).x(n-k) #' k=1 #' }} #' #' \code{arburg} does not remove the mean from the data. You should remove the #' mean from the data if you want a power spectrum. A non-zero mean can produce #' large errors in a power-spectrum estimate. See \code{\link{detrend}} #' #' @note AIC, AICc, KIC and AKICc are based on information theory. They attempt #' to balance the complexity (or length) of the model against how well the #' model fits the data. AIC and KIC are biased estimates of the asymmetric #' and the symmetric Kullback-Leibler divergence, respectively. AICc and AKICc #' attempt to correct the bias. See reference [2]. #' #' @param x input data, specified as a numeric or complex vector or matrix. In #' case of a vector it represents a single signal; in case of a matrix each #' column is a signal. #' @param p model order; number of poles in the AR model or limit to the number #' of poles if a valid criterion is provided. Must be < length(x) - 2. #' @param criterion model-selection criterion. Limits the number of poles so #' that spurious poles are not added when the whitened data has no more #' information in it. Recognized values are: #' \describe{ #' \item{AKICc}{approximate corrected Kullback information criterion #' (recommended)} #' \item{KIC}{Kullback information criterion} #' \item{AICc}{corrected Akaike information criterion} #' \item{AIC}{Akaike information criterion} #' \item{FPE}{final prediction error} #' } #' The default is to NOT use a model-selection criterion (NULL) #' #' @return A \code{list} containing the following elements: #' \describe{ #' \item{a}{vector or matrix containing \code{(p+1)} autoregression #' coefficients. If \code{x} is a matrix, then each row of a corresponds to #' a column of \code{x}. \code{a} has \code{p + 1} columns.} #' \item{e}{white noise input variance, returned as a vector. If \code{x} is #' a matrix, then each element of e corresponds to a column of \code{x}.} #' \item{k}{Reflection coefficients defining the lattice-filter embodiment #' of the model returned as vector or a matrix. If \code{x} is a matrix, #' then each column of \code{k} corresponds to a column of \code{x}. #' \code{k} has \code{p} rows.} #' } #' #' @examples #' A <- Arma(1, c(1, -2.7607, 3.8106, -2.6535, 0.9238)) #' y <- filter(A, 0.2 * rnorm(1024)) #' coefs <- arburg(y, 4) #' #' @author Peter V. Lanspeary, \email{pvl@@mecheng.adelaide.edu.au}.\cr #' Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com}. #' #' @references [1] Burg, J.P. (1968) A new analysis technique for time series #' data, NATO advanced study Institute on Signal Processing with Emphasis on #' Underwater Acoustics, Enschede, Netherlands, Aug. 12-23, 1968.\cr #' [2] Seghouane, A. and Bekara, M. (2004). A small sample model selection #' criterion based on Kullback’s symmetric divergence. IEEE Trans. Sign. #' Proc., 52(12), pp 3314-3323, #' #' @seealso \code{\link{ar_psd}} #' #' @export arburg <- function(x, p, criterion = NULL) { # check parameters if (!(is.vector(x) || is.matrix(x)) || !is.numeric(x)) { stop("x must be a numeric or vector or matrix") } if (is.vector(x)) { vec <- TRUE x <- as.matrix(x, ncol = 1) } else { vec <- FALSE } nr <- nrow(x) nc <- ncol(x) if (!isScalar(p) || !isWhole(p) || !is.numeric(p) || p <= 0.5) { stop("p must be a positive integer") } if (p >= nr - 2) { stop(paste0("p must be less than the length of x (", nr, ") - 2")) } if (!is.null(criterion)) { criterion <- match.arg(criterion, c("AKICc", "KIC", "AICc", "AIC", "FPE")) # Set the model-selection-criterion flags. # is_akicc, isa_kic and is_corrected are short-circuit flags is_akicc <- criterion == "AKICc" # AKICc isa_kic <- is_akicc || criterion == "KIC" # KIC or AKICc is_corrected <- is_akicc || criterion == "AICc" # AKICc or AICc use_inf_crit <- is_corrected || isa_kic || criterion == "AIC" use_fpe <- criterion == "FPE" } else { use_inf_crit <- FALSE use_fpe <- FALSE } # end of parameter checking # loop over columns aggr_a <- aggr_v <- aggr_k <- NULL for (icol in seq_len(nc)) { # f(n) = forward prediction error # b(n) = backward prediction error # Storage of f(n) and b(n) is a little tricky. Because f(n) is always # combined with b(n-1), f(1) and b(N) are never used, and therefore are # not stored. Not storing unused data makes the calculation of the # reflection coefficient look much cleaner :) # N.B. {initial v} = {error for zero-order model} = # {zero-lag autocorrelation} = E(x*conj(x)) = x*x'/N # E = expectation operator f <- x[2:nr, icol] b <- x[1:(nr - 1), icol] v <- Re(x[, icol] %*% x[, icol]) / nr # new_crit/old_crit is the mode-selection criterion new_crit <- abs(v) old_crit <- 2 * new_crit for (ip in seq_len(p)) { # new reflection coeff = -2* E(f.conj(b)) / ( E(f^2)+E(b(^2) ) last_k <- as.vector(-2 * (b %*% f) / (f %*% f + b %*% b)) ## Levinson-Durbin recursion for residual new_v <- v * (1.0 - Re(last_k * Conj(last_k))) if (ip > 1) { # Apply the model-selection criterion and break out of loop if it # increases (rather than decreases). # Do it before we update the old model "a" and "v". # * Information Criterion (AKICc, KIC, AICc, AIC) if (use_inf_crit) { old_crit <- new_crit new_crit <- log(new_v) + as.integer(is_akicc) * ip / nr / (nr - ip) + (2 + as.integer(isa_kic) - as.integer(is_akicc) * (ip + 2) / nr) * (ip + 1) / (nr - as.integer(is_corrected) * (ip + 2)) if (new_crit > old_crit) { break } # (FPE) Final prediction error } else if (use_fpe) { old_crit <- new_crit new_crit <- new_v * (nr + ip + 1) / (nr - ip - 1) if (new_crit > old_crit) { break } } ## Update model "a" and "v". ## Use Levinson-Durbin recursion formula (for complex data). a <- c(prev_a + last_k * Conj(prev_a[seq(ip - 1, 1, -1)]), last_k) } else { # if(ip==1 ) a <- last_k k <- NULL } k <- c(k, last_k) v <- new_v if (ip < p) { prev_a <- a # calculate new prediction errors (by recursion): # f(p,n) = f(p-1,n) + k * b(p-1,n-1) n=2,3,...n # b(p,n) = b(p-1,n-1) + conj(k) * f(p-1,n) n=2,3,...n # remember f(p,1) is not stored, so don't calculate it; make f(p,2) # the first element in f. b(p,n) isn't calculated either. nn <- nr - ip new_f <- f[2:nn] + last_k * b[2:nn] b <- b[1:(nn - 1)] + Conj(last_k) * f[1:(nn - 1)] f <- new_f } } # loop over p aggr_a <- rbind(aggr_a, c(1, a)) aggr_v <- c(aggr_v, v) aggr_k <- rbind(aggr_k, k) } # loop over signals if (vec) { rv <- list(a = as.vector(aggr_a), e = aggr_v, k = as.vector(aggr_k)) } else { rv <- list(a = aggr_a, e = aggr_v, k = t(aggr_k)) } rv } gsignal/R/conv2.R0000644000176200001440000000500114420222025013236 0ustar liggesusers# conv2.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200227 GvB setup for gsignal v0.1.0 # 20200228 GvB coerce inputs a and to to matrices instead of checking #------------------------------------------------------------------------------ #' 2-D convolution #' #' Compute the two-dimensional convolution of two matrices. #' #' @param a,b Input matrices, coerced to numeric. #' @param shape Subsection of convolution, partially matched to: #' \describe{ #' \item{"full"}{Return the full convolution (default)} #' \item{"same"}{Return the central part of the convolution with the same size #' as A. The central part of the convolution begins at the indices #' \code{floor(c(nrow(b), ncol(b)) / 2 + 1)}} #' \item{"valid"}{Return only the parts which do not include zero-padded #' edges. The size of the result is \code{max(nrow(a) - nrow(a) + 1, 0)} by #' \code{max(ncol(A) - ncol(B) + 1, 0)}} #' } #' #' @return Convolution of input matrices, returned as a matrix. #' #' @examples #' a <- matrix(1:16, 4, 4) #' b <- matrix(1:9, 3,3) #' cnv <- conv2(a, b) #' cnv <- conv2(a, b, "same") #' cnv <- conv2(a, b, "valid") #' #' @seealso \code{\link{conv}}, \code{\link[stats]{convolve}} #' #' @author Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export conv2 <- function(a, b, shape = c("full", "same", "valid")) { a <- as.matrix(a) b <- as.matrix(b) shape <- match.arg(shape) if (length(a) < length(b)) { x <- a a <- b b <- x } y <- switch(shape, "full" = .Call("_gsignal_conv2df", PACKAGE = "gsignal", Re(a), Re(b)), "same" = .Call("_gsignal_conv2ds", PACKAGE = "gsignal", Re(a), Re(b)), "valid" = .Call("_gsignal_conv2dv", PACKAGE = "gsignal", Re(a), Re(b)) ) y } gsignal/R/detrend.R0000644000176200001440000000574114420222025013647 0ustar liggesusers# detrend.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 1995-2017 Kurt Hornik # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200104 GvB setup for gsignal v0.1.0 # 20211221 GvB corrected bug in return value when input is a vector # 20220328 GvB copy dimnames of x to output object #------------------------------------------------------------------------------ #' Remove Polynomial Trend #' #' \code{detrend} removes the polynomial trend of order \code{p} from the data #' \code{x}. #' #' @param x Input vector or matrix. If \code{x} is a matrix, the trend is #' removed from the columns. #' @param p Order of the polynomial. Default: 1. The order of the polynomial can #' also be given as a string, in which case \code{p} must be either #' \code{"constant"} (corresponds to \code{p = 0}) or \code{"linear"} #' (corresponds to \code{p = 1}). #' #' @return The detrended data, of same type and dimensions as \code{x} #' #' @examples #' t <- 0:20 #' x <- 3 * sin(t) + t #' y <- detrend(x) #' plot(t, x, type = "l", ylim = c(-5, 25), xlab = "", ylab = "") #' lines(t, y, col = "red") #' lines(t, x - y, lty = 2) #' legend('topleft', legend = c('Input Data', 'Detrended Data', 'Trend'), #' col = c(1, 2 ,1), lty = c(1, 1, 2)) #' #' @author Kurt Hornik, \email{Kurt.Hornik@@wu-wien.ac.at}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export detrend <- function(x, p = 1) { if (!is.numeric(x)) { stop("x must be numeric") } if (is.vector(x)) { x <- matrix(x, ncol = 1) vec <- TRUE } else if (is.matrix(x)) { vec <- FALSE } else { stop("x must be a numeric vector or matrix") } if (is.character(p)) { p <- match.arg(p, c("constant", "linear")) if (p == "constant") { p <- 0 } else if (p == "linear") { p <- 1 } else { stop(paste("input argument p must be 'constant',", "'linear', or a positive integer")) } } else { if (!isPosscal(p) || !isWhole(p)) { stop(paste("input argument p must be 'constant',", "'linear', or a positive integer")) } } r <- nrow(x) b <- (as.matrix(1:r) %*% matrix(1L, 1, (p + 1))) ^ (matrix(1L, r, 1) %*% as.matrix(t(0:p))) y <- x - b %*% pracma::mldivide(b, x) if (vec) { y <- as.vector(y) } dimnames(y) <- dimnames(x) y } gsignal/R/cheb2ord.R0000644000176200001440000001754114420222025013713 0ustar liggesusers# cheb2ord.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2000 Paul Kienzle # Copyright (C) 2018 Charles Praplan # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200519 Geert van Boxtel First version for v0.1.0 # 20200708 GvB renamed IIRfspec to FilterSpecs #------------------------------------------------------------------------------ #' Chebyshev Type II filter order #' #' Compute Chebyshev type-II filter order and cutoff for the desired #' response characteristics. #' #' @param Wp,Ws pass-band and stop-band edges. For a low-pass or high-pass #' filter, \code{Wp} and \code{Ws} are scalars. For a band-pass or #' band-rejection filter, both are vectors of length 2. For a low-pass filter, #' \code{Wp < Ws}. For a high-pass filter, \code{Ws > Wp}. For a band-pass #' \code{(Ws[1] < Wp[1] < Wp[2] < Ws[2])} or band-reject \code{(Wp[1] < Ws[1] #' < Ws[2] < Wp[2])} filter design, \code{Wp} gives the edges of the pass #' band, and \code{Ws} gives the edges of the stop band. For digital filters, #' frequencies are normalized to [0, 1], corresponding to the range [0, fs / #' 2]. In case of an analog filter, all frequencies are specified in radians #' per second. #' @param Rp allowable decibels of ripple in the pass band. #' @param Rs minimum attenuation in the stop band in dB. #' @param plane "z" for a digital filter or "s" for an analog filter. #' #' @return A list of class \code{'FilterSpecs'} with the following list #' elements: #' \describe{ #' \item{n}{filter order} #' \item{Wc}{cutoff frequency} #' \item{type}{filter type, normally one of \code{"low"}, \code{"high"}, #' \code{"stop"}, or \code{"pass"}.} #' } #' @examples #' ## low-pass 30 Hz filter #' fs <- 128 #' spec <- cheb2ord(30/(fs/2), 40/(fs/2), 0.5, 40) #' cf <- cheby2(spec) #' freqz(cf, fs = fs) #' #' @author Paul Kienzle, Charles Praplan.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{cheby1}} #' #' @export cheb2ord <- function(Wp, Ws, Rp, Rs, plane = c("z", "s")) { #input validation plane <- match.arg(plane) if (! (is.vector(Wp) && is.vector(Ws) && (length(Wp) == length(Ws)))) { stop("Wp and Ws must both be scalars or vectors of length 2") } if (! ((length(Wp) == 1) || (length(Wp) == 2))) { stop("Wp and Ws must both be scalars or vectors of length 2") } if (plane == "z" && !(is.numeric(Wp) && all(Wp >= 0) && all(Wp <= 1))) { stop("all elements of Wp must be in the range [0,1]") } if (plane == "z" && !(is.numeric(Ws) && all(Ws >= 0) && all(Ws <= 1))) { stop("all elements of Ws must be in the range [0,1]") } if (plane == "s" && !(is.numeric(Wp) && all(Wp >= 0))) { stop("all elements of Wp must be non-negative") } if (plane == "s" && !(is.numeric(Ws) && all(Ws >= 0))) { stop("all elements of Ws must be non-negative") } if ((length(Wp) == 2) && (Wp[2] <= Wp[1])) { stop("Wp[1] must be smaller than Wp[2]") } if ((length(Ws) == 2) && (Ws[2] <= Ws[1])) { stop("Ws[1] must be smaller than Ws[2]") } if ((length(Wp) == 2) && (all(Wp > Ws) || all(Ws > Wp))) { stop("Wp must be contained by Ws or Ws must be contained by Wp") } if (plane == "s") { # No prewarp in case of analog filter Wpw <- Wp Wsw <- Ws } else { ## sampling frequency of 2 Hz T <- 2 Wpw <- (2 / T) * tan(pi * Wp / T) # prewarp Wsw <- (2 / T) * tan(pi * Ws / T) # prewarp } ## pass/stop band to low pass filter transform: if (length(Wpw) == 2 && length(Wsw) == 2) { ## Band-pass filter if (Wpw[1] > Wsw[1]) { ## Modify band edges if not symmetrical. For a band-pass filter, ## the lower or upper stopband limit is moved, resulting in a smaller ## stopband than the caller requested. if (Wpw[1] * Wpw[2] < Wsw[1] * Wsw[2]) { Wsw[2] <- Wpw[1] * Wpw[2] / Wsw[1] } else { Wsw[1] <- Wpw[1] * Wpw[2] / Wsw[2] } w02 <- Wpw[1] * Wpw[2] wp <- Wpw[2] - Wpw[1] ws <- Wsw[2] - Wsw[1] ## Band-stop / band-reject / notch filter } else { ## Modify band edges if not symmetrical. For a band-stop filter, ## the lower or upper passband limit is moved, resulting in a smaller ## rejection band than the caller requested. if (Wpw[1] * Wpw[2] > Wsw[1] * Wsw[2]) { Wpw[2] <- Wsw[1] * Wsw[2] / Wpw[1] } else { Wpw[1] <- Wsw[1] * Wsw[2] / Wpw[2] } w02 <- Wpw[1] * Wpw[2] wp <- w02 / (Wpw[2] - Wpw[1]) ws <- w02 / (Wsw[2] - Wsw[1]) } ws <- ws / wp wp <- 1 ## High-pass filter } else if (Wpw > Wsw) { wp <- Wsw ws <- Wpw ## Low-pass filter } else { wp <- Wpw ws <- Wsw } Wa <- ws / wp ## compute minimum n which satisfies all band edge conditions stop_atten <- 10 ^ (abs(Rs) / 10) pass_atten <- 10 ^ (abs(Rp) / 10) n <- ceiling(acosh(sqrt((stop_atten - 1) / (pass_atten - 1))) / acosh(Wa)) ## compute stopband frequency limits to make the the filter characteristic ## touch either at least one stop band corner or one pass band corner. epsilon <- 1 / sqrt(10 ^ (.1 * abs(Rs)) - 1) k <- cosh(1 / n * acosh(sqrt(1 / (10 ^ (.1 * abs(Rp)) - 1)) / epsilon)) ## compute -3dB cutoff given Wp, Rp and n if (length(Wpw) == 2 && length(Wsw) == 2) { ## Band-pass filter if (Wpw[1] > Wsw[1]) { type <- "pass" w_prime_s <- Wsw # same formula as for LP w_prime_p <- k * Wpw # " ## Band-stop / band-reject / notch filter } else { type <- "stop" w_prime_s <- Wsw # same formula as for HP w_prime_p <- Wpw / k # " } ## freq to be returned to match pass band w0 <- sqrt(prod(Wpw)) Q <- w0 / diff(Wpw) # BW at -Rp dB not at -3dB wc <- Wpw W_prime <- w_prime_p[1] / wc[1] # same with w_prime(2)/wc(2) wa <- abs(W_prime + sqrt(W_prime^2 + 4 * Q ^ 2)) / (2 * Q / w0) wb <- abs(W_prime - sqrt(W_prime^2 + 4 * Q ^ 2)) / (2 * Q / w0) Wcw_p <- c(wb, wa) ## freq to be returned to match stop band w0 <- sqrt(prod(Wsw)) Q <- w0 / diff(Wsw) # BW at -Rs dB not at -3dB wc <- Wsw W_prime <- w_prime_s[1] / wc[1] # same with w_prime(2)/wc(2) wa <- abs(W_prime + sqrt(W_prime^2 + 4 * Q ^ 2)) / (2 * Q / w0) wb <- abs(W_prime - sqrt(W_prime^2 + 4 * Q ^ 2)) / (2 * Q / w0) Wcw_s <- c(wb, wa) ## High-pass filter } else if (Wpw > Wsw) { type <- "high" Wcw_s <- Wsw # to match stop band Wcw_p <- Wpw / k # to match pass band ## Low-pass filter } else { type <- "low" Wcw_s <- Wsw # to match stop band Wcw_p <- k * Wpw # to match pass band } if (plane == "s") { # No prewarp in case of analog filter Wc_s <- Wcw_s Wc_p <- Wcw_p } else { # Inverse frequency warping for discrete-time filter Wc_s <- atan(Wcw_s * (T / 2)) * (T / pi) Wc_p <- atan(Wcw_p * (T / 2)) * (T / pi) } FilterSpecs(n = n, Wc = Wc_p, type = type, Wc_s = Wc_s, plane = plane, Rs = Rs) } gsignal/R/poly.R0000644000176200001440000000446714663322361013226 0ustar liggesusers# poly.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function Copyright (C) 1994-2017 John W. Eaton # Author: KH # Created: 24 December 1993 # Adapted-By: jwe # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200126 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Polynomial with specified roots #' #' Compute the coefficients of a polynomial when the roots are given, or the #' characteristic polynomial of a matrix. #' #' If a vector is passed as an argument, then \code{poly(x)} is a vector of the #' coefficients of the polynomial whose roots are the elements of \code{x}. #' #' If an \eqn{N x N} square matrix is given, \code{poly(x)} #' is the row vector of the coefficients of \code{det (z * diag (N) - x)}, #' which is the characteristic polynomial of \code{x}. #' #' @param x Real or complex vector, or square matrix. #' #' @return A vector of the coefficients of the polynomial in order from highest #' to lowest polynomial power. #' #' @examples #' p <- poly(c(1, -1)) #' p <- poly(pracma::roots(1:3)) #' p <- poly(matrix(1:9, 3, 3)) #' #' @seealso \code{\link[pracma]{roots}} #' #' @author Kurt Hornik.\cr #' Conversion to R by Tom Short,\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com} # #' @export poly <- function(x) { n <- NROW(x) m <- NCOL(x) if (is.null(x) || length(x) == 0) return(1) if (m == 1) { v <- x } else if (m == n) { v <- eigen(x)$values } else { stop("x must be a vector or a square matrix") } y <- numeric(n + 1) y[1] <- 1 for (j in seq_len(n)) { y[2:(j + 1)] <- y[2:(j + 1)] - v[j] * y[1:j] } zapIm(y) } gsignal/R/gaussian.R0000644000176200001440000000450214420222025014026 0ustar liggesusers# gaussian.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1999 Paul Kienzle # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191211 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Gaussian convolution window #' #' Return a Gaussian convolution window of length \code{n}. #' #' The width of the window is inversely proportional to the parameter \code{a}. #' Use larger \code{a} for a narrower window. Use larger \code{m} for longer #' tails. #' \deqn{w = e^{(-(a*x)^{2}/2 )}} #' for \code{x <- seq(-(n - 1) / 2, (n - 1) / 2, by = n)}. #' #' Width a is measured in frequency units (sample rate/num samples). It should #' be f when multiplying in the time domain, but 1/f when multiplying in the #' frequency domain (for use in convolutions). #' #' @param n Window length, specified as a positive integer. #' @param a Width factor, specified as a positive real scalar. \code{a} is #' inversely proportional to the width of the window. Default: 1. #' #' @return Gaussian convolution window, returned as a vector. #' #' @examples #' #' g1 <- gaussian(128, 1) #' g2 <- gaussian(128, 0.5) #' plot (g1, type = "l", xlab = "Samples", ylab =" Amplitude", ylim = c(0, 1)) #' lines(g2, col = "red") #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export gaussian <- function(n, a = 1) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) stop("n must be an integer strictly positive") if (!isScalar(a)) stop("a must be a scalar") w <- exp(-0.5 * ((0:(n - 1) - (n - 1) / 2) * a)^2) w } gsignal/R/dwt.R0000644000176200001440000002557514420222025013027 0ustar liggesusers# dwt.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2013 Lukas F. Reichlin # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201020 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' 1-D Discrete Wavelet Transform #' #' Compute the single-level discrete wavelet transform of a signal #' #' This function is only included because of compatibility with the 'Octave' #' 'signal' package. Specialized packages exist in R to perform the discrete #' wavelet transform, e.g., the \code{wavelets} package [1]. this function #' recognizes only a few wavelet names, namely those for which scale #' coefficients are available (Daubechies [2] and Coiflet [3]). #' #' The wavelet and scaling coefficients are returned by the function #' \code{wfilters}, which returns the coefficients for reconstruction filters #' associated with the wavelet \code{wname}. Decomposition filters are the time #' reverse of the reconstruction filters (see examples). #' #' @param x input data, specified as a numeric vector. #' @param wname analyzing wavelet, specified as a character string consisting of #' a class name followed by the wavelet length Only two classes of wavelets #' are supported; Daubechies (denoted by the prefix \code{'d'} of even #' lengths 2 - 20, and Coiflet (denoted by the prefix '\code{'c'} of #' lengths 6, 12, 18, 24, and 30. The wavelet name \code{'haar'} is #' the equivalent of \code{'d2'}. Default: d8. #' @param lo scaling (low-pass) filter, specified as an even-length numeric #' vector. \code{lo} must be the same length as \code{hi}. Ignored when #' \code{wname != NULL}. #' @param hi wavelet (high-pass) filter, specified as an even-length numeric #' vector. \code{hi} must be the same length as \code{lo}, Ignored when #' \code{wname != NULL}. #' #' @note The notations \code{g} and \code{h} are often used to denote low-pass #' (scaling) and high-pass (wavelet) coefficients, respectively, but #' inconsistently. Ref [4] uses it, as does the R \code{wavelets} package. #' 'Octave' uses the reverse notation. To avoid confusion, more neutral terms #' are used here. #' #' @note There are two naming schemes for wavelet names in use. For instance for #' Daubechies wavelets (d), dN using the length or number of taps, and dbA #' referring to the number of vanishing moments. So d4 and db2 are the same #' wavelet transform. This function uses the formed (dN) notation; 'Matlab' #' uses the latter (dbA). #' #' @return A list containing two numeric vectors: #' \describe{ #' \item{a}{approximation (average) coefficients, obtained from convolving #' \code{x} with the scaling (low-pass) filter \code{lo}, and then #' downsampled (keep the even-indexed elements).} #' \item{d}{detail (difference) coefficients, obtained from convolving #' \code{x} with the wavelet (high-pass) filter \code{hi}, and then #' downsampled (keep the even-indexed elements).} #' } #' #' @examples #' # get Coiflet 30 coefficients #' wv <- wfilters('c30') #' lo <- rev(wv$lo) #' hi <- rev(wv$hi) #' #' # general time-varying signal #' time <- 1 #' fs <- 1000 #' x <- seq(0,time, length.out=time*fs) #' y <- c(cos(2*pi*100*x)[1:300], cos(2*pi*50*x)[1:300], #' cos(2*pi*25*x)[1:200], cos(2*pi*10*x)[1:200]) #' op <- par(mfrow = c(3,1)) #' plot(x, y, type = "l", xlab = "Time", ylab = "Amplitude", #' main = "Original signal") #' wt <- dwt(y, wname = NULL, lo, hi) #' #' x2 <- seq(1, length(x) - length(hi) + 1, 2) #' plot(x2, wt$a, type = "h", xlab = "Time", ylab = "", #' main = "Approximation coefficients") #' plot(x2, wt$d, type = "h", xlab = "Time", ylab = "", #' main = "Detail coefficients") #' par (op) #' #' @author Lukas F. Reichlin.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references [1] \url{https://CRAN.R-project.org/package=wavelets} #' @references [2] \url{https://en.wikipedia.org/wiki/Daubechies_wavelet} #' @references [3] \url{https://en.wikipedia.org/wiki/Coiflet} #' @references [4] #' \url{https://en.wikipedia.org/wiki/Discrete_wavelet_transform} #' #' @rdname dwt #' @export dwt <- function(x, wname = "d8", lo = NULL, hi = NULL) { # check parameters if (!is.vector(x) || !is.numeric(x)) { stop("x must be a numeric vector") } if (is.null(wname)) { if (is.null(lo) || is.null(hi)) { stop("both lo and hi needed when wname not specified") } else { if (length(lo) != length(hi)) { stop("lo and hi must be of equal length") } } } else { cf <- wfilters(wname) lo <- cf$lo hi <- cf$hi } tmp <- wconv("1d", x, lo, "valid") u <- tmp[seq(1, length(tmp), 2)] tmp <- wconv("1d", x, hi, "valid") v <- tmp[seq(1, length(tmp), 2)] list(a = u, d = v) } #' @rdname dwt #' @export wfilters <- function(wname) { lo <- switch(wname, "haar" = c(1, 1), "d2" = c(1, 1), "d4" = c(0.6830127, 1.1830127, 0.3169873, -0.1830127), "d6" = c(0.47046721, 1.14111692, 0.650365, -0.19093442, -0.12083221, 0.0498175), "d8" = c(0.32580343, 1.01094572, 0.89220014, -0.03957503, -0.26450717, 0.0436163, 0.0465036, -0.01498699), "d10" = c(0.22641898, 0.85394354, 1.02432694, 0.19576696, -0.34265671, -0.04560113, 0.10970265, -0.00882680, -0.01779187, 4.71742793e-3), "d12" = c(0.15774243, 0.69950381, 1.06226376, 0.44583132, -0.31998660, -0.18351806, 0.13788809, 0.03892321, -0.04466375, 7.83251152e-4, 6.75606236e-3, -1.52353381e-3), "d14" = c(0.11009943, 0.56079128, 1.03114849, 0.66437248, -0.20351382, -0.31683501, 0.1008467, 0.11400345, -0.05378245, -0.02343994, 0.01774979, 6.07514995e-4, -2.54790472e-3, 5.00226853e-4), "d16" = c(0.07695562, 0.44246725, 0.95548615, 0.82781653, -0.02238574, -0.40165863, 6.68194092e-4, 0.18207636, -0.02456390, -0.06235021, 0.01977216, 0.01236884, -6.88771926e-3, -5.54004549e-4, 9.55229711e-4, -1.66137261e-4), "d18" = c(0.05385035, 0.34483430, 0.85534906, 0.92954571, 0.18836955, -0.41475176, -0.13695355, 0.21006834, 0.043452675, -0.09564726, 3.54892813e-4, 0.03162417, -6.67962023e-3, -6.05496058e-3, 2.61296728e-3, 3.25814671e-4, -3.56329759e-4, 5.5645514e-5), "d20" = c(0.03771716, 0.26612218, 0.74557507, 0.97362811, 0.39763774, -0.35333620, -0.27710988, 0.18012745, 0.13160299, -0.10096657, -0.04165925, 0.04696981, 5.10043697e-3, -0.01517900, 1.97332536e-3, 2.81768659e-3, -9.69947840e-4, -1.64709006e-4, 1.32354367e-4, -1.875841e-5), "c6" = c(-0.1028594569415370, 0.4778594569415370, 1.2057189138830700, 0.5442810861169260, -0.1028594569415370, -0.0221405430584631), "c12" = c(0.0231751934774337, -0.0586402759669371, -0.0952791806220162, 0.5460420930695330, 1.1493647877137300, 0.5897343873912380, -0.1081712141834230, -0.0840529609215432, 0.0334888203265590, 0.0079357672259240, -0.0025784067122813, -0.0010190107982153), "c18" = c(-0.0053648373418441, 0.0110062534156628, 0.0331671209583407, -0.0930155289574539, -0.0864415271204239, 0.5730066705472950, 1.1225705137406600, 0.6059671435456480, -0.1015402815097780, -0.1163925015231710, 0.0488681886423339, 0.0224584819240757, -0.0127392020220977, -0.0036409178311325, 0.0015804102019152, 0.0006593303475864, -0.0001003855491065, -0.0000489314685106), "c24" = c(0.0012619224228619, -0.0023044502875399, -0.0103890503269406, 0.0227249229665297, 0.0377344771391261, -0.1149284838038540, -0.0793053059248983, 0.5873348100322010, 1.1062529100791000, 0.6143146193357710, -0.0942254750477914, -0.1360762293560410, 0.0556272739169390, 0.0354716628454062, -0.0215126323101745, -0.0080020216899011, 0.0053053298270610, 0.0017911878553906, -0.0008330003901883, -0.0003676592334273, 0.0000881604532320, 0.0000441656938246, -0.0000046098383254, -0.0000025243583600), "c30" = c(-0.0002999290456692, 0.0005071055047161, 0.0030805734519904, -0.0058821563280714, -0.0143282246988201, 0.0331043666129858, 0.0398380343959686, -0.1299967565094460, -0.0736051069489375, 0.5961918029174380, 1.0950165427080700, 0.6194005181568410, -0.0877346296564723, -0.1492888402656790, 0.0583893855505615, 0.0462091445541337, -0.0279425853727641, -0.0129534995030117, 0.0095622335982613, 0.0034387669687710, -0.0023498958688271, -0.0009016444801393, 0.0004268915950172, 0.0001984938227975, -0.0000582936877724, -0.0000300806359640, 0.0000052336193200, 0.0000029150058427, -0.0000002296399300, -0.0000001358212135) ) lo <- lo / sqrt(2) ll <- length(lo) hi <- lo[ll:1] * (-1) ^ ((1:ll) - 1) list(lo = lo, hi = hi) } gsignal/R/hanning.R0000644000176200001440000000571014420222025013640 0ustar liggesusers# hanning.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1995-2017 Andreas Weingessel # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191209 GbB First version for v0.1.0 # 20200413 GvB corrected definition of hanning # 20200606 GvB exported hanning from namespace #------------------------------------------------------------------------------ #' Hann window #' #' Return the filter coefficients of a Hann window of length \code{n}. #' #' The Hann window is a member of the family of cosine sum windows. It was named #' after Julius von Hann, and is sometimes referred to as Hanning, presumably #' due to its linguistic and formulaic similarities to Hamming window. #' #' @param n Window length, specified as a positive integer. #' @param method Character string. Window sampling method, specified as: #' \describe{ #' \item{"symmetric"}{(Default). Use this option when using windows for filter #' design.} #' \item{"periodic"}{This option is useful for spectral analysis because it #' enables a windowed signal to have the perfect periodic extension implicit #' in the discrete Fourier transform. When \code{"periodic"} is specified, the #' function computes a window of length \code{n + 1} and returns the first #' \code{n} points.} #' } #' #' @return Hann window, returned as a vector. #' #' @examples #' #' h <- hann(64) #' plot (h, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' hs = hann(64,'symmetric') #' hp = hann(63,'periodic') #' plot (hs, type = "l", xlab = "Samples", ylab =" Amplitude") #' lines(hp, col="red") #' #' @author Andreas Weingessel, \email{Andreas.Weingessel@@ci.tuwien.ac.at}.\cr #' Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. # #' @rdname hann #' @export hann <- function(n, method = c("symmetric", "periodic")) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) stop("n must be an integer strictly positive") method <- match.arg(method) if (method == "periodic") { N <- n } else if (method == "symmetric") { N <- n - 1 } else { stop("method must be either 'periodic' or 'symmetric'") } if (n == 1) { w <- 1 } else { n <- n - 1 w <- 0.5 - 0.5 * cos(2 * pi * (0:n) / N) } w } #' @rdname hann #' @export hanning <- function(n, method = c("symmetric", "periodic")) hann(n, method) gsignal/R/cheb.R0000644000176200001440000000453514420222025013123 0ustar liggesusers# cheb.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2002 André Carezia # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191211 GvB First version for v0.1.0 # 20210405 GvB v0.3.0 corrected numerical rounding error # when called by chebwin(7) #------------------------------------------------------------------------------ #' Chebyshev polynomials #' #' Return the value of the Chebyshev polynomial at specific points. #' #' The Chebyshev polynomials are defined by the equations: #' \if{latex}{ #' \deqn{Tn(x) = cos(n \cdot acos(x), |x|<= 1} #' \deqn{Tn(x) = cosh(n \cdot acosh(x), |x|> 1} #' } #' \if{html}{\preformatted{ #' Tn(x) = cos(n . acos(x), |x|<= 1 #' Tn(x) = cosh(n . acosh(x), |x|> 1 #' }} #' If \code{x} is a vector, the output is a vector of the same size, where each #' element is calculated as \eqn{y(i) = Tn(x(i))}. #' #' @param n Order of the polynomial, specified as a positive integer. #' @param x Point or points at which to calculate the Chebyshev polynomial #' #' @return Polynomial of order \code{x}, evaluated at point(s) \code{x}. #' #' @examples #' #' cp <- cheb(5, 1) #' cp <- cheb(5, c(2,3)) #' #' @author André Carezia, \email{acarezia@@uol.com.br}.\cr Conversion to R by #' Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export cheb <- function(n, x) { if (!isPosscal(n) || !isWhole(n) || n <= 0) stop("n must be an integer strictly positive") T <- rep(0, length(x)) idx <- abs(x) <= 1 if (any(idx)) { T[idx] <- cos(n * acos(signif(as.complex(x[idx], 15)))) } idx <- abs(x) > 1 if (any(idx)) { T[idx] <- cosh(n * acosh(signif(as.complex(x[idx])))) } Re(T) } gsignal/R/ar_psd.R0000644000176200001440000002402014420222025013461 0ustar liggesusers# ar_psd.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 2006 Peter V. Lanspeary # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201101 GvB setup for gsignal v0.1.0 # 20220511 GvB use inherits() instead of direct comparison of class name # 20220512 GvB plot method for class 'ar_psd' #------------------------------------------------------------------------------ #' Power spectrum of AR model #' #' Compute the power spectral density of an autoregressive model. #' #' This function calculates the power spectrum of the autoregressive model #' \if{latex}{ #' \deqn{x(n) = \sqrt{v} \cdot e(n) + \sum_{k=1}^{M} a(k) \cdot x(n-k)} #' } #' \if{html}{\preformatted{ #' M #' x(n) = sqrt(v).e(n) + SUM a(k).x(n-k) #' k=1 #' }} #' where \code{x(n)} is the output of the model and \code{e(n)} is white noise. #' #' @param a numeric vector of autoregressive model coefficients. The first #' element is the zero-lag coefficient, which always has a value of 1. #' @param v square of the moving average coefficient, specified as a positive #' scalar Default: 1 #' @param freq vector of frequencies at which power spectral density is #' calculated, or a scalar indicating the number of uniformly distributed #' frequency values at which spectral density is calculated. Default: 256. #' @param fs sampling frequency (Hz). Default: 1 #' @param range character string. one of: #' \describe{ #' \item{\code{"half"} or \code{"onesided"}}{frequency range of the spectrum #' is from zero up to but not including \code{fs / 2}. Power from negative #' frequencies is added to the positive side of the spectrum.} #' \item{\code{"whole"} or \code{"twosided"}}{frequency range of the spectrum #' is \code{-fs / 2} to \code{fs / 2}, with negative frequencies stored in #' "wrap around order" after the positive frequencies; e.g. frequencies for a #' 10-point \code{"twosided"} spectrum are 0 0.1 0.2 0.3 0.4 0.5 -0.4 -0.3 #' -0.2. -0.1.} #' \item{\code{"shift"} or \code{"centerdc"}}{same as \code{"whole"} but with #' the first half of the spectrum swapped with second half to put the #' zero-frequency value in the middle. If \code{freq} is a vector, #' \code{"shift"} is ignored.} #' } #' Default: If model coefficients \code{a} are real, the default range is #' \code{"half"}, otherwise the default range is \code{"whole"}. #' @param method method used to calculate the power spectral density, either #' \code{"fft"} (use the Fast Fourier Transform) or \code{"poly"} (calculate #' the power spectrum as a polynomial). This argument is ignored if the #' \code{freq} argument is a vector. The default is \code{"poly"} unless the #' \code{freq} argument is an integer power of 2. #' @param x object to plot. #' @param yscale character string specifying scaling of Y-axis; one of #' \code{"linear"}, \code{"log"}, \code{"dB"} #' @param xlab,ylab,main labels passed to plotting function. Default: NULL #' @param ... additional arguments passed to functions #' #' @return An object of class \code{"ar_psd"} , which is a list containing two #' elements, \code{freq} and \code{psd} containing the frequency values and #' the estimates of power-spectral density, respectively. #' #' @examples #' a <- c(1, -2.7607, 3.8106, -2.6535, 0.9238) #' psd <- ar_psd(a) #' #' @author Peter V. Lanspeary, \email{pvl@@mecheng.adelaide.edu.au}.\cr #' Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com} #' #' @rdname ar_psd #' @export ar_psd <- function(a, v = 1, freq = 256, fs = 1, range = ifelse(is.numeric(a), "half", "whole"), method = ifelse(length(freq) == 1 && bitwAnd(freq, freq - 1) == 0, "fft", "poly")) { # parameter checking if (!is.vector(a) || length(a) < 2 || a[1] != 1) { stop("a must be a vector of length >= 2 with the first element equal to 1") } else { real_model <- ifelse(is.numeric(a), 1L, 0L) } if (!isPosscal(v) || v <= 0) { stop("v must be a positive scalar > 0") } if (!is.vector(freq)) { stop("freq must be a scalar or a vector") } else { freq_len <- length(freq) user_freqs <- freq_len > 1 if (!user_freqs && (!is.numeric(freq) || !isWhole(freq) || freq < 2)) { stop("freq must be an integer >= 2") } else if (user_freqs && !is.numeric(freq)) { stop("freq vector must be numeric") } } if (!isPosscal(fs) || fs <= 0) { stop("fs must be a positive scalar > 0") } range <- match.arg(range, c("half", "onesided", "whole", "twosided", "shift", "centerdc")) if (range == "half" || range == "onesided") { pad_fact <- 2L # FT zero-padding factor (pad FFT to double length) do_shift <- FALSE } else if (range == "whole" || range == "twosided") { pad_fact <- 1L # FFT zero-padding factor (do not pad) do_shift <- FALSE } else if (range == "shift" || range == "centerdc") { pad_fact <- 1L do_shift <- TRUE } method <- match.arg(method, c("fft", "poly")) if (method == "fft") { force_fft <- TRUE force_poly <- FALSE } else if (method == "poly") { force_fft <- FALSE force_poly <- TRUE } # end of parameter checking # frequencies at which to determine psd if (user_freqs) { # user provides vector of frequencies if (any(abs(freq) > fs / 2)) { stop("freq cannot exceed half of the sampling frequency") } else if (pad_fact == 2L && any(freq < 0)) { stop("freq must be positive in a onesided spectrum") } freq_len <- length(freq) fft_len <- freq_len use_fft <- FALSE do_shift <- FALSE } else { # internally generated frequencies freq_len <- freq freq <- (fs / pad_fact / freq_len) * seq(0, freq_len - 1) # decide which method to use (poly or FFT) is_power_of_2 <- length(freq_len) == 1 && bitwAnd(freq_len, freq_len - 1) == 0 use_fft <- (!force_poly && is_power_of_2) || force_fft fft_len <- freq_len * pad_fact } # calculate denominator of Equation 2.28, Kay and Marple Jr, "Spectrum # analysis -- a modern perspective", Proceedings of the IEEE, Vol 69, pp # 1380-1419, Nov., 1981 len_coeffs <- length(a) if (use_fft) { # FFT method fft_out <- stats::fft(postpad(a, fft_len)) } else { # polynomial method # complex data on "half" frequency range needs -ve frequency values if (pad_fact == 2L && !real_model) { freq <- c(freq, -freq[seq(freq_len, 1, -1)]) fft_len <- 2 * freq_len } fft_out <- pracma::polyval(a[seq(len_coeffs, 1, -1)], exp((-1i * 2 * pi / fs) * freq)) } # The power spectrum (PSD) is the scaled squared reciprocal of amplitude # of the FFT/polynomial. This is NOT the reciprocal of the periodogram. # The PSD is a continuous function of frequency. For uniformly # distributed frequency values, the FFT algorithm might be the most # efficient way of calculating it. psd <- (v / fs) / (fft_out * Conj(fft_out)) # range='half' or 'onesided', # add PSD at -ve frequencies to PSD at +ve frequencies # N.B. unlike periodogram, PSD at zero frequency _is_ doubled. if (pad_fact == 2L) { freq <- freq[1:freq_len] if (real_model) { # real data, double the psd psd <- 2 * psd[1:freq_len] } else if (use_fft) { # complex data, FFT method, internally-generated frequencies psd <- psd[1:freq_len] + c(psd[1], psd[seq(fft_len, freq_len + 2, -1)]) } else { # complex data, polynomial method # user-defined and internally-generated frequencies psd <- psd[1:freq_len] + psd[seq(fft_len, freq_len + 1, -1)] } # range equals 'shift' # disabled for user-supplied frequencies # Shift zero-frequency to the middle (pad_fact==1) } else if (do_shift) { len2 <- trunc((fft_len + 1) / 2) psd <- c(psd[(len2 + 1):fft_len], psd[1:len2]) freq <- c(freq[(len2 + 1):fft_len] - fs, freq[1:len2]) } if (real_model == 1L) { psd <- Re(psd) } structure(list(freq = freq, psd = psd, fs = fs), class = "ar_psd") } #' @rdname ar_psd #' @export plot.ar_psd <- function( x, yscale = c("linear", "log", "dB"), xlab = NULL, ylab = NULL, main = NULL, ...) { if (!inherits(x, "ar_psd")) { stop("invalid object type") } yscale <- match.arg(yscale) if (is.null(xlab)) { if (x$fs == 1) { xlab <- expression( paste("Normalized frequency (\u00D7 ", pi, " rad/sample)")) } else if (x$fs == pi) { xlab <- "Frequency (rad/sample)" } else { xlab <- "Frequency (Hz)" } } sub <- paste("Resolution:", format(x$fs / length(x$freq), digits = 6, nsmall = 6)) if (is.null(ylab)) { ylab <- switch(yscale, "linear" = "PSD/Frequency", "log" = expression(paste("log"[10], "PSD/Frequency")), "dB" = "PSD (dB/Hz)") } plt <- switch(yscale, "linear" = x$psd, "log" = log10(x$psd), "dB" = 10 * log10(x$psd)) graphics::plot(x$freq, plt, type = "l", xlab = xlab, ylab = "", ...) graphics::title(main, sub = sub) graphics::title(ylab = ylab, line = 2) } #' @rdname ar_psd #' @export print.ar_psd <- function(x, yscale = c("linear", "log", "dB"), xlab = NULL, ylab = NULL, main = NULL, ...) { plot.ar_psd(x, yscale, xlab, ylab, main, ...) }gsignal/R/buttap.R0000644000176200001440000000337114420222025013516 0ustar liggesusers# buttap.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2013 Carne Draug # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200517 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Butterworth filter prototype #' #' Return the poles and gain of an analog Butterworth lowpass filter prototype. #' #' This function exists for compatibility with 'Matlab' and 'Octave' only, and #' is equivalent to \code{butter(n, 1, "low", "s")}. #' #' @param n Order of the filter. #' #' @return List of class \code{\link{Zpg}} containing poles and gain of the #' filter. #' #' @examples #' ## 9th order Butterworth low-pass analog filter #' zp <- buttap(9) #' w <- seq(0, 4, length.out = 128) #' freqs(zp, w) #' #' @author Carne Draug, \email{carandraug+dev@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export buttap <- function(n) { if (!isPosscal(n) || ! isWhole(n)) stop("n must be an integer strictly positive") butter(n, 1, "low", "s", "Zpg") } gsignal/R/tf2sos.R0000644000176200001440000000427514420222025013443 0ustar liggesusers# tf2sos.R # Copyright (C) 2020 Geert van Boxtel # Original Octave version: # Copyright (C) 2005 Julius O. Smith III # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200402 GvB setup for gsignal v0.1.0 # 20200406 GvB validated #------------------------------------------------------------------------------ #' Transfer function to second-order sections form #' #' Convert digital filter transfer function data to second-order section form. #' #' @param b moving average (MA) polynomial coefficients #' @param a autoregressive (AR) polynomial coefficients #' #' @return A list with the following list elements: #' \describe{ #' \item{sos}{Second-order section representation, specified as an nrow-by-6 #' matrix, whose rows contain the numerator and denominator coefficients of #' the second-order sections:\cr \code{sos <- rbind(cbind(B1, A1), cbind(...), #' cbind(Bn, An))}, where \code{B1 <- c(b0, b1, b2)}, and \code{A1 <- c(a0, #' a1, a2)} for section 1, etc. The b0 entry must be nonzero for each #' section.} #' \item{g}{Overall gain factor that effectively scales the output \code{b} #' vector (or any one of the input \code{Bi} vectors).} #' } #' #' @seealso See also \code{\link{filter}} #' #' @examples #' b <- c(1, 0, 0, 0, 0, 1) #' a <- c(1, 0, 0, 0, 0, .9) #' sosg <- tf2sos (b, a) #' #' @author Julius O. Smith III, \email{jos@@ccrma.stanford.edu}.\cr #' Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com}. #' #' @export tf2sos <- function(b, a) { zpk <- tf2zp(b, a) sos <- zp2sos(zpk$z, zpk$p, zpk$g) sos } gsignal/R/flattopwin.R0000644000176200001440000000577314420222025014416 0ustar liggesusers# flattopwin.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Author: Paul Kienzle (2004) # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191211 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Flat top window #' #' Return the filter coefficients of a flat top window. #' #' The Flat Top window is defined by the function: #' \deqn{f(w) = 1 - 1.93 cos(2 \pi w) + 1.29 cos(4 \pi w) - 0.388 cos(6 \pi w) + #' 0.0322 cos(8 \pi w)} #' where \code{w = i/(n-1)} for \code{i=0:n-1} for a symmetric window, or #' \code{w = i/n} for \code{i=0:n-1} for a periodic window. The default is #' symmetric. The returned window is normalized to a peak of 1 at w = 0.5. #' #' Flat top windows have very low passband ripple (< 0.01 dB) and are used #' primarily for calibration purposes. Their bandwidth is approximately 2.5 #' times wider than a Hann window. #' #' @param n Window length, specified as a positive integer. #' @param method Character string. Window sampling method, specified as: #' \describe{ #' \item{"symmetric"}{(Default). Use this option when using windows for filter #' design.} #' \item{"periodic"}{This option is useful for spectral analysis because it #' enables a windowed signal to have the perfect periodic extension implicit #' in the discrete Fourier transform. When 'periodic' is specified, the #' function computes a window of length \code{n + 1} and returns the first #' \code{n} points.} #' } #' #' @return Flat top window, returned as a vector. #' #' @examples #' #' ft <- flattopwin(64) #' plot (ft, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export flattopwin <- function(n, method = c("symmetric", "periodic")) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) stop("n must be an integer strictly positive") method <- match.arg(method) if (method == "periodic") { N <- n } else if (method == "symmetric") { N <- n - 1 } else { stop("method must be either 'periodic' or 'symmetric'") } if (n == 1) { w <- 1 } else { x <- 2 * pi * (0:(n - 1)) / N w <- (1 - 1.93 * cos(x) + 1.29 * cos(2 * x) - 0.388 * cos(3 * x) + 0.0322 * cos(4 * x)) / 4.6402 } w } gsignal/R/FilterSpecs.R0000644000176200001440000000464514420222025014447 0ustar liggesusers# FilterSpecs.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200507 GvB setup for gsignal v0.1.0 # 20200708 GvB renamed IIRfspec to FilterSpecs #------------------------------------------------------------------------------ #' Filter specifications #' #' Filter specifications, including order, frequency cutoff, type, and #' possibly others. #' #' @param n filter order. #' @param Wc cutoff frequency. #' @param type filter type, normally one of \code{"low"}, \code{"high"}, #' \code{"stop"}, or \code{"pass"}. #' @param ... other filter description characteristics, possibly including Rp #' for dB of pass band ripple or Rs for dB of stop band ripple, depending on #' filter type (Butterworth, Chebyshev, etc.). #' #' @return A list of class \code{'FilterSpecs'} with the following list elements #' (repeats of the input arguments): #' \describe{ #' \item{n}{filter order} #' \item{Wc}{cutoff frequency} #' \item{type}{filter type, normally one of \code{"low"}, \code{"high"}, #' \code{"stop"}, or \code{"pass"}.} #' \item{...}{other filter description characteristics, possibly including Rp #' for dB of pass band ripple or Rs for dB of stop band ripple, depending on #' filter type (Butterworth, Chebyshev, etc.).} #' } #' #' @seealso \code{\link{filter}}, \code{\link{butter}} and #' \code{\link{buttord}}, \code{\link{cheby1}} and \code{\link{cheb1ord}}, #' \code{\link{ellip}} and \code{\link{ellipord}}. #' #' @examples #' filt <- FilterSpecs(3, 0.1, "low") #' #' @author Tom Short, \email{tshort@@eprisolutions.com},\cr #' renamed and adapted by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com} #' #' @export FilterSpecs <- function(n, Wc, type, ...) { res <- list(n = n, Wc = Wc, type = type, ...) class(res) <- "FilterSpecs" res } gsignal/R/welchwin.R0000644000176200001440000000710314420222025014034 0ustar liggesusers# welchwin.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2007 Muthiah Annamalai # Copyright (C) 2008-2009 Mike Gross # Copyright (C) 2008-2009 Peter V. Lanspeary # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191210 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Welch window #' #' Return the filter coefficients of a Welch window of length \code{n}. #' #' The Welch window is a polynomial window consisting of a single parabolic #' section: #' \deqn{w(k) = 1 - (k / N - 1)^2, n=0,1, ... n-1}. #' The optional argument specifies a "symmetric" window (the default) or a #' "periodic" window. A symmetric window has zero at each end and maximum in the #' middle, and the length must be an integer greater than 2. The variable #' \code{N} in the formula above is \code{(n-1)/2}. A periodic window wraps #' around the cyclic interval \code{0,1, ... m-1}, and is intended for use #' with the DFT. The length must be an integer greater than 1. The variable #' \code{N} in the formula above is \code{n/2}. #' #' @param n Window length, specified as a positive integer. #' @param method Character string. Window sampling method, specified as: #' \describe{ #' \item{"symmetric"}{(Default). Use this option when using windows for filter #' design.} #' \item{"periodic"}{This option is useful for spectral analysis because it #' enables a windowed signal to have the perfect periodic extension implicit #' in the discrete Fourier transform. When 'periodic' is specified, the #' function computes a window of length \code{n + 1} and returns the first #' \code{n} points.} #' } #' #' @return Welch window, returned as a vector. #' #' @examples #' #' w <- welchwin(64) #' plot (w, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' ws = welchwin(64,'symmetric') #' wp = welchwin(63,'periodic') #' plot (ws, type = "l", xlab = "Samples", ylab =" Amplitude") #' lines(wp, col="red") #' #' @author Muthiah Annamalai, \email{muthiah.annamalai@@uta.edu},\cr #' Mike Gross, \email{mike@@appl-tech.com},\cr #' Peter V. Lanspeary, \email{pvl@@mecheng.adelaide.edu.au}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export welchwin <- function(n, method = c("symmetric", "periodic")) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) stop("n must be an integer strictly positive") method <- match.arg(method) if (method == "periodic") { N <- n / 2 nmin <- 2 } else if (method == "symmetric") { N <- (n - 1) / 2 nmin <- 3 } else { stop("method must be either 'periodic' or 'symmetric'") } ## Periodic window is not properly defined for m < 2. ## Symmetric window is not properly defined for m < 3. if (n < nmin) { stop(paste("n must be an integer greater than", nmin)) } k <- 0:(n - 1) w <- 1 - ((k - N) / N)^2 w } gsignal/R/square.R0000644000176200001440000000550314420222025013516 0ustar liggesusers# square.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2006 Paul Kienzle # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191127 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Square wave #' #' Generate a square wave of period \eqn{2\pi} with limits +1 and -1. #' #' \code{y <- square(t)} generates a square wave with period \eqn{2\pi} for the #' elements of the time array \code{t}. #' \code{square} is similar to the sine function but creates a square wave with #' values of –1 and 1. #' #' \code{y <- square(t, duty)} generates a square wave with specified duty cycle #' \code{duty}. The duty cycle is the percent of the signal period in which the #' square wave is positive. #' \if{latex}{ #' \deqn{duty cycle = \frac{ontime * 100}{ontime + offtime}} #' } #' \if{html}{\preformatted{ #' ontime * 100 #' duty cycle = ---------------- #' ontime + offtime #' }} #' #' @param t Time array, specified as a vector. #' @param duty Duty cycle, specified as a real scalar from 0 to 100. Default: #' 50. #' #' @return Square wave, returned as a vector. #' #' @examples #' #' ## Create a vector of 100 equally spaced numbers from 0 to 3pi. #' ## Generate a square wave with a period of 2pi. #' t <- seq(0, 3*pi, length.out = 100) #' y <- square(t) #' plot(t/pi, y, type="l", xlab = expression(t/pi), ylab = "") #' lines (t/pi, sin(t), col = "red") #' #' ## Generate a 30 Hz square wave sampled at 1 kHz for 70 ms. #' ## Specify a duty cycle of 37%. #' ## Add white Gaussian noise with a variance of 1/100. #' t <- seq(0, 0.07, 1/1e3) #' y <- square(2 * pi * 30 * t, 37) + rnorm(length(t)) / 10 #' plot(t, y, type="l", xlab = "", ylab = "") #' #' @author Paul Kienzle.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export square <- function(t, duty = 50) { if (length(t) <= 0) stop("t must be a vector with length > 0") if (!isScalar(duty) || duty < 0 || duty > 100) stop("width must be a scalar between 0 and 100") duty <- duty / 100 t <- t / (2 * pi) y <- rep(1L, length(t)) y[t - floor(t) >= duty] <- -1 y } gsignal/R/peak2peak.R0000644000176200001440000000665114420222025014066 0ustar liggesusers# peak2peak.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2014 Georgios Ouzounis # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200110 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Maximum-to-minimum difference #' #' Compute the maximum-to-minimum difference of the input data \code{x}. #' #' The input \code{x} can be a vector, a matrix or an array. If the input is a #' vector, a single value is returned representing the maximum-to-minimum #' difference of the vector. If the input is a matrix or an array, a vector or #' an array of values is returned representing the maximum-to-minimum #' differences of the dimensions of \code{x} indicated by the \code{MARGIN} #' argument. #' #' Support for complex valued input is provided. In this case, the function #' \code{peak2peak} identifies the maximum and minimum in complex magnitude, and #' then subtracts the complex number with the minimum modulus from the complex #' number with the maximum modulus. #' #' @param x the data, expected to be a vector, a matrix, an array. #' @param MARGIN a vector giving the subscripts which the function will be #' applied over. E.g., for a matrix 1 indicates rows, 2 indicates columns, #' c(1, 2) indicates rows and columns. Where \code{x} has named dimnames, it #' can be a character vector selecting dimension names. Default: 2 (columns) #' #' @return Vector or array of values containing the maximum-to-minimum #' differences of the specified \code{MARGIN} of \code{x}. #' #' @examples #' ## numeric vector #' x <- c(1:5) #' pp <- peak2peak(x) #' #' ## numeric matrix #' x <- matrix(c(1,2,3, 100, 150, 200, 1000, 1500, 2000), 3, 3) #' pp <- peak2peak(x) #' pp <- peak2peak(x, 1) #' #' ## numeric array #' x <- array(c(1, 1.5, 2, 100, 150, 200, 1000, 1500, 2000, #' 10000, 15000, 20000), c(2,3,2)) #' pp <- peak2peak(x, 1) #' pp <- peak2peak(x, 2) #' pp <- peak2peak(x, 3) #' #' ## complex input #' x <- c(1+1i, 2+3i, 3+5i, 4+7i, 5+9i) #' pp <- peak2peak(x) #' #' @author Georgios Ouzounis, \email{ouzounis_georgios@@hotmail.com}.\cr #' Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export peak2peak <- function(x, MARGIN = 2) { if (!(is.numeric(x) || is.complex(x)) || !(is.vector(x) || is.matrix(x) || is.array(x))) { stop("x must be a numeric or complex vector, matrix or array") } if (!isPosscal(MARGIN) || !isWhole(MARGIN)) { stop("MARGIN must be a positive scalar") } mm <- function(a) max(a) - min(a) cmm <- function(a) a[which.max(abs(a))] - a[which.min(abs(a))] if (is.vector(x)) { x <- as.matrix(x) MARGIN <- 2 } if (is.numeric(x)) { y <- apply(x, MARGIN, mm) } else { y <- apply(x, MARGIN, cmm) } y } gsignal/R/ellipord.R0000644000176200001440000001454514420222025014036 0ustar liggesusers# ellipord.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2001 Paulo Neis # Copyright (C) 2018 Charles Praplan # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200527 Geert van Boxtel First version for v0.1.0 # 20200708 GvB renamed IIRfspec to FilterSpecs #------------------------------------------------------------------------------ #' Elliptic Filter Order #' #' Compute elliptic filter order and cutoff for the desired #' response characteristics. #' #' @param Wp,Ws pass-band and stop-band edges. For a low-pass or high-pass #' filter, \code{Wp} and \code{Ws} are scalars. For a band-pass or #' band-rejection filter, both are vectors of length 2. For a low-pass filter, #' \code{Wp < Ws}. For a high-pass filter, \code{Ws > Wp}. For a band-pass #' \code{(Ws[1] < Wp[1] < Wp[2] < Ws[2])} or band-reject \code{(Wp[1] < Ws[1] #' < Ws[2] < Wp[2])} filter design, \code{Wp} gives the edges of the pass #' band, and \code{Ws} gives the edges of the stop band. For digital filters, #' frequencies are normalized to [0, 1], corresponding to the range [0, fs/2]. #' In case of an analog filter, all frequencies are specified in radians per #' second. #' @param Rp allowable decibels of ripple in the pass band. #' @param Rs minimum attenuation in the stop band in dB. #' @param plane "z" for a digital filter or "s" for an analog filter. #' #' @return A list of class \code{\link{FilterSpecs}} with the following list #' elements: #' \describe{ #' \item{n}{filter order} #' \item{Wc}{cutoff frequency} #' \item{type}{filter type, one of \code{"low"}, \code{"high"}, \code{"stop"}, #' or \code{"pass"}.} #' \item{Rp}{dB of passband ripple.} #' \item{Rs}{dB of stopband ripple.} #' } #' @examples #' fs <- 10000 #' spec <- ellipord(1000/(fs/2), 1200/(fs/2), 0.5, 29) #' ef <- ellip(spec) #' hf <- freqz(ef, fs = fs) #' plot(c(0, 1000, 1000, 0, 0), c(0, 0, -0.5, -0.5, 0), #' type = "l", xlab = "Frequency (Hz)", ylab = "Attenuation (dB)", #' col = "red", ylim = c(-35,0), xlim = c(0,2000)) #' lines(c(5000, 1200, 1200, 5000, 5000), c(-1000, -1000, -29, -29, -1000), #' col = "red") #' lines(hf$w, 20*log10(abs(hf$h))) #' #' @author Paulo Neis, \email{p_neis@@yahoo.com.br},\cr #' adapted by Charles Praplan.\cr #' Conversion to R by Tom Short,\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{buttord}}, \code{\link{cheb1ord}}, #' \code{\link{cheb2ord}}, \code{\link{ellip}} #' #' @export ellipord <- function(Wp, Ws, Rp, Rs, plane = c("z", "s")) { #input validation plane <- match.arg(plane) if (! (is.vector(Wp) && is.vector(Ws) && (length(Wp) == length(Ws)))) { stop("Wp and Ws must both be scalars or vectors of length 2") } if (! ((length(Wp) == 1) || (length(Wp) == 2))) { stop("Wp and Ws must both be scalars or vectors of length 2") } if (plane == "z" && !(is.numeric(Wp) && all(Wp >= 0) && all(Wp <= 1))) { stop("all elements of Wp must be in the range [0,1]") } if (plane == "z" && !(is.numeric(Ws) && all(Ws >= 0) && all(Ws <= 1))) { stop("all elements of Ws must be in the range [0,1]") } if (plane == "s" && !(is.numeric(Wp) && all(Wp >= 0))) { stop("all elements of Wp must be non-negative") } if (plane == "s" && !(is.numeric(Ws) && all(Ws >= 0))) { stop("all elements of Ws must be non-negative") } if ((length(Wp) == 2) && (Wp[2] <= Wp[1])) { stop("Wp[1] must be smaller than Wp[2]") } if ((length(Ws) == 2) && (Ws[2] <= Ws[1])) { stop("Ws[1] must be smaller than Ws[2]") } if ((length(Wp) == 2) && (all(Wp > Ws) || all(Ws > Wp))) { stop("Wp must be contained by Ws or Ws must be contained by Wp") } if (plane == "s") { # No prewarp in case of analog filter Wpw <- Wp Wsw <- Ws } else { ## sampling frequency of 2 Hz T <- 2 Wpw <- (2 / T) * tan(pi * Wp / T) # prewarp Wsw <- (2 / T) * tan(pi * Ws / T) # prewarp } ## pass/stop band to low pass filter transform: if (length(Wpw) == 2 && length(Wsw) == 2) { ## Band-pass filter if (Wpw[1] > Wsw[1]) { type <- "pass" ## Modify band edges if not symmetrical. For a band-pass filter, ## the lower or upper stopband limit is moved, resulting in a smaller ## stopband than the caller requested. if (Wpw[1] * Wpw[2] < Wsw[1] * Wsw[2]) { Wsw[2] <- Wpw[1] * Wpw[2] / Wsw[1] } else { Wsw[1] <- Wpw[1] * Wpw[2] / Wsw[2] } wp <- Wpw[2] - Wpw[1] ws <- Wsw[2] - Wsw[1] ## Band-stop / band-reject / notch filter } else { type <- "stop" ## Modify band edges if not symmetrical. For a band-stop filter, ## the lower or upper passband limit is moved, resulting in a smaller ## rejection band than the caller requested. if (Wpw[1] * Wpw[2] > Wsw[1] * Wsw[2]) { Wpw[2] <- Wsw[1] * Wsw[2] / Wpw[1] } else { Wpw[1] <- Wsw[1] * Wsw[2] / Wpw[2] } w02 <- Wpw[1] * Wpw[2] wp <- w02 / (Wpw[2] - Wpw[1]) ws <- w02 / (Wsw[2] - Wsw[1]) } ws <- ws / wp wp <- 1 ## High-pass filter } else if (Wpw > Wsw) { type <- "high" wp <- Wsw ws <- Wpw ## Low-pass filter } else { type <- "low" wp <- Wpw ws <- Wsw } k <- wp / ws k1 <- sqrt(1 - k^2) q0 <- (1 / 2) * ((1 - sqrt(k1)) / (1 + sqrt(k1))) q <- q0 + 2 * q0^5 + 15 * q0^9 + 150 * q0^13 D <- (10 ^ (0.1 * Rs) - 1) / (10 ^ (0.1 * Rp) - 1) n <- ceiling(log10(16 * D) / log10(1 / q)) if (plane == "s") { # No prewarp in case of analog filter Wc <- Wpw } else { # Inverse frequency warping for discrete-time filter Wc <- atan(Wpw * (T / 2)) * (T / pi) } FilterSpecs(n = n, Wc = Wc, type = type, plane = plane, Rp = Rp, Rs = Rs) } gsignal/R/sawtooth.R0000644000176200001440000000600314420222025014062 0ustar liggesusers# sawtooth.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2007 Juan Aguado # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191127 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Sawtooth or triangle wave #' #' Returns samples of the sawtooth function at the times indicated by \code{t}. #' #' The code \code{y <- sawtooth(t)} generates a sawtooth wave with period #' \eqn{2\pi} for the elements of the time array \code{t}. \code{sawtooth()} is #' similar to the sine function but creates a sawtooth wave with peaks of –1 and #' 1. The sawtooth wave is defined to be –1 at multiples of \eqn{2\pi} and to #' increase linearly with time with a slope of \eqn{1/\pi} at all other times. #' #' \code{y <- sawtooth(t, width)} generates a modified triangle wave with the #' maximum location at each period controlled by \code{width}. Set \code{width} #' to 0.5 to generate a standard triangle wave. #' #' @param t Sample times of unit sawtooth wave specified by a vector. #' @param width Real number between 0 and 1 which specifies the point between 0 #' and \eqn{2 \pi} where the maximum is. The function increases linearly from #' -1 to 1 in the interval from 0 to \eqn{ 2 * \pi * width}, and decreases #' linearly from 1 to -1 in the interval from \eqn{2 * \pi * width} to \eqn{2 #' * \pi}. Default: 1 (standard sawtooth). #' #' @return Sawtooth wave, returned as a vector. #' #' @examples #' #' T <- 10 * (1 / 50) #' fs <- 1000 #' t <- seq(0, T-1/fs, 1/fs) #' y <- sawtooth(2 * pi * 50 *t) #' plot(t, y, type="l", xlab = "", ylab = "", main = "50 Hz sawtooth wave") #' #' T <- 10 * (1 / 50) #' fs <- 1000 #' t <- seq(0, T-1/fs, 1/fs) #' y <- sawtooth(2 * pi * 50 * t, 1/2) #' plot(t, y, type="l", xlab = "", ylab = "", main = "50 Hz triangle wave") #' #' @author Juan Aguado.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export sawtooth <- function(t, width = 1) { if (length(t) <= 0) stop("t must be a vector with length > 0") if (!isScalar(width) || width < 0 || width > 1) stop("width must be a scalar between 0 and 1") t <- (t / (2 * pi)) %% 1 y <- rep(0L, length(t)) if (width != 0) { y[t < width] <- 2 * t[t < width] / width - 1 } if (width != 1) { y[t >= width] <- -2 * (t[t >= width] - width) / (1 - width) + 1 } y } gsignal/R/impinvar.R0000644000176200001440000001145414420222025014045 0ustar liggesusers# impinvar.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 1994-2017 John W. Eaton # Copyright (C) 2007 Ben Abbott # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200616 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Impulse invariance method for A/D filter conversion #' #' Convert analog filter with coefficients b and a to digital, conserving #' impulse response. #' #' Because \code{impinvar} is generic, it can also accept input of class #' \code{\link{Arma}}. #' #' @param b coefficients of numerator polynomial #' @param a coefficients of denominator polynomial #' @param fs sampling frequency (Default: 1 Hz) #' @param tol tolerance. Default: 0.0001 #' @param ... additional arguments (not used) #' #' @return A list of class \code{\link{Arma}} containing numerator and #' denominator polynomial filter coefficients of the A/D converted filter. #' #' @examples #' f <- 2 #' fs <- 10 #' but <- butter(6, 2 * pi * f, 'low', 's') #' zbut <- impinvar(but, fs) #' freqz(zbut, n = 1024, fs = fs) #' #' @author Tony Richardson, \email{arichard@@stark.cc.oh.us},\cr #' Ben Abbott, \email{bpabbott@@mac.com},\cr #' adapted by John W. Eaton.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com} #' #' @seealso \code{\link{invimpinvar}} #' #' @rdname impinvar #' @export impinvar <- function(b, ...) UseMethod("impinvar") #' @rdname impinvar #' @export impinvar.Arma <- function(b, ...) impinvar(b$b, b$a, ...) #' @rdname impinvar #' @export impinvar.default <- function(b, a, fs = 1, tol = 0.0001, ...) { if (!isPosscal(fs)) { stop("fs must be a positive scalar") } if (!isPosscal(tol)) { stop("tol must be a positive scalar") } ts <- 1 / fs rpk_in <- residue(b, a) n <- length(rpk_in$r) if (length(rpk_in$k) > 0) { stop("Order numerator >= order denominator") } r_out <- rep(0L, n) p_out <- rep(0L, n) k_out <- 0 i <- 1 while (i <= n) { m <- 1 first_pole <- rpk_in$p[i] while (i < n && abs(first_pole - rpk_in$p[i + 1]) < tol) { i <- i + 1 m <- m + 1 } rpk_out <- z_res(rpk_in$r[(i - m + 1):i], first_pole, ts) k_out <- k_out + rpk_out$k p_out[(i - m + 1):i] <- rpk_out$p r_out[(i - m + 1):i] <- rpk_out$r i <- i + 1 } ba <- inv_residue(r_out, p_out, k_out, tol) a <- zapIm(ba$a) b <- zapIm(ba$b) b <- b[1:(length(b) - 1)] Arma(b, a) } z_res <- function(r_in, sm, ts) { p_out <- exp(ts * sm) n <- length(r_in) r_out <- rep(0L, n) k_out <- r_in[1] * ts r_out[1] <- r_in[1] * ts * p_out if (n > 1) { for (i in 2:n) { r_out[1:i] <- r_out[1:i] + r_in[i] * rev(h1_z_deriv(i - 1, p_out, ts)) } } list(r = r_out, p = p_out, k = k_out) } # The following functions are # Copyright (C) 2007 R.G.H. Eschauzier # Conversion to R by Geert van Boxtel h1_deriv <- function(n) { b <- pracma::fact(n) * sapply(0:n, function(k) pracma::nchoosek(n, k)) b <- b * (-1)^n b } h1_z_deriv <- function(n, p, ts) { d <- (-1)^n for (i in 1:(n - 1)) { d <- c(d, 0) d <- d + prepad(pracma::polyder(d), i + 1, 0, 2) } b <- rep(0L, n + 1) for (i in 1:n) { b <- b + d[i] * prepad(h1_deriv(n - i + 1), n + 1, 0, 2) } b <- b * ts ^ (n + 1) / pracma::fact(n) b <- b * p^seq(n + 1, 1, -1) b } inv_residue <- function(r_in, p_in, k_in, tol) { n <- length(r_in) k <- 0 if (length(k_in) == 1) { k <- k_in[1] } else if (length(k_in) > 1) { stop("Order numerator > order denominator") } a_out <- poly(p_in) b_out <- rep(0L, n + 1) b_out <- b_out + k * a_out i <- 1 while (i <= n) { term <- c(1, -p_in[i]) p <- r_in[i] * pracma::deconv(a_out, term)$q p <- prepad(p, n + 1, 0, 2) b_out <- b_out + p m <- 1 mterm <- term first_pole <- p_in[i] while (i < n && abs(first_pole - p_in[i + 1]) < tol) { i <- i + 1 m <- m + 1 mterm <- conv(mterm, term) p <- r_in[i] * pracma::deconv(a_out, mterm)$q p <- prepad(p, n + 1, 0, 2) b_out <- b_out + p } i <- i + 1 } Arma(b_out, a_out) } gsignal/R/tukeywin.R0000644000176200001440000000641014420222025014073 0ustar liggesusers# tukeywin.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2007 Laurent Mazet # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200101 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Tukey (tapered cosine) window #' #' Return the filter coefficients of a Tukey window (also known as the #' cosine-tapered window) of length \code{n}. #' #' The Tukey window, also known as the tapered cosine window, can be regarded as #' a cosine lobe that is convolved with a rectangular window. \code{r} defines #' the ratio between the constant section and and the cosine section. It has to #' be between 0 and 1. The function returns a Hann window for \code{r} equal to #' 1 and a rectangular window for \code{r} equal to 0. #' #' @param n Window length, specified as a positive integer. #' @param r Cosine fraction, specified as a real scalar. The Tukey window is a #' rectangular window with the first and last \code{r / 2} percent of the #' samples equal to parts of a cosine. For example, setting \code{r = 0.5} #' (default) produces a Tukey window where 1/2 of the entire window length #' consists of segments of a phase-shifted cosine with period 2r = 1. If you #' specify r <= 0, an n-point rectangular window is returned. If you specify r #' >= 1, an n-point von Hann window is returned. #' #' @return Tukey window, returned as a vector. #' #' @examples #' #' n <- 128 #' t0 <- tukeywin(n, 0) # Equivalent to a rectangular window #' t25 <- tukeywin(n, 0.25) #' t5 <- tukeywin(n) # default r = 0.5 #' t75 <- tukeywin(n, 0.75) #' t1 <- tukeywin(n, 1) # Equivalent to a Hann window #' plot(t0, type = "l", xlab = "Samples", ylab =" Amplitude", ylim=c(0,1.2)) #' lines(t25, col = 2) #' lines(t5, col = 3) #' lines(t75, col = 4) #' lines(t1, col = 5) #' #' @author Laurent Mazet, \email{mazet@@crm.mot.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export tukeywin <- function(n, r = 1 / 2) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) stop("n must be an integer strictly positive") if (r > 1) { r <- 1 } else if (r < 0) { r <- 0 } if (r == 0) { w <- rep(1L, n) } else if (r == 1) { w <- hann(n) } else { if (n == 1) { w <- 1 } else { # cosine-tapered window k <- seq(0, 1, length.out = n)[1:(n / 2)] w <- (1 + cos(pi * (2 * k / r - 1))) / 2 idx <- (floor(r * (n - 1) / 2) + 2):length(w) if (!any(idx > length(w))) { w[idx] <- 1 } w <- c(w, rep(1, n %% 2), rev(w)) } } w } gsignal/R/dst.R0000644000176200001440000000772614420222025013021 0ustar liggesusers# dct.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Author: Paul Kienzle (2006) # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201016 GvB setup for gsignal v0.1.0 # 20210506 GvB use matrix() instead of as.matrix() #------------------------------------------------------------------------------ #' Discrete Sine Transform #' #' Compute the discrete sine transform of a signal. #' #' The discrete sine transform (DST) is closely related to the discrete Fourier #' transform. but using a purely real matrix. It is equivalent to the imaginary #' parts of a DFT of roughly twice the length. #' #' The DST has four standard variants. This function implements the DCT-I #' according to the definition in [1], which is the most common variant, and #' the original variant first proposed for image processing. #' #' The 'Matlab' documentation for the DST warns that the use of the function is #' not recommended. They do not state the reason why, but it is likely that use #' of the discrete cosine transform (DCT)is preferred for image processing. #' Because cos(0) is 1, the first coefficient of the DCT (II) is the mean of the #' values being transformed. This makes the first coefficient of each 8x8 block #' represent the average tone of its constituent pixels, which is obviously a #' good start. Subsequent coefficients add increasing levels of detail, starting #' with sweeping gradients and continuing into increasingly fiddly patterns, and #' it just so happens that the first few coefficients capture most of the signal #' in photographic images. Sin(0) is 0, so the DSTs start with an offset of 0.5 #' or 1, and the first coefficient is a gentle mound rather than a flat plain. #' That is unlikely to suit ordinary images, and the result is that DSTs require #' more coefficients than DCTs to encode most blocks. This explanation was #' provided by Douglas Bagnall on Stackoverflow. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param n transform length, specified as a positive integer scalar. Default: #' \code{NROW(x)}. #' #' @return Discrete sine transform, returned as a vector or matrix. #' #' @examples #' x <- matrix(seq_len(100) + 50 * cos(seq_len(100) * 2 * pi / 40)) #' ct <- dct(x) #' st <- dst(x) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references [1] \url{https://en.wikipedia.org/wiki/Discrete_sine_transform} #' #' @seealso \code{\link{idst}} #' #' @export dst <- function(x, n = NROW(x)) { # check parameters if (!(is.vector(x) || is.matrix(x)) || !(is.numeric(x) || is.complex(x))) { stop("x must be a numeric or complex vector or matrix") } else { realx <- is.numeric(x) } if (is.vector(x)) { vec <- TRUE x <- matrix(x, ncol = 1) } else { vec <- FALSE } nr <- nrow(x) nc <- ncol(x) if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer") } if (n != nr) { x <- postpad(x, n) } y <- stats::mvfft(rbind(rep(0, nc), x, rep(0, nc), -matrix(pracma::flipud(x), ncol = nc))) / -2i y <- y[2:(nr + 1), , drop = FALSE] if (realx) { y <- Re(y) } if (vec) { y <- as.vector(y) } y } gsignal/R/czt.R0000644000176200001440000001160514420222025013016 0ustar liggesusers# czt.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2004 Daniel Gunyan # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201011 GvB setup for gsignal v0.1.0 # 20210506 GvB use matrix() instead of as.matrix() #------------------------------------------------------------------------------ #' Chirp Z-transform #' #' Compute the Chirp Z-transform along a spiral contour on the z-plane. #' #' The chirp Z-transform (CZT) is a generalization of the discrete Fourier #' transform (DFT). While the DFT samples the Z plane at uniformly-spaced points #' along the unit circle, the chirp Z-transform samples along spiral arcs in the #' Z-plane, corresponding to straight lines in the S plane. The DFT, real DFT, #' and zoom DFT can be calculated as special cases of the CZT[1]. For the #' specific case of the DFT, \code{a = 0}, \code{m = NCOL(x)}, and \code{w = 2 * #' pi / m}[2, p. 656]. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param m transform length, specified as a positive integer scalar. Default: #' \code{NROW(x)}. #' @param w ratio between spiral contour points in each step (i.e., radius #' increases exponentially, and angle increases linearly), specified as a #' complex scalar. Default: \code{exp(0-1i * 2 * pi / m)}. #' @param a initial spiral contour point, specified as a complex scalar. #' Default: 1. #' #' @return Chirp Z-transform, returned as a vector or matrix. #' #' @examples #' fs <- 1000 # sampling frequency #' secs <- 10 # number of seconds #' t <- seq(0, secs, 1/fs) # time series #' x <- sin(100 * 2 * pi * t) + runif(length(t)) # 100 Hz signal + noise #' m <- 32 # n of points desired #' f0 <- 75; f1 <- 175; # desired freq range #' w <- exp(-1i * 2 * pi * (f1 - f0) / ((m - 1) * fs)) # freq step of f1-f0/m #' a <- exp(1i * 2 * pi * f0 / fs); # starting at freq f0 #' y <- czt(x, m, w, a) #' #' # compare DFT and FFT #' fs <- 1000 #' h <- as.numeric(fir1(100, 125/(fs / 2), type = "low")) #' m <- 1024 #' y <- stats::fft(postpad(h, m)) #' #' f1 <- 75; f2 <- 175; #' w <- exp(-1i * 2 * pi * (f2 - f1) / (m * fs)) #' a <- exp(1i * 2 * pi * f1 / fs) #' z <- czt(h, m, w, a) #' #' fn <- seq(0, m - 1, 1) / m #' fy <- fs * fn #' fz = (f2 - f1) * fn + f1 #' plot(fy, 10 * log10(abs(y)), type = "l", xlim = c(50, 200), #' xlab = "Frequency", ylab = "Magnitude (dB") #' lines(fz, 10 * log10(abs(z)), col = "red") #' legend("topright", legend = c("FFT", "CZT"), col=1:2, lty = 1) #' #' @author Daniel Gunyan.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references [1] \url{https://en.wikipedia.org/wiki/Chirp_Z-transform}\cr #' [2]Oppenheim, A.V., Schafer, R.W., and Buck, J.R. (1999). Discrete-Time #' Signal Processing, 2nd edition. Prentice-Hall. #' #' @export czt <- function(x, m = NROW(x), w = exp(complex(real = 0, imaginary = -2 * pi / m)), a = 1) { # check parameters if (!(is.vector(x) || is.matrix(x)) || !(is.numeric(x) || is.complex(x))) { stop("x must be a numeric or complex vector or matrix") } if (is.vector(x)) { x <- matrix(x, ncol = 1) vec <- TRUE } else { vec <- FALSE } n <- nrow(x) if (!isPosscal(m) || !isWhole(m)) { stop("m must be a positive integer") } if (!(is.numeric(w) || is.complex(w)) || length(w) != 1) { stop("w must be a single complex value") } w <- as.complex(w) if (!(is.numeric(a) || is.complex(a)) || length(a) != 1) { stop("a must be a single complex value") } a <- as.complex(a) # indexing to make the statements a little more compact N <- seq(0, n - 1, 1) + n NM <- seq(- (n - 1), (m - 1), 1) + n M <- seq(0, m - 1, 1) + n nfft <- nextpow2(n + m - 1) # fft pad W2 <- w ^ ((seq(- (n - 1), max(m - 1, n - 1), 1)^2) / 2) # chirp fg <- stats::mvfft(postpad(x * (a ^ - (N - n)) * W2[N], nfft)) fw <- stats::fft(postpad(1 / W2[NM], nfft)) gg <- imvfft(fg * fw) y <- gg[M, ] * W2[M] if (vec) { y <- as.vector(y) } y } gsignal/R/unshiftdata.R0000644000176200001440000000677214420222025014541 0ustar liggesusers# unshiftdata.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2014 Georgios Ouzounis # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191202 Geert van Boxtel First version for v0.1.0 # 20200507 GvB Bugfix #------------------------------------------------------------------------------ #' Inverse of shiftdata #' #' Reverse what has been done by \code{shiftdata()}. #' #' \code{unshiftdata} restores the orientation of the data that was shifted with #' shiftdata. The permutation vector is given by \code{perm}, and \code{nshifts} #' is the number of shifts that was returned from \code{shiftdata()}. #' #' \code{unshiftdata} is meant to be used in tandem with \code{shiftdata}. These #' functions are useful for creating functions that work along a certain #' dimension, like filter, goertzel, sgolayfilt, and sosfilt. These functions #' are useful for creating functions that work along a certain dimension, like #' \code{\link{filter}}, \code{\link{sgolayfilt}}, and \code{\link{sosfilt}}. #' #' @param sd A list of objects named \code{x}, \code{perm}, and \code{nshifts}, #' as returned by \code{shiftdata()} #' #' @return Array with the same values and dimensions as passed to a previous #' call to \code{shiftdata}. #' #' @examples #' #' ## create a 3x3 magic square #' x <- pracma::magic(3) #' ## Shift the matrix x to work along the second dimension. #' ## The permutation vector, perm, and the number of shifts, nshifts, #' ## are returned along with the shifted matrix. #' sd <- shiftdata(x, 2) #' #' ## Shift the matrix back to its original shape. #' y <- unshiftdata(sd) #' #' ## Rearrange Array to Operate on First Nonsingleton Dimension #' x <- 1:5 #' sd <- shiftdata(x) #' y <- unshiftdata(sd) #' #' @author Georgios Ouzounis, \email{ouzounis_georgios@@hotmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{shiftdata}} #' #' @export unshiftdata <- function(sd) { nm <- names(sd) if (!is.list(sd) || !("x" %in% nm && "perm" %in% nm && "nshifts" %in% nm)) stop("sd must be a list with elements x, perm and nshifts") if (length(sd$perm) > 0 && !anyNA(sd$perm)) { if (!isWhole(sd$perm)) stop(paste0(deparse(substitute(sd)), "$perm must be a vector of integers")) dimx <- sd$perm[1] } else if (length(sd$nshifts) > 0) { if (!isWhole(sd$nshifts)) stop(paste0(deparse(substitute(sd)), "$nshifts must be an integer")) dimx <- sd$nshifts + 1 } else { stop(paste0("Either perm or nshifts must not be empty")) } perm <- dimx if (dimx - 1 >= 1) { perm <- c(dimx, 1:(dimx - 1)) } d1 <- dimx + 1 d2 <- (length(dim(sd$x))) if (d1 <= d2) perm <- c(perm, d1:d2) iaperm <- function(x, p) { p[p] <- seq_along(dim(x)) aperm(x, p) } out <- iaperm(sd$x, perm) out } gsignal/R/marcumq.R0000644000176200001440000000302214420222025013655 0ustar liggesusers# marcumq.R # Copyright (C) 2020 William Asquith # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201123 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Marcum Q function #' #' Compute the generalized Marcum Q function #' #' The code for this function was taken from the help file of the \code{cdfkmu} #' function in the \code{lmomco} package, based on a suggestion of Daniel #' Wollschlaeger. #' #' @param a,b input arguments, specified as non-negative real numbers. #' @param m order, specified as a positive integer #' #' @return Marcum Q function. #' #' @examples #' mq <- marcumq(12.4, 12.5) #' #' @author William Asquith, \email{william.asquith@@ttu.edu}. #' #' @references \url{https://cran.r-project.org/package=lmomco} # #' @export marcumq <- function(a, b, m = 1) { stats::pchisq(b^2, df = 2 * m, ncp = a^2, lower.tail = FALSE) } gsignal/R/filter.R0000644000176200001440000002522214420222025013503 0ustar liggesusers# filter.R # Copyright (C) 2020-2021 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200208 GvB setup for gsignal v0.1.0 # 20200413 GvB added S3 method for Sos # 20210319 GvB new setup using filter.cpp to handle initial conditions # the function now also has the options to return the # final conditions # 20210515 GvB check return value of rfilter # 20210712 GvB copy attributes of input x to output y # 20210724 GvB allow filtering complex signals and coefficients #------------------------------------------------------------------------------ #' Filter a signal #' #' Apply a 1-D digital filter compatible with 'Matlab' and 'Octave'. #' #' The filter is a direct form II transposed implementation of the standard #' linear time-invariant difference equation: #' \if{latex}{ #' \deqn{\sum_{k=0}^{N} a(k+1) y(n-k) + \sum_{k=0}^{M} b(k+1) x(n-k) = 0; 1 #' \le n \le length(x)} #' } #' \if{html}{\preformatted{ #' N M #' SUM a(k+1)y(n-k) + SUM b(k+1)x(n-k) = 0; 1 <= n <= length(x) #' k=0 k=0 #' }} #' where \code{N = length(a) - 1} and \code{M = length(b) - 1}. #' #' The initial and final conditions for filter delays can be used to filter data #' in sections, especially if memory limitations are a consideration. See the #' examples. #' #' @param filt For the default case, the moving-average coefficients of an ARMA #' filter (normally called \code{b}), specified as a numeric or complex #' vector. Generically, \code{filt} specifies an arbitrary filter operation. #' @param a the autoregressive (recursive) coefficients of an ARMA filter, #' specified as a numeric or complex vector. If \code{a[1]} is not equal to 1, #' then filter normalizes the filter coefficients by \code{a[1]}. Therefore, #' \code{a[1]} must be nonzero. #' @param x the input signal to be filtered, specified as a numeric or complex #' vector or matrix. If \code{x} is a matrix, each column is filtered. #' @param zi If \code{zi} is provided, it is taken as the initial state of the #' system and the final state is returned as zf. The state vector is a vector #' or a matrix (depending on \code{x}) whose length or number of rows is equal #' to the length of the longest coefficient vector \code{b} or \code{a} minus #' one. If \code{zi} is not supplied (NULL), the initial state vector is set #' to all zeros. Alternatively, \code{zi} may be the character string #' \code{"zf"}, which specifies to return the final state vector even though #' the initial state vector is set to all zeros. Default: NULL. #' @param ... additional arguments (ignored). #' #' @return The filtered signal, of the same dimensions as the input signal. In #' case the \code{zi} input argument was specified, a list with two elements #' is returned containing the variables \code{y}, which represents the output #' signal, and \code{zf}, which contains the final state vector or matrix. #' #' @examples #' bf <- butter(3, 0.1) # 10 Hz low-pass filter #' t <- seq(0, 1, len = 100) # 1 second sample #' x <- sin(2* pi * t * 2.3) + 0.25 * rnorm(length(t)) # 2.3 Hz sinusoid+noise #' z <- filter(bf, x) # apply filter #' plot(t, x, type = "l") #' lines(t, z, col = "red") #' #' ## specify initial conditions #' ## from Python scipy.signal.lfilter() documentation #' t <- seq(-1, 1, length.out = 201) #' x <- (sin(2 * pi * 0.75 * t * (1 - t) + 2.1) #' + 0.1 * sin(2 * pi * 1.25 * t + 1) #' + 0.18 * cos(2 * pi * 3.85 * t)) #' h <- butter(3, 0.05) #' lab <- max(length(h$b), length(h$a)) - 1 #' zi <- filtic(h$b, h$a, rep(1, lab), rep(1, lab)) #' z1 <- filter(h, x) #' z2 <- filter(h, x, zi * x[1]) #' plot(t, x, type = "l") #' lines(t, z1, col = "red") #' lines(t, z2$y, col = "green") #' legend("bottomright", legend = c("Original signal", #' "Filtered without initial conditions", #' "Filtered with initial conditions"), #' lty = 1, col = c("black", "red", "green")) #' #' @seealso \code{\link{filter_zi}}, \code{\link{sosfilt}} (preferred because it #' avoids numerical problems). #' #' @author Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @rdname filter #' @export filter <- function(filt, ...) UseMethod("filter") #' @rdname filter #' @method filter default #' @export filter.default <- function(filt, a, x, zi = NULL, ...) { if (!is.vector(filt) || ! is.vector(a)) { stop("b and a must be numeric vectors") } if (is.numeric(filt) && is.numeric(a)) { real_coefs <- TRUE } else if (is.complex(filt) || is.complex(a)) { real_coefs <- FALSE } else { stop("b and a must be numeric or complex") } la <- length(a) lb <- length(filt) lab <- max(la, lb) #save attributes of x atx <- attributes(x) if (is.null(x)) { return(NULL) } if (is.numeric(x)) { real_x <- TRUE } else if (is.complex(x)) { real_x <- FALSE } else { stop("x must be a numeric or complex vector or matrix") } if (is.vector(x)) { x <- as.matrix(x, ncol = 1) vec <- TRUE } else { vec <- FALSE } nrx <- NROW(x) ncx <- NCOL(x) if (is.null(nrx) || nrx <= 0) { return(x) } rzf <- (is.character(zi) && zi == "zf") if (!is.null(zi) && !is.numeric(zi) && ! is.complex(zi) && !rzf) { stop("invalid value for zi") } if (is.null(zi) || rzf) { if (is.numeric(x)) { zi <- matrix(0, lab - 1, ncx) } else if(is.complex(x)) { zi <- matrix(0 + 0i, lab - 1, ncx) } if (is.null(zi)) { rzf <- FALSE } } else if (!is.null(zi)) { rzf <- TRUE } if (is.vector(zi)) { zi <- as.matrix(zi, ncol = 1) } nrzi <- NROW(zi) nczi <- NCOL(zi) if (nrzi != lab - 1) { stop("zi must be of length max(length(a), length(b)) - 1") } if (nczi != ncx) { stop("number of columns of zi and x must agree") } while (length(a) > 1 && a[1] == 0) { a <- a[2:length(a)] } if (length(a) < 1 || a[1] == 0) { stop("There must be at least one nonzero element in the vector a") } if (a[1] != 1) { # Normalize the coefficients so a[1] == 1. filt <- filt / a[1] a <- a / a[1] } if (la <= 1 && nrzi <= 0) { retval <- filt[1] * x if (vec) retval <- as.vector(retval) return(retval) } if (real_coefs) { if (real_x) { # real filter coefs, real x y <- matrix(0, nrx, ncx) zf <- matrix(0, lab - 1, nczi) for (icol in seq_len(ncx)) { l <- .Call("_gsignal_rfilter", PACKAGE = "gsignal", filt, a, x[, icol], zi[, icol]) if (length(l) <= 0) { stop("Error filtering data") } y[, icol] <- l[["y"]] zf[, icol] <- l[["zf"]] } } else { # real filter coefs, complex x y <- matrix(0 + 0i, nrx, ncx) zf <- matrix(0 + 0i, lab - 1, nczi) for (icol in seq_len(ncx)) { re <- .Call("_gsignal_rfilter", PACKAGE = "gsignal", filt, a, Re(x[, icol]), Re(zi[, icol])) if (length(re) <= 0) { stop("Error filtering data") } im <- .Call("_gsignal_rfilter", PACKAGE = "gsignal", filt, a, Im(x[, icol]), Im(zi[, icol])) if (length(im) <= 0) { stop("Error filtering data") } y[, icol] <- re[["y"]] + 1i * im[["y"]] zf[, icol] <- re[["zf"]] + 1i * im[["zf"]] } } } else { if (real_x) { # complex filter coefs, real x y <- matrix(0 + 0i, nrx, ncx) zf <- matrix(0 + 0i, lab - 1, nczi) for (icol in seq_len(ncx)) { re <- .Call("_gsignal_rfilter", PACKAGE = "gsignal", Re(filt), Re(a), x[, icol], Re(zi[, icol])) if (length(re) <= 0) { stop("Error filtering data") } im <- .Call("_gsignal_rfilter", PACKAGE = "gsignal", Im(filt), Im(a), x[, icol], Im(zi[, icol])) if (length(im) <= 0) { stop("Error filtering data") } y[, icol] <- re[["y"]] + 1i * im[["y"]] zf[, icol] <- re[["zf"]] + 1i * im[["zf"]] } } else { # complex filter coefs, complex x # avoid one filtering operation y <- matrix(0 + 0i, nrx, ncx) zf <- matrix(0 + 0i, lab - 1, nczi) for (icol in seq_len(ncx)) { l1 <- .Call("_gsignal_rfilter", PACKAGE = "gsignal", Re(filt), Re(a), Re(x[, icol]), Re(zi[, icol])) if (length(l1) <= 0) { stop("Error filtering data") } l2 <- .Call("_gsignal_rfilter", PACKAGE = "gsignal", Im(filt), Im(a), Im(x[, icol]), Im(zi[, icol])) if (length(l2) <= 0) { stop("Error filtering data") } l3 <- .Call("_gsignal_rfilter", PACKAGE = "gsignal", Re(filt) + Im(filt), Re(a) + Im(a), Re(x[, icol]) + Im(x[, icol]), Re(zi[, icol]) + Im(zi[, icol])) if (length(l3) <= 0) { stop("Error filtering data") } y[, icol] <- l1[["y"]] - l2[["y"]] + + 1i * (l3[["y"]] - l1[["y"]] - l2[["y"]]) zf[, icol] <- l1[["zf"]] - l2[["zf"]] + + 1i * (l3[["zf"]] - l1[["zf"]] - l2[["zf"]]) } } } if (vec) { y <- as.vector(y) zf <- as.vector(zf) } if (!real_x || !real_coefs) { y <- zapIm(y) zf <- zapIm(zf) } # set attributes of y nd return attributes(y) <- atx if (rzf) { retval <- list(y = y, zf = zf) } else { retval <- y } retval } #' @rdname filter #' @method filter Arma #' @export filter.Arma <- function(filt, x, ...) # IIR filter(filt$b, filt$a, x, ...) #' @rdname filter #' @method filter Ma #' @export filter.Ma <- function(filt, x, ...) # FIR filter(unclass(filt), 1, x, ...) #' @rdname filter #' @method filter Sos #' @export filter.Sos <- function(filt, x, ...) { # Second-order sections if (filt$g != 1) { filt$sos[1, 1:3] <- filt$sos[1, 1:3] * filt$g } sosfilt(filt$sos, x, ...) } #' @rdname filter #' @method filter Zpg #' @export filter.Zpg <- function(filt, x, ...) # zero-pole-gain form filter(as.Arma(filt), x, ...) gsignal/R/bitrevorder.R0000644000176200001440000000472314420222025014550 0ustar liggesusers# bitrevorder.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2013-2019 Mike Miller # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200821 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Permute input to bit-reversed order #' #' Reorder the elements of the input vector in bit-reversed order. #' #' This function is equivalent to calling \code{digitrevorder(x, 2)}, and is #' useful for prearranging filter coefficients so that bit-reversed ordering #' does not have to be performed as part of an fft or ifft computation. #' #' @param x input data, specified as a vector. The length of \code{x} must be an #' integer power of 2. #' @param index.return logical indicating if the ordering index vector should be #' returned as well. Default: \code{FALSE}. #' #' @return The bit-reversed input vector. If \code{index.return = TRUE}, then #' a list containing the bit-reversed input vector (\code{y}), and the #' digit-reversed indices (\code{i}). #' #' @examples #' x <- 0:15 #' v <- bitrevorder(x) #' dec2bin <- function(x, l) #' substr(paste(as.integer(rev(intToBits(x))), collapse = ""), #' 32 - l + 1, 32) #' x_bin <- sapply(x, dec2bin, 4) #' v_bin <- sapply(v, dec2bin, 4) #' data.frame(x, x_bin, v, v_bin) #' #' @author Mike Miller.\cr #' Port to to by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{digitrevorder}}, \code{\link{fft}}, \code{\link{ifft}} #' #' @export bitrevorder <- function(x, index.return = FALSE) { if (!is.vector(x)) { stop("x must be a vector") } else if (trunc(log2(length(x))) != log2(length(x))) { stop("x must have length equal to an integer power of 2") } if (!is.logical(index.return)) { stop("index.return must be TRUE or FALSE") } digitrevorder(x, 2, index.return) } gsignal/R/sosfilt.R0000644000176200001440000001626214420222025013705 0ustar liggesusers# sosfilt.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200413 GvB setup for gsignal v0.1.0 # 20210329 GvB different setup for v0.3.0 including initial conditions # 20210712 GvB copy attributes of input x to output y # 20210724 GvB allow filtering complex signals #------------------------------------------------------------------------------ #' Second-order sections filtering #' #' One-dimensional second-order (biquadratic) sections IIR digital filtering. #' #' The filter function is implemented as a series of second-order filters #' with direct-form II transposed structure. It is designed to minimize #' numerical precision errors for high-order filters [1]. #' #' @param sos Second-order section representation, specified as an nrow-by-6 #' matrix, whose rows contain the numerator and denominator coefficients of #' the second-order sections:\cr \code{sos <- rbind(cbind(B1, A1), cbind(...), #' cbind(Bn, An))}, where \code{B1 <- c(b0, b1, b2)}, and \code{A1 <- c(a0, #' a1, a2)} for section 1, etc. The b0 entry must be nonzero for each section. #' @param x the input signal to be filtered, specified as a numeric or complex #' vector or matrix. If \code{x} is a matrix, each column is filtered. #' @param zi If \code{zi} is provided, it is taken as the initial state of the #' system and the final state is returned as zf. If \code{x} is a vector, #' \code{zi} must be a matrix with \code{nrow(sos)} rows and 2 columns. If #' \code{x} is a matrix, then \code{zi} must be a 3-dimensional array of size #' \code{(nrow(sos), 2, ncol(x))}. Alternatively, \code{zi} may be the #' character string \code{"zf"}, which specifies to return the final state #' vector even though the initial state vector is set to all zeros. Default: #' NULL. #' #' @return The filtered signal, of the same dimensions as the input signal. In #' case the \code{zi} input argument was specified, a list with two elements #' is returned containing the variables \code{y}, which represents the output #' signal, and \code{zf}, which contains the final state vector or matrix. #' #' @examples #' fs <- 1000 #' t <- seq(0, 1, 1/fs) #' s <- sin(2* pi * t * 6) #' x <- s + rnorm(length(t)) #' plot(t, x, type = "l", col="light gray") #' lines(t, s, col="black") #' sosg <- butter(3, 0.02, output = "Sos") #' sos <- sosg$sos #' sos[1, 1:3] <- sos[1, 1:3] * sosg$g #' y <- sosfilt(matrix(sos, ncol=6), x) #' lines(t, y, col="red") #' #' ## using 'filter' will handle the gain for you #' y2 <- filter(sosg, x) #' all.equal(y, y2) #' #' ## The following example is from Python scipy.signal.sosfilt #' ## It shows the instability that results from trying to do a #' ## 13th-order filter in a single stage (the numerical error #' ## pushes some poles outside of the unit circle) #' arma <- ellip(13, 0.009, 80, 0.05, output='Arma') #' sos <- ellip(13, 0.009, 80, 0.05, output='Sos') #' x <- rep(0, 700); x[1] <- 1 #' y_arma <- filter(arma, x) #' y_sos <- filter(sos, x) #' plot(y_arma, type ="l") #' lines (y_sos, col = 2) #' legend("topleft", legend = c("Arma", "Sos"), lty = 1, col = 1:2) #' #' @seealso \code{\link{filter}}, \code{\link{filtfilt}}, \code{\link{Sos}} #' #' @references Smith III, J.O. (2012). Introduction to digital filters, with #' audio applications (3rd Ed.). W3K Publishing. #' #' @author Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export sosfilt <- function(sos, x, zi = NULL) { # Check sos if (is.vector(sos)) { if (length(sos) == 6) { sos <- matrix(sos, ncol = 6) } else { stop("sos must a matrix with 6 columns") } } else if (is.matrix(sos)) { if (ncol(sos) != 6) { stop("sos must a matrix with 6 columns") } } else { stop("sos must a matrix with 6 columns") } a0 <- sos[, 4] if (any(a0 == 0)) { stop("invalid sos structure (sos[, 4] must not be zero)") } if (any(a0 != 1)) { sos <- sos / a0 } # check x, coerce it to matrix if (is.null(x)) { return(NULL) } if (!(is.numeric(x) || is.complex(x))) { stop("x must be a numeric or complex vector or matrix") } #save attributes of x atx <- attributes(x) if (is.vector(x)) { x <- as.matrix(x, ncol = 1) vec <- TRUE } else { vec <- FALSE } nrx <- NROW(x) ncx <- NCOL(x) if (is.null(nrx) || nrx <= 0) { return(x) } # check zi, coerce to 3d array rzf <- (is.character(zi) && zi == "zf") if (!is.null(zi) && !is.numeric(zi) && !rzf) { stop("zi must be NULL, a numeric vector or matrix, or the string 'zf'") } if (is.null(zi) || rzf) { if (is.numeric(x)) { zi <- array(0, dim = c(nrow(sos), 2, ncx)) } else if(is.complex(x)) { zi <- array(0 + 0i, dim = c(nrow(sos), 2, ncx)) } if (is.null(zi)) { rzf <- FALSE } } else if (!is.null(zi)) { rzf <- TRUE } if (is.vector(zi)) { stop("zi must be NULL, a matrix or a 3-dimensional array") } else { dims_zi <- dim(zi) if (length(dims_zi) == 2) { dim(zi) <- c(dims_zi, 1) dims_zi <- c(dims_zi, 1) } } if (dims_zi[1] != nrow(sos)) { stop("zi must equal the number of sections in sos") } if (dims_zi[2] != 2) { stop("number of columns of zi must be 2") } if (dims_zi[3] != ncx) { stop("third dimension of zi must be equal the number of columns in x") } if (is.numeric(x)) { y <- matrix(0, nrx, ncx) zf <- array(0, dim = dims_zi) for (icol in seq_len(ncx)) { l <- .Call("_gsignal_rsosfilt", PACKAGE = "gsignal", sos, x[, icol], matrix(zi[, , icol], ncol = 2)) if (length(l) <= 0) { stop("Error filtering data") } y[, icol] <- l[["y"]] zf[, , icol] <- l[["zf"]] } } else if (is.complex(x)) { y <- matrix(0 + 0i, nrx, ncx) zf <- array(0 + 0i, dim = dims_zi) for (icol in seq_len(ncx)) { re <- .Call("_gsignal_rsosfilt", PACKAGE = "gsignal", sos, Re(x[, icol]), Re(matrix(zi[, , icol], ncol = 2))) if (length(re) <= 0) { stop("Error filtering data") } im <- .Call("_gsignal_rsosfilt", PACKAGE = "gsignal", sos, Im(x[, icol]), Im(matrix(zi[, , icol], ncol = 2))) if (length(im) <= 0) { stop("Error filtering data") } y[, icol] <- re[["y"]] + 1i * im[["y"]] zf[, , icol] <- re[["zf"]] + 1i * im[["zf"]] } } if (vec) { y <- as.vector(y) dim(zf) <- dims_zi[1:2] } if (is.complex(x)) { y <- zapIm(y) zf <- zapIm(zf) } # set attributes of y nd return attributes(y) <- atx if (rzf) { rv <- list(y = y, zf = zf) } else { rv <- y } rv } gsignal/R/blackman.R0000644000176200001440000000516714420222025013774 0ustar liggesusers# blackman.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1995-2017 Andreas Weingessel # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191210 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Blackman window #' #' Return the filter coefficients of a Blackman window. #' #' The Blackman window is a member of the family of cosine sum windows. #' #' @param n Window length, specified as a positive integer. #' @param method Character string. Window sampling method, specified as: #' \describe{ #' \item{"symmetric" (Default)}{Use this option when using windows for filter #' design.} #' \item{"periodic"}{This option is useful for spectral analysis because it #' enables a windowed signal to have the perfect periodic extension implicit #' in the discrete Fourier transform. When "periodic" is specified, the #' function computes a window of length \code{n + 1} and returns the first #' \code{n} points.} #' } #' #' @return Blackman window, returned as a vector. #' #' @examples #' #' h <- blackman(64) #' plot (h, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' bs = blackman(64,'symmetric') #' bp = blackman(63,'periodic') #' plot (bs, type = "l", xlab = "Samples", ylab =" Amplitude") #' lines(bp, col="red") #' #' @author Andreas Weingessel, \email{Andreas.Weingessel@@ci.tuwien.ac.at}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export blackman <- function(n, method = c("symmetric", "periodic")) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) { stop("n must be an integer strictly positive") } method <- match.arg(method) if (method == "periodic") { N <- n } else if (method == "symmetric") { N <- n - 1 } else { stop("method must be either 'periodic' or 'symmetric'") } if (n == 1) { w <- 1 } else { n <- n - 1 k <- (0:n) / N w <- 0.42 - 0.5 * cos(2 * pi * k) + 0.08 * cos(4 * pi * k) } w } gsignal/R/idct.R0000644000176200001440000000752314420222025013145 0ustar liggesusers# dct.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2001 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201015 GvB setup for gsignal v0.1.0 # 20210506 GvB use matrix() instead of as.matrix # 20220328 GvB copy dimnames of x to output object #------------------------------------------------------------------------------ #' Inverse Discrete Cosine Transform #' #' Compute the inverse unitary discrete cosine transform of a signal. #' #' The discrete cosine transform (DCT) is closely related to the discrete #' Fourier transform. You can often reconstruct a sequence very accurately from #' only a few DCT coefficients. This property is useful for applications #' requiring data reduction. #' #' @param x input discrete cosine transform, specified as a numeric vector or #' matrix. In case of a vector it represents a single signal; in case of a #' matrix each column is a signal. #' @param n transform length, specified as a positive integer scalar. Default: #' \code{NROW(x)}. #' #' @return Inverse discrete cosine transform, returned as a vector or matrix. #' #' @examples #' x <- seq_len(100) + 50 * cos(seq_len(100) * 2 * pi / 40) #' X <- dct(x) #' #' # Find which cosine coefficients are significant (approx.) #' # zero the rest #' nsig <- which(abs(X) < 1) #' N <- length(X) - length(nsig) + 1 #' X[nsig] <- 0 #' #' # Reconstruct the signal and compare it to the original signal. #' xx <- idct(X) #' plot(x, type = "l") #' lines(xx, col = "red") #' legend("bottomright", legend = c("Original", paste("Reconstructed, N =", N)), #' lty = 1, col = 1:2) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{dct}} #' #' @export idct <- function(x, n = NROW(x)) { # check parameters if (!(is.vector(x) || is.matrix(x)) || !(is.numeric(x) || is.complex(x))) { stop("x must be a numeric or complex vector or matrix") } else { realx <- is.numeric(x) } if (is.vector(x)) { vec <- TRUE x <- matrix(x, ncol = 1) } else { vec <- FALSE } nr <- nrow(x) ns <- ncol(x) if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer") } if (n != nr) { x <- postpad(x, n) } if (realx && n %% 2 == 0) { w <- c(sqrt(n / 4), sqrt(n / 2) * exp((1i * pi / 2 / n) * seq_len(n - 1))) %o% rep(1, ns) y <- imvfft(w * x) y[c(seq(1, n, 2), seq(n, 1, -2)), ] <- 2 * Re(y) } else if (n == 1) { y <- x } else { ## reverse the steps of dct using inverse operations ## 1. undo post-fft scaling w <- c(sqrt(4 * n), sqrt(2 * n) * exp((1i * pi / 2 / n) * seq_len(n - 1))) %o% rep(1, ns) y <- x * w ## 2. reconstruct fft result and invert it w <- exp(-1i * pi * seq(n - 1, 1, -1) / n) %o% rep(1, ns) y <- imvfft(rbind(y, rep(0, ns), matrix(y[seq(n, 2, -1), ], ncol = ns) * w)) ## 3. keep only the original data; toss the reversed copy y <- y[1:n, ] } if (realx) { y <- Re(y) } if (vec) { y <- as.vector(y) } dimnames(y) <- dimnames(x) y } gsignal/R/rectpuls.R0000644000176200001440000000524114420222025014056 0ustar liggesusers# rectpuls.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2000 Paul Kienzle, Copyright (C) 2018-2019 Mike Miller # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191127 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Rectangular pulse #' #' Return samples of the unit-amplitude rectangular pulse at the times #' indicated by \code{t}. #' #' \code{y <- rectpuls(t)} returns a continuous, aperiodic, unit-height #' rectangular pulse at the sample times indicated in array t, centered about t #' = 0. #' #' \code{y <- rectpuls(t, w)} generates a rectangular pulse over the interval #' from \code{-w/2} to \code{w/2}, sampled at times \code{t}. This is useful #' with the function \code{pulstran} for generating a series of pulses. #' #' @param t Sample times of unit rectangular pulse, specified by a vector. #' @param w Rectangle width, specified by a positive number. Default: 1 #' #' @return Rectangular pulse of unit amplitude, returned as a vector. #' #' @seealso \code{\link{pulstran}} #' #' @examples #' #' fs <- 10e3 #' t <- seq(-0.1, 0.1, 1/fs) #' w <- 20e-3 #' y <- rectpuls(t, w) #' plot(t, y, type="l", xlab = "Time", ylab = "Amplitude") #' #' fs <- 11025 # arbitrary sample rate #' f0 <- 100 # pulse train sample rate #' w <- 0.3/f0 # pulse width 1/10th the distance between pulses #' y <- pulstran (seq(0, 4/f0, 1/fs), seq(0, 4/f0, 1/f0), 'rectpuls', w = w) #' plot (seq(0, length(y)-1) * 1000/fs, y, type ="l", xlab = "Time (ms)", #' ylab = "Amplitude", #' main = "Rectangular pulse train of 3 ms pulses at 10 ms intervals") #' #' @author Paul Kienzle, Mike Miller.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export rectpuls <- function(t, w = 1) { if (length(t) <= 0) stop("t must be a vector with length > 0") if (!isScalar(w) || w < 0) stop("w must be a positive scalar") y <- rep(0L, length(t)) idx <- which((t >= -w / 2) & (t < w / 2)) y[idx] <- 1 y } gsignal/R/conv.R0000644000176200001440000000737514420222025013174 0ustar liggesusers# conv.R # Copyright (C) 2020 Geert van Boxtel # Octave version: Copyright (C) 1994-2017 John W. Eaton # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 2020209 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Convolution and polynomial multiplication #' #' Convolve two vectors \code{a} and \code{b}. #' #' The convolution of two vectors, \code{a} and \code{b}, represents the area of #' overlap under the points as \code{B} slides across \code{a}. Algebraically, #' convolution is the same operation as multiplying polynomials whose #' coefficients are the elements of \code{a} and \code{b}. #' #' The function \code{conv} uses the \code{\link{filter}} function, NOT #' \code{fft}, which may be faster for large vectors. #' #' @param a,b Input, coerced to vectors, can be different lengths or data types. #' @param shape Subsection of convolution, partially matched to \code{"full"} #' (full convolution - default), \code{"same"} (central part of the #' convolution of the same size as \code{a}), or \code{"valid"} (only those #' parts of the convolution that are computed without the zero-padded edges) #' #' @return Output vector with length equal to \code{length (a) + length (b) - #' 1}. When the parameter \code{shape} is set to \code{"valid"}, the length of #' the output is \code{max(length(a) - length(b) + 1, 0)}, except when #' length(b) is zero. In that case, the length of the output vector equals #' \code{length(a)}. #' #' When \code{a} and \code{b} are the coefficient vectors of two polynomials, #' the convolution represents the coefficient vector of the product #' polynomial. #' #' @examples #' u <- rep(1L, 3) #' v <- c(1, 1, 0, 0, 0, 1, 1) #' w <- conv(u, v) #' #' ## Create vectors u and v containing the coefficients of the polynomials #' ## x^2 + 1 and 2x + 7. #' u <- c(1, 0, 1) #' v <- c(2, 7) #' ## Use convolution to multiply the polynomials. #' w <- conv(u, v) #' ## w contains the polynomial coefficients for 2x^3 + 7x^2 + 2x + 7. #' #' ## Central part of convolution #' u <- c(-1, 2, 3, -2, 0, 1, 2) #' v <- c(2, 4, -1, 1) #' w <- conv(u, v, 'same') #' #' @author Tony Richardson, \email{arichard@@stark.cc.oh.us}, adapted by John W. #' Eaton.\cr Conversion to R by Geert van Boxtel, #' \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export conv <- function(a, b, shape = c("full", "same", "valid")) { a <- as.vector(a) b <- as.vector(b) shape <- match.arg(shape) la <- la_orig <- length(a) lb <- lb_orig <- length(b) ly <- la + lb - 1 if (ly == 0) { y <- NULL } else { ## Use shortest vector as the coefficient vector to filter. if (la > lb) { tmp <- a a <- b b <- tmp lb <- la } x <- b ## Pad longer vector to convolution length. if (ly > lb) { x <- postpad(x, ly) } y <- filter(a, 1, x) if (shape == "same") { idx <- ceiling((ly - la) / 2) y <- y[(idx + 1):(idx + la)] } else if (shape == "valid") { len <- la_orig - lb_orig if (lb_orig + len < lb_orig) { y <- NULL } else { y <- y[(lb_orig:(lb_orig + len))] } } } y } gsignal/R/sftrans.R0000644000176200001440000003051214420222025013674 0ustar liggesusers# sftrans.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1999-2001 Paul Kienzle # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200501 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Transform filter band edges #' #' Transform band edges of a generic lowpass filter to a filter with different #' band edges and to other filter types (high pass, band pass, or band stop). #' #' Given a low pass filter represented by poles and zeros in the splane, you can #' convert it to a low pass, high pass, band pass or band stop by transforming #' each of the poles and zeros individually. The following summarizes the #' transformations: #' \if{latex}{ #' \tabular{lll}{ #' \strong{Transform} \tab \strong{Zero at x} \tab \strong{Pole at x} \cr #' ------------------------- \tab ------------------------- \tab ------------------------- \cr #' \strong{Low-Pass} \tab zero: \eqn{Fc x/C} \tab pole: \eqn{Fc x/C} \cr #' \eqn{S \rightarrow C S/Fc} \tab gain: \eqn{C/Fc} \tab gain: \eqn{Fc/C} \cr #' ------------------------- \tab ------------------------- \tab ------------------------- \cr #' \strong{High Pass} \tab zero: \eqn{Fc C/x} \tab pole: \eqn{Fc C/x} \cr #' \eqn{S \rightarrow C Fc/S} \tab pole: \eqn{0} \tab zero: \eqn{0} \cr #' \tab gain: \eqn{-x} \tab gain: \eqn{-1/x} \cr #' ------------------------- \tab ------------------------- \tab ------------------------- \cr #' \strong{Band Pass} \tab zero: \eqn{b +- \sqrt{(b^2-FhFl)}} \tab pole: \eqn{b \pm \sqrt{(b^2-FhFl)}} \cr #' \tab pole: \eqn{0} \tab zero: \eqn{0} \cr #' S -> \eqn{C \frac{S^2+FhFl}{S(Fh-Fl)}} #' \tab gain: \eqn{C/(Fh-Fl)} \tab gain: \eqn{(Fh-Fl)/C} \cr #' \tab \eqn{b=x/C (Fh-Fl)/2} \tab \eqn{b=x/C (Fh-Fl)/2} \cr #' ------------------------- \tab ------------------------- \tab ------------------------- \cr #' \strong{Band Stop} \tab zero: \eqn{b \pm \sqrt{(b^2-FhFl)}} \tab pole: \eqn{b +- \sqrt{(b^2-FhFl)}} \cr #' \tab pole: \eqn{\pm \sqrt{(-FhFl)}} \tab zero: \eqn{\pm \sqrt{(-FhFl)}} \cr #' S -> \eqn{C \frac{S(Fh-Fl)}{S^2+FhFl}} #' \tab gain: \eqn{-x} \tab gain: \eqn{-1/x} \cr #' \tab \eqn{b=C/x (Fh-Fl)/2} \tab \eqn{b=C/x (Fh-Fl)/2} \cr #' ------------------------- \tab ------------------------- \tab ------------------------- \cr #' \strong{Bilinear} \tab zero: \eqn{(2+xT)/(2-xT)} \tab pole: \eqn{(2+xT)/(2-xT)} \cr #' \tab pole: \eqn{-1} \tab zero: \eqn{-1} \cr #' \eqn{S \rightarrow \frac{2 z-1}{T z+1}} #' \tab gain: \eqn{(2-xT)/T} \tab gain: \eqn{(2-xT)/T} \cr #' ------------------------- \tab ------------------------- \tab ------------------------- \cr #' }} #' \if{html}{\preformatted{ #' #' Transform Zero at x Pole at x #' ---------------- ------------------------- -------------------------- #' Low-Pass zero: Fc x/C pole: Fc x/C #' S -> C S/Fc gain: C/Fc gain: Fc/C #' ---------------- ------------------------- -------------------------- #' High Pass zero: Fc C/x pole: Fc C/x #' S -> C Fc/S pole: 0 zero: 0 #' gain: -x gain: -1/x #' ---------------- ------------------------- -------------------------- #' Band Pass zero: b +- sqrt(b^2-FhFl) pole: b +- sqrt(b^2-FhFl) #' S^2+FhFl pole: 0 zero: 0 #' S -> C -------- gain: C/(Fh-Fl) gain: (Fh-Fl)/C #' S(Fh-Fl) b=x/C (Fh-Fl)/2 b=x/C (Fh-Fl)/2 #' ---------------- ------------------------- -------------------------- #' Band Stop zero: b +- sqrt(b^2-FhFl) pole: b +- sqrt(b^2-FhFl) #' S(Fh-Fl) pole: +-sqrt(-FhFl) zero: +-sqrt(-FhFl) #' S -> C -------- gain: -x gain: -1/x #' S^2+FhFl b=C/x (Fh-Fl)/2 b=C/x (Fh-Fl)/2 #' ---------------- ------------------------- -------------------------- #' Bilinear zero: (2+xT)/(2-xT) pole: (2+xT)/(2-xT) #' 2 z-1 pole: -1 zero: -1 #' S -> ----- gain: (2-xT)/T gain: (2-xT)/T #' T z+1 #' ---------------- ------------------------- -------------------------- #' }} #' #' where C is the cutoff frequency of the initial lowpass filter, F_c is the #' edge of the target low/high pass filter and [F_l,F_h] are the edges of the #' target band pass/stop filter. With abundant tedious algebra, you can derive #' the above formulae yourself by substituting the transform for S into #' \eqn{H(S)=S-x} for a zero at x or \eqn{H(S)=1/(S-x)} for a pole at x, and #' converting the result into the form: #' #' \deqn{g prod(S-Xi) / prod(S-Xj)} #' #' Please note that a pole and a zero at the same place exactly cancel. This is #' significant for High Pass, Band Pass and Band Stop filters which create #' numerous extra poles and zeros, most of which cancel. Those which do not #' cancel have a fill-in effect, extending the shorter of the sets to have the #' same number of as the longer of the sets of poles and zeros (or at least #' split the difference in the case of the band pass filter). There may be other #' opportunistic cancellations, but it does not check for them. #' #' Also note that any pole on the unit circle or beyond will result in an #' unstable filter. Because of cancellation, this will only happen if the number #' of poles is smaller than the number of zeros and the filter is high pass or #' band pass. The analytic design methods all yield more poles than zeros, so #' this will not be a problem. #' #' @param Sz In the generic case, a model to be transformed. In the default case, #' a vector containing the zeros in a pole-zero-gain model. #' @param Sp a vector containing the poles in a pole-zero-gain model. #' @param Sg a vector containing the gain in a pole-zero-gain model. #' @param w critical frequencies of the target filter specified in radians. #' \code{w} must be a scalar for low-pass and high-pass filters, and \code{w} #' must be a two-element vector c(low, high) specifying the lower and upper #' bands in radians. #' @param stop FALSE for a low-pass or band-pass filter, TRUE for a high-pass or #' band-stop filter. #' @param ... arguments passed to the generic function. #' #' @return For the default case or for sftrans.Zpg, an object of class "Zpg", #' containing the list elements: #' \describe{ #' \item{z}{complex vector of the zeros of the transformed model} #' \item{p}{complex vector of the poles of the transformed model} #' \item{g}{gain of the transformed model} #' } #' For sftrans.Arma, an object of class "Arma", containing the list elements: #' \describe{ #' \item{b}{moving average (MA) polynomial coefficients} #' \item{a}{autoregressive (AR) polynomial coefficients} #' } #' #' @examples #' ## 6th order Bessel bandpass #' zpg <- besselap(6) #' bp <- sftrans(zpg, c(2, 3), stop = TRUE) #' freqs(bp, seq(0, 4, length.out = 128)) #' bp <- sftrans(zpg, c(0.1,0.3), stop = FALSE) #' freqs(bp, seq(0, 4, length.out = 128)) #' #' @references Proakis & Manolakis (1992). \emph{Digital Signal Processing}. New #' York: Macmillan Publishing Company. #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Tom Short,\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @rdname sftrans #' @export sftrans <- function(Sz, ...) UseMethod("sftrans") #' @rdname sftrans #' @export sftrans.Zpg <- function(Sz, w, stop = FALSE, ...) sftrans.default(Sz$z, Sz$p, Sz$g, w, stop) #' @rdname sftrans #' @export sftrans.Arma <- function(Sz, w, stop = FALSE, ...) as.Arma(sftrans(as.Zpg(Sz), w, stop)) #' @rdname sftrans #' @export sftrans.default <- function(Sz, Sp, Sg, w, stop = FALSE, ...) { if (is.null(Sz)) Sz <- 0 #GvB 20200428 C <- 1 p <- length(Sp) z <- length(Sz) if (z > p || p == 0) { stop("must have at least as many poles as zeros in s-plane") } if (length(w) == 2) { Fl <- w[1] Fh <- w[2] if (stop) { ## ---------------- ------------------------- ------------------------ ## Band Stop zero: b +- sqrt(b^2-FhFl) pole: b +- sqrt(b^2-FhFl) ## S(Fh-Fl) pole: +-sqrt(-FhFl) zero: +-sqrt(-FhFl) ## S -> C -------- gain: -x gain: -1/x ## S^2+FhFl b=C/x (Fh-Fl)/2 b=C/x (Fh-Fl)/2 ## ---------------- ------------------------- ------------------------ Sg <- Sg * Re(prod(-Sz) / prod(-Sp)) b <- (C * (Fh - Fl) / 2) / Sp Sp <- c(b + sqrt(0i + b^2 - Fh * Fl), b - sqrt(0i + b^2 - Fh * Fl)) extend <- c(sqrt(0i + -Fh * Fl), -sqrt(0i + -Fh * Fl)) if (is.null(Sz) || length(Sz) == 0) { Sz <- extend[1 + (1:(2 * p)) %% 2] } else { b <- (C * (Fh - Fl) / 2) / Sz Sz <- c(b + sqrt(0i + b^2 - Fh * Fl), b - sqrt(0i + b^2 - Fh * Fl)) if (p > z) { Sz <- c(Sz, extend[1 + ((1:2) * (p - z)) %% 2]) } } } else { ## ---------------- ------------------------- ------------------------ ## Band Pass zero: b +- sqrt(b^2-FhFl) pole: b +- sqrt(b^2-FhFl) ## S^2+FhFl pole: 0 zero: 0 ## S -> C -------- gain: C/(Fh-Fl) gain: (Fh-Fl)/C ## S(Fh-Fl) b=x/C (Fh-Fl)/2 b=x/C (Fh-Fl)/2 ## ---------------- ------------------------- ------------------------ Sg <- Sg * (C / (Fh - Fl)) ^ (z - p) b <- Sp * (Fh - Fl) / (2 * C) Sp <- c(b + sqrt(0i + b^2 - Fh * Fl), b - sqrt(0i + b^2 - Fh * Fl)) if (is.null(Sz) || length(Sz) == 0) { Sz <- numeric(p) } else { b <- Sz * (Fh - Fl) / (2 * C) Sz <- c(b + sqrt(0i + b^2 - Fh * Fl), b - sqrt(0i + b^2 - Fh * Fl)) if (p > z) { Sz <- c(Sz, numeric(p - z)) } } } } else { Fc <- w if (stop) { ## ---------------- ------------------------- ------------------------ ## High Pass zero: Fc C/x pole: Fc C/x ## S -> C Fc/S pole: 0 zero: 0 ## gain: -x gain: -1/x ## ---------------- ------------------------- ------------------------ Sg <- Sg * Re(prod(-Sz) / prod(-Sp)) Sp <- C * Fc / Sp if (is.null(Sz) || length(Sz) == 0) { Sz <- numeric(p) } else { Sz <- C * Fc / Sz if (p > z) { Sz <- c(Sz, numeric(p - z)) } } } else { ## ---------------- ------------------------- ------------------------ ## Low Pass zero: Fc x/C pole: Fc x/C ## S -> C S/Fc gain: C/Fc gain: Fc/C ## ---------------- ------------------------- ------------------------ Sg <- Sg * (C / Fc) ^ (z - p) Sp <- Fc * Sp / C Sz <- Fc * Sz / C } } Zpg(z = Sz, p = Sp, g = Sg) } gsignal/R/gausswin.R0000644000176200001440000000447214420222025014062 0ustar liggesusers# gausswin.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1999 Paul Kienzle # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191211 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Gaussian window #' #' Return the filter coefficients of a Gaussian window of length \code{n}. #' #' The width of the window is inversely proportional to the parameter \code{a}. #' Use larger \code{a} for a narrower window. Use larger \code{m} for a smoother #' curve. #' \deqn{w = e^{(-(a*x)^{2}/2 )}} #' for \code{x <- seq(-(n - 1) / n, (n - 1) / n, by = n)}. #' #' The exact correspondence with the standard deviation of a Gaussian #' probability density function is \eqn{\sigma = (n - 1) / (2a)}. #' #' @param n Window length, specified as a positive integer. #' @param a Width factor, specified as a positive real scalar. \code{a} is #' inversely proportional to the width of the window. Default: 2.5. #' #' @return Gaussian convolution window, returned as a vector. #' #' @examples #' #' g1 <- gausswin(64) #' g2 <- gausswin(64, 5) #' plot (g1, type = "l", xlab = "Samples", ylab =" Amplitude", ylim = c(0, 1)) #' lines(g2, col = "red") #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export gausswin <- function(n, a = 2.5) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) stop("n must be an integer strictly positive") if (!isScalar(a)) stop("a must be a scalar") if (n == 1) { w <- 1 } else { w <- exp(-0.5 * (a / (n - 1) * seq(- (n - 1), (n - 1), 2))^2) } w } gsignal/R/freqz.R0000644000176200001440000002320014420222025013337 0ustar liggesusers# freqz.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 1994-2017 John W. Eaton # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200422 GvB setup for gsignal v0.1.0 # 20200423 GvB corrected minor bug in print.summary.freqz # print phase in degrees # 20200425 GvB Added S3 method for class 'Zpg' # 20200515 GvB resolve infinite ylim values in freqz.plot # 20200616 GvB pass default parameters to methods # 20200629 GvB bug in parameter passing for class 'Ma' # 20201103 GvB changed the S3 method handling # 20220616 GvB match freqz.default to Octave signal-1.4.2 setup # implemented freqz.Sos instead of converting to Arma # freqz.Zpg converted to Sos instead of Arma for accuracy #------------------------------------------------------------------------------ #' Frequency response of digital filter #' #' Compute the z-plane frequency response of an ARMA model or rational IIR #' filter. #' #' The frequency response of a digital filter can be interpreted as the transfer #' function evaluated at \eqn{z = e^{j\omega}}. #' #' The 'Matlab' and 'Octave' versions of \code{freqz} produce magnitude and #' phase plots. The \code{freqz} version in the 'signal' package produces #' separate plots of magnitude in the pass band (max - 3 dB to max) and stop #' (total) bands, as well as a phase plot. The current version produces slightly #' different plots. The magnitude plots are separate for stop and pass bands, #' but the pass band plot has an absolute lower limit of -3 dB instead of max - #' 3 dB. In addition a \code{summary} method was added that prints out the most #' important information about the frequency response of the filter. #' #' @note When results of \code{freqz} are printed, \code{freqz_plot} will be #' called to display frequency plots of magnitude and phase. As with lattice #' plots, automatic printing does not work inside loops and function calls, so #' explicit calls to print or plot are needed there. #' #' @param filt for the default case, the moving-average coefficients of an ARMA #' model or filter. Generically, \code{filt} specifies an arbitrary model or #' filter operation. #' @param a the autoregressive (recursive) coefficients of an ARMA filter. #' @param n number of points at which to evaluate the frequency response. If #' \code{n} is a vector with a length greater than 1, then evaluate the #' frequency response at these points. For fastest computation, \code{n} #' should factor into a small number of small primes. Default: 512. #' @param whole FALSE (the default) to evaluate around the upper half of the #' unit circle or TRUE to evaluate around the entire unit circle. #' @param fs sampling frequency in Hz. If not specified (default = 2 * pi), the #' frequencies are in radians. #' @param x object to be printed or plotted. #' @param w vector of frequencies #' @param h complex frequency response \eqn{H(e^{j\omega})}, specified as a #' vector. #' @param ... for methods of \code{freqz}, arguments are passed to the default #' method. For \code{freqz_plot}, additional arguments are passed through to #' plot. #' @param object object of class \code{"freqz"} for \code{summary} #' #' @return For \code{freqz}, a list of class \code{'freqz'} with items: #' \describe{ #' \item{h}{complex array of frequency responses at frequencies \code{f}.} #' \item{w}{array of frequencies.} #' \item{u}{units of (angular) frequency; either rad/s or Hz.} #' } #' #' @examples #' b <- c(1, 0, -1) #' a <- c(1, 0, 0, 0, 0.25) #' freqz(b, a) #' #' hw <- freqz(b, a) #' summary(hw) #' #' @author John W. Eaton, Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Port to R by Tom Short,\cr #' adapted by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com} #' #' @rdname freqz #' @export freqz <- function(filt, ...) UseMethod("freqz") #' @rdname freqz #' @export freqz.default <- function(filt, a = 1, n = 512, whole = ifelse((is.numeric(filt) && is.numeric(a)), FALSE, TRUE), fs = 2 * pi, ...) { if (!(is.vector(filt) && is.vector(a))) { stop("filt and a must be vectors") } if (anyNA(filt) || anyNA(a)) { stop("filt and a must not contain missing values") } else { b <- filt } if(!is.vector(n) || anyNA(n) || any(n < 0)) { stop("n must be positive") } if (!is.logical(whole)) { whole <- FALSE } if (!(isScalar(fs) && fs > 0)) { stop("fs must be a scalar > 0") } if (fs == 2 * pi) { u <- "rad/s" } else { u <- "Hz" } if (!isScalar(n) || !isWhole(n) || as.integer(n) == 0) { ## Explicit frequency vector given w <- f <- n w <- 2 * pi * n / fs k <- max(length(b), length(a)) hb <- pracma::polyval(postpad(b, k), exp(1i * w)) ha <- pracma::polyval(postpad(a, k), exp(1i * w)) } else { ## polyval(fliplr(P),exp(jw)) is O(p n) and fft(x) is O(n log(n)), ## where p is the order of the polynomial P. For small p it ## would be faster to use polyval but in practice the overhead for ## polyval is much higher and the little bit of time saved isn't ## worth the extra code. k <- max(length(b), length(a)) if (whole) { N <- n f <- fs * (0:(n - 1)) / N } else { N <- 2 * n f <- fs * (0:(n - 1)) / N } pad_sz <- N * ceiling(k / N) b <- postpad(b, pad_sz) a <- postpad(a, pad_sz) hb <- rep(0, n) ha <- rep(0, n) for (i in seq(1, pad_sz, N)) { hb <- hb + stats::fft(postpad(b[i:(i + N -1)], N))[1:n] ha <- ha + stats::fft(postpad(a[i:(i + N -1)], N))[1:n] } } h <- hb / ha res <- list(h = h, w = f, u = u) class(res) <- "freqz" res } #' @rdname freqz #' @export freqz.Arma <- function(filt, n = 512, whole = ifelse( (is.numeric(filt$b) && is.numeric(filt$a)), FALSE, TRUE), fs = 2 * pi, ...) freqz.default(filt$b, filt$a, n, whole, fs, ...) #' @rdname freqz #' @export freqz.Ma <- function(filt, n = 512, whole = ifelse(is.numeric(filt), FALSE, TRUE), fs = 2 * pi, ...) # FIR freqz.default(unclass(filt), 1, n, whole, fs, ...) #' @rdname freqz #' @export freqz.Sos <- function(filt, n = 512, whole = FALSE, fs = 2 * pi, ...) { filt$sos[1, 1:3] <- filt$sos[1, 1:3] * filt$g #apply gain h <- 1 for (row in seq_len(nrow(filt$sos))) { wh <- freqz.default(filt$sos[row, 1:3], filt$sos[row, 4:6], n = n, whole = whole, fs = fs) h <- h * wh$h } res <- list(h = h, w = wh$w, u = wh$u) class(res) <- "freqz" res } #' @rdname freqz #' @export freqz.Zpg <- function(filt, n = 512, whole = FALSE, fs = 2 * pi, ...) freqz.Sos(as.Sos(filt), n, whole, fs, ...) #' @rdname freqz #' @export print.freqz <- plot.freqz <- function(x, ...) freqz_plot(x$w, x$h, ...) #' @rdname freqz #' @export summary.freqz <- function(object, ...) { nm <- deparse(substitute(object)) h <- object$h w <- object$w rw <- range(w) mag <- 20 * log10(abs(h)) mmag <- max(mag) wmag <- w[which.max(mag)] cutoff <- w[diff(ifelse((!is.finite(mag) | is.na(mag) | mag < -3), 0, 1)) != 0] phase <- unwrap(Arg(h)) rp <- range(phase) structure(list(nm = nm, rw = rw, mmag = mmag, wmag = wmag, cutoff = cutoff, rp = rp, u = object$u), class = c("summary.freqz", "list")) } #' @rdname freqz #' @export print.summary.freqz <- function(x, ...) { cat(paste0("\nSummary of freqz object '", x$nm, "':\n")) rw <- round(x$rw, 3) cat(paste("\nFrequencies ranging from", rw[1], "to", rw[2], x$u)) mmag <- round(x$mmag, 3) wmag <- round(x$wmag, 3) cat(paste0("\nMaximum magnitude ", mmag, " dB at frequency ", wmag, " ", x$u)) cutoff <- round(x$cutoff, 3) lc <- length(cutoff) fr <- ifelse(lc > 1, "frequencies", "frequency") cat(paste0("\n-3 dB cutoff at ", fr, " ", cutoff[1])) if (lc > 1) { for (i in 2:lc) { cat(paste(",", cutoff[i])) } } cat(paste0(" ", x$u)) rp <- round(x$rp, 3) rpd <- round(rp * 360 / (2 * pi), 3) cat(paste0("\nPhase ranging from ", rp[1], " to ", rp[2], " rad (", rpd[1], " to ", rpd[2], " degrees)")) cat("\n") } #' @rdname freqz #' @export freqz_plot <- function(w, h, ...) { mag <- 20 * log10(abs(h)) maxmag <- max(mag, na.rm = TRUE) if (is.na(maxmag) || maxmag == Inf) maxmag <- 1 argh <- Arg(h) argh[which(is.na(argh))] <- 0 phase <- unwrap(argh) op <- graphics::par(mfrow = c(3, 1), mar = c(4, 4, 1.5, 1)) on.exit(graphics::par(op)) graphics::plot(w, mag, type = "l", xlab = "", ylab = "", ylim = c(-4, maxmag), ...) graphics::title("Pass band (dB)") graphics::abline(h = -3, col = "red", lty = 2) graphics::plot(w, mag, type = "l", xlab = "", ylab = "", ...) graphics::title("Stop band (dB)") graphics::abline(h = -3, col = "red", lty = 2) graphics::plot(w, phase * 360 / (2 * pi), type = "l", xlab = "Frequency", ylab = "", ...) graphics::title("Phase (degrees)") } gsignal/R/rms.R0000644000176200001440000000572114420222025013021 0ustar liggesusers# rms.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2015 Andreas Weber # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200111 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Root-mean-square #' #' Compute the root-mean-square (RMS) of the object \code{x}. #' #' The input \code{x} can be a vector, a matrix or an array. If the input is a #' vector, a single value is returned representing the root-mean-square of the #' vector. If the input is a matrix or an array, a vector or an array of values #' is returned representing the root-mean-square of the dimensions of \code{x} #' indicated by the \code{MARGIN} argument. #' #' Support for complex valued input is provided. The sum of squares of complex #' numbers is defined by \code{sum(x * Conj(x))} #' #' @param x the data, expected to be a vector, a matrix, an array. #' @param MARGIN a vector giving the subscripts which the function will be #' applied over. E.g., for a matrix 1 indicates rows, 2 indicates columns, #' c(1, 2) indicates rows and columns. Where \code{x} has named dimnames, it #' can be a character vector selecting dimension names. Default: 2 (columns) #' #' @return Vector or array of values containing the root-mean-squares of the #' specified \code{MARGIN} of \code{x}. #' #' @examples #' ## numeric vector #' x <- c(1:5) #' r <- rms(x) #' #' ## numeric matrix #' x <- matrix(c(1,2,3, 100, 150, 200, 1000, 1500, 2000), 3, 3) #' p <- rms(x) #' p <- rms(x, 1) #' #' ## numeric array #' x <- array(c(1, 1.5, 2, 100, 150, 200, 1000, 1500, #' 2000, 10000, 15000, 20000), c(2,3,2)) #' p <- rms(x, 1) #' p <- rms(x, 2) #' p <- rms(x, 3) #' #' ## complex input #' x <- c(1+1i, 2+3i, 3+5i, 4+7i, 5+9i) #' p <- rms(x) #' #' @author Andreas Weber, \email{octave@@tech-chat.de}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export rms <- function(x, MARGIN = 2) { if (!(is.numeric(x) || is.complex(x)) || !(is.vector(x) || is.matrix(x) || is.array(x))) { stop("x must be a numeric or complex vector, matrix or array") } if (!isPosscal(MARGIN) || !isWhole(MARGIN)) { stop("MARGIN must be a positive scalar") } if (is.vector(x)) { x <- as.matrix(x) MARGIN <- 2 } y <- apply(x, MARGIN, rmsq) y } gsignal/R/downsample.R0000644000176200001440000000515414420222025014371 0ustar liggesusers# downsample.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2007 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201129 GvB setup for gsignal v0.1.0 # 20220328 GvB copy dimnames of x to output object #------------------------------------------------------------------------------ #' Decrease sample rate #' #' Downsample a signal by an integer factor. #' #' For most signals you will want to use \code{\link{decimate}} instead since it #' prefilters the high frequency components of the signal and avoids aliasing #' effects. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param n downsampling factor, specified as a positive integer. #' @param phase offset, specified as a positive integer from \code{0} to \code{n #' - 1}. Default: 0. #' #' @return Downsampled signal, returned as a vector or matrix. #' #' @examples #' x <- seq_len(10) #' xd <- downsample(x, 3) # returns 1 4 7 10 #' xd <- downsample(x, 3, 2) # returns 3 6 9 #' #' x <- matrix(seq_len(12), 4, 3, byrow = TRUE) #' xd <- downsample(x, 3) #' #' @seealso \code{\link{decimate}}, \code{\link{resample}} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export downsample <- function(x, n, phase = 0) { if (is.vector(x)) { lx <- length(x) x <- matrix(x, ncol = 1) vec <- TRUE } else if (is.matrix(x)) { lx <- nrow(x) vec <- FALSE } else { stop("x must be a numeric vector or matrix") } if (!(isPosscal(n) && isWhole(n))) { stop("n must be a positive integer") } if (!(isPosscal(phase) && isWhole(phase)) || phase > n - 1) { stop("phase must be a positive integer between 0 and n - 1") } y <- x[seq(phase + 1, lx, n), ] if (vec) { y <- as.vector(y) } dimnames(y) <- dimnames(x) y } gsignal/R/fracshift.R0000644000176200001440000001140414420222025014164 0ustar liggesusers# fracshift.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2008 Eric Chassande-Mottin, CNRS (France) # Copyright (C) 2018 Juan Pablo Carbajal # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201122 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Fractional shift #' #' Shift a signal by a (possibly fractional) number of samples. #' #' The function calculates the initial index and end index of the sequences of #' 1’s in the rows of \code{x}. The clusters are sought in the rows of the array #' \code{x}. The function works by finding the indexes of jumps between #' consecutive values in the rows of \code{x}. #' #' @param x input data, specified as a numeric vector. #' @param d number of samples to shift \code{x} by, specified as a numeric value #' @param h interpolator impulse response, specified as a numeric vector. If #' NULL (default), the interpolator is designed by a Kaiser-windowed sinecard. #' #' @return A list of matrices size \code{nr}, where \code{nr} is the number of #' rows in \code{x}. Each element of the list contains a matrix with two rows. #' The first row is the initial index of a sequence of 1s and the second row #' is the end index of that sequence. If \code{nr == 1} the output is a matrix #' with two rows. #' #' @examples #' N = 1024 #' t <- seq(0, 1, length.out = N) #' x <- exp(-t^2 / 2 / 0.25^2) * sin(2 * pi * 10 * t) #' dt <- 0.25 #' d <- dt / (t[2] - t[1]) #' y <- fracshift(x, d) #' plot(t, x, type = "l", xlab = "Time", ylab = "Sigfnal") #' lines (t, y, col = "red") #' legend("topright", legend = c("original", "shifted"), lty = 1, col = 1:2) #' #' @author Eric Chassande-Mottin, \email{ecm@@apc.univ-paris7.fr},\cr #' Juan Pablo Carbajal, \email{carbajal@@ifi.uzh.ch},\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references [1] A. V. Oppenheim, R. W. Schafer and J. R. Buck, #' Discrete-time signal processing, Signal processing series, #' Prentice-Hall, 1999.\cr #' [2] T.I. Laakso, V. Valimaki, M. Karjalainen and U.K. Laine #' Splitting the unit delay, IEEE Signal Processing Magazine, #' vol. 13, no. 1, pp 30--59 Jan 1996. # #' @export fracshift <- function(x, d, h = NULL) { if (!is.vector(x) || !is.numeric(x)) { stop("x must be a numeric vector") } if (!isScalar(d)) { stop("d must be a scalar") } if (!is.null(h)) { if (!is.numeric(h) || !is.vector(h)) { stop("h must be a numeric vector") } } else { h <- design_filter(d) Lx <- length(x) Lh <- length(h) L <- (Lh - 1) / 2.0 Ly <- Lx ## pre and postpad filter response hpad <- prepad(h, Lh) offset <- floor(L) hpad <- postpad(hpad, Ly + offset) ## filtering xfilt <- upfirdn(x, hpad, 1, 1) x <- xfilt[(offset + 1):(offset + Ly)] } y <- pracma::circshift(x, trunc(d)) y } design_filter <- function(d) { ## properties of the interpolation filter log10_rejection <- -3.0 ## use empirical formula from [1] Chap 7, Eq. (7.63) p 476 rejection_dB <- -20.0 * log10_rejection ## determine parameter of Kaiser window ## use empirical formula from [1] Chap 7, Eq. (7.62) p 474 ## FIXME since the parameters are fix the conditional below is not needed if (rejection_dB >= 21 && rejection_dB <= 50) { beta <- 0.5842 * (rejection_dB - 21.0)^0.4 + 0.07886 * (rejection_dB - 21.0) } else if (rejection_dB > 50) { beta <- 0.1102 * (rejection_dB - 8.7) } else { beta <- 0.0 } ## properties of the interpolation filter stopband_cutoff_f <- 0.5 roll_off_width <- stopband_cutoff_f / 10 ## ideal sinc filter ## determine filter length L <- ceiling((rejection_dB - 8.0) / (28.714 * roll_off_width)) t <- (-L:L) ideal_filter <- 2 * stopband_cutoff_f * sinc(2 * stopband_cutoff_f * (t - (d - trunc(d)))) ## apodize ideal (sincard) filter response m <- 2 * L t <- (0:m) - (d - trunc(d)) # kludge to prevent sqrt of negative number # besselI does not take complex input qq <- t * (m - t) qq[which(qq < 0)] <- 0 t <- 2 * beta / m * sqrt(qq) w <- besselI(t, 0) / besselI(beta, 0) h <- w * ideal_filter h } gsignal/R/parzenwin.R0000644000176200001440000000377614420222025014245 0ustar liggesusers# parzenwin.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2007 Sylvain Pelissier # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191215 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Parzen (de la Vallée Poussin) window #' #' Return the filter coefficients of a Parzen window of length \code{n}. #' #' Parzen windows are piecewise-cubic approximations of Gaussian windows. #' #' @param n Window length, specified as a positive integer. #' #' @return Parzen window, returned as a vector. #' #' @examples #' #' p <- parzenwin(64) #' g <- gausswin(64) #' plot (p, type = "l", xlab = "Samples", ylab =" Amplitude", ylim = c(0, 1)) #' lines(g, col = "red") #' #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export parzenwin <- function(n) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) stop("n must be an integer strictly positive") N <- n - 1 k <- (- (N / 2)):(N / 2) k1 <- k[which(abs(k) <= (N / 4))] k2 <- k[which(k > (N / 4))] k3 <- k[which(k < (-N / 4))] w1 <- 1 - 6 * (abs(k1) / (n / 2))^2 + 6 * (abs(k1) / (n / 2))^3 w2 <- 2 * (1 - abs(k2) / (n / 2))^3 w3 <- 2 * (1 - abs(k3) / (n / 2))^3 w <- c(w3, w1, w2) w } gsignal/R/filter2.R0000644000176200001440000000544214420222025013567 0ustar liggesusers# filter2.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2001-2019 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201130 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' 2-D digital filter #' #' Apply a 2-D digital filter to the data in \code{x}. #' #' The \code{filter2} function filters data by taking the 2-D convolution of the #' input \code{x} and the coefficient matrix \code{h} rotated 180 degrees. More #' specifically, \code{filter2(h, x, shape)} is equivalent to \code{conv2(x, #' rot90(h, 2), shape)}. #' #' @param h transfer function, specified as a matrix. #' @param x numeric matrix containing the input signal to be filtered. #' @param shape Subsection of convolution, partially matched to: #' \describe{ #' \item{"same"}{Return the central part of the filtered data; same size as #' \code{x} (Default)} #' \item{"full"}{Return the full 2-D filtered data, with zero-padding on all #' sides before filtering} #' \item{"valid"}{Return only the parts which do not include zero-padded #' edges.} #' } #' #' @return The filtered signal, returned as a matrix #' #' @examples #' op <- par(mfcol = c(1, 2)) #' x <- seq(-10, 10, length.out = 30) #' y <- x #' f <- function(x, y) { r <- sqrt(x^2+y^2); 10 * sin(r)/r } #' z <- outer(x, y, f) #' z[is.na(z)] <- 1 #' persp(x, y, z, theta = 30, phi = 30, expand = 0.5, col = "lightblue") #' title( main = "Original") #' #' h <- matrix(c(1, -2, 1, -2, 3, -2, 1, -2, 1), 3, 3) #' zf <-filter2(h, z, 'same') #' persp(x, y, zf, theta = 30, phi = 30, expand = 0.5, col = "lightgreen") #' title( main = "Filtered") #' par(op) #' #' @seealso \code{\link{conv2}} #' #' @author Paul Kienzle. #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export filter2 <- function(h, x, shape = c("same", "full", "valid")) { if (!is.numeric(h) || !is.matrix(h)) { stop("h must be a numeric matrix") } if (!is.numeric(x) || !is.matrix(x)) { stop("x must be a numeric matrix") } shape <- match.arg(shape) nr <- nrow(h) nc <- ncol(h) y <- conv2(x, h[seq(nr, 1, -1), seq(nc, 1, -1)], shape) y } gsignal/R/zp2tf.R0000644000176200001440000000341614420222025013264 0ustar liggesusers# zp2tf.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200402 GvB setup for gsignal v0.1.0 # 20200405 GvB Set default k = 1 # 20200406 GvB validated # 20210326 GvB renamed k to g, return object of class 'Arma' #------------------------------------------------------------------------------ #' Zero-pole-gain to transfer function #' #' Convert digital filter zero-pole-gain data to transfer function form #' #' @param z complex vector of the zeros of the model #' @param p complex vector of the poles of the model #' @param g overall gain. Default: 1. #' #' @return A list of class "Arma" with the following list elements: #' \describe{ #' \item{b}{moving average (MA) polynomial coefficients} #' \item{a}{autoregressive (AR) polynomial coefficients} #' } #' #' @seealso \code{\link{as.Arma}}, \code{\link{filter}} #' #' @examples #' g <- 1 #' z <- c(0, 0) #' p <- pracma::roots(c(1, 0.01, 1)) #' ba <- zp2tf(z, p, g) #' #' @author Geert van Boxtel, \email{gjmvanboxtel@@gmail.com} #' #' @export zp2tf <- function(z, p, g = 1) { b <- Re(g * poly(z)) a <- Re(poly(p)) Arma(b = b, a = a) } gsignal/R/movingrms.R0000644000176200001440000000626714420222025014247 0ustar liggesusers# movingrms.R # Copyright (C) 2020 Geert van Boxtel # Original Matlab/Octave version: # Copyright (C) 2012 Juan Pablo Carbajal # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200322 GvB setup for gsignal v0.1.0 # 20210517 GvB adapted examples #------------------------------------------------------------------------------ #' Moving Root Mean Square #' #' Compute the moving root mean square (RMS) of the input signal. #' #' The signal is convoluted against a sigmoid window of width \code{w} and #' risetime \code{rc}. The units of these parameters are relative to the value #' of the sampling frequency given in \code{fs}. #' #' @param x Input signal, specified as a numeric vector or matrix. In case of a #' matrix, the function operates along the columns #' @param width width of the sigmoid window, in units relative to \code{fs}. #' Default: 0.1 #' @param rc Rise time (time constant) of the sigmoid window, in units relative #' to \code{fs}. Default: 1e-3 #' @param fs Sampling frequency. Default: 1 #' #' @return A \code{\link{list}} containing 2 variables: #' \describe{ #' \item{rmsx}{Output signal with the same dimensions as \code{x}} #' \item{w}{Window, returned as a vector} #' } #' #' @examples #' #' N <- 128 #' fs <- 5 #' t <- seq(0, 1, length.out = N) #' x <- sin(2 * pi * fs * t) + runif(N) #' y <- movingrms(x, 5) #' #' @seealso \code{\link{sigmoid_train}} #' #' @author Juan Pablo Carbajal, \email{carbajal@@ifi.uzh.ch}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export movingrms <- function(x, width = 0.1, rc = 1e-3, fs = 1) { if (is.vector(x)) { n <- length(x) } else if (is.matrix(x)) { n <- nrow(x) } else { stop("x must be a vector or a matrix") } if (!isPosscal(width)) { stop("width must be a positive scalar") } if (!isPosscal(rc)) { stop("rc must be a positive scalar") } if (!isPosscal(fs)) { stop("fs must be a positive scalar") } if (width * fs > n / 2) { idx <- c(1, n) w <- rep(1L, n) } else { idx <- round((n + width * fs * c(-1, 1)) / 2) w <- sigmoid_train((1:n), idx, rc * fs)$y } rmsx_single <- function(x, w, n, idx) { fx <- stats::fft(as.vector(x)^2) fw <- stats::fft(as.vector(w)^2) out <- ifft(fx * fw) / (n - 1) out[out < .Machine$double.eps * max(out)] <- 0 out <- pracma::circshift(sqrt(out), round(mean(idx))) } if (is.vector(x)) { rmsx <- rmsx_single(x, w, n, idx) } else { rmsx <- apply(x, 2, rmsx_single, w, n, idx) } list(rmsx = rmsx, w = w) } gsignal/R/aryule.R0000644000176200001440000001002414420222025013511 0ustar liggesusers# aryule.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 1999 Paul Kienzle # Copyright (C) 2006 Peter Lanspeary # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201106 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Autoregressive model coefficients - Yule-Walker method #' #' compute autoregressive all-pole model parameters using the Yule-Walker #' method. #' #' \code{aryule} uses the Levinson-Durbin recursion on the biased estimate of #' the sample autocorrelation sequence to compute the parameters. #' #' @param x input data, specified as a numeric or complex vector or matrix. In #' case of a vector it represents a single signal; in case of a matrix each #' column is a signal. #' @param p model order; number of poles in the AR model or limit to the number #' of poles if a valid criterion is provided. Must be smaller than the length #' of \code{x} minus 1. #' #' @return A \code{list} containing the following elements: #' \describe{ #' \item{a}{vector or matrix containing \code{(p + 1)} autoregression #' coefficients. If \code{x} is a matrix, then each row of a corresponds to #' a column of \code{x}. \code{a} has \code{p + 1} columns.} #' \item{e}{white noise input variance, returned as a vector. If \code{x} is #' a matrix, then each element of e corresponds to a column of \code{x}.} #' \item{k}{Reflection coefficients defining the lattice-filter embodiment #' of the model returned as vector or a matrix. If \code{x} is a matrix, #' then each column of \code{k} corresponds to a column of \code{x}. #' \code{k} has \code{p} rows.} #' } #' #' @note The power spectrum of the resulting filter can be plotted with #' \code{pyulear(x, p)}, or you can plot it directly with #' \code{ar_psd(a,v,...)}. #' #' @examples #' a <- Arma(1, c(1, -2.7607, 3.8106, -2.6535, 0.9238)) #' y <- filter(a, rnorm(1024)) #' coefs <- aryule(y, 4) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Peter V. Lanspeary, \email{pvl@@mecheng.adelaide.edu.au}.\cr #' Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com}. #' #' @seealso \code{\link{ar_psd}}, \code{\link{arburg}} #' #' @export aryule <- function(x, p) { # check parameters if (!(is.vector(x) || is.matrix(x)) || !is.numeric(x)) { stop("x must be a numeric or vector or matrix") } if (is.vector(x)) { vec <- TRUE x <- as.matrix(x, ncol = 1) } else { vec <- FALSE } nr <- nrow(x) nc <- ncol(x) if (!isScalar(p) || !isWhole(p) || !is.numeric(p) || p <= 0.5) { stop("p must be a positive integer") } if (p >= nr - 1) { stop(paste0("p must be less than the length of x (", nr, ") - 1")) } # end of parameter checking # loop over columns aggr_a <- aggr_e <- aggr_k <- NULL for (icol in seq_len(nc)) { xc <- xcorr(x[, icol], maxlag = p + 1, scale = "biased") R <- xc$R[-c(1:(p + 1))] # remove negative autocorrelation lags R[1] <- Re(R[1]) # levinson/toeplitz requires # exactly R[1]==Conj(R[1]) lev <- levinson(R, p) aggr_a <- rbind(aggr_a, lev$a) aggr_e <- c(aggr_e, lev$e) aggr_k <- rbind(aggr_k, lev$k) } if (vec) { rv <- list(a = as.vector(aggr_a), e = aggr_e, k = as.vector(aggr_k)) } else { rv <- list(a = aggr_a, e = aggr_e, k = t(aggr_k)) } rv } gsignal/R/xcorr.R0000644000176200001440000002355014420222025013355 0ustar liggesusers# xcorr.R # Copyright (C) 2020 Geert van Boxtel # Octave version: # Copyright (C) 1999-2001 Paul Kienzle # Copyright (C) 2004 # Copyright (C) 2008, 2010 Peter Lanspeary # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 2020313 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Cross-correlation #' #' Estimate the cross-correlation between two sequences or the autocorrelation #' of a single sequence #' #' Estimate the cross correlation R_xy(k) of vector arguments \code{x} and #' \code{y} or, if \code{y} is omitted, estimate autocorrelation R_xx(k) of #' vector \code{x}, for a range of lags \code{k} specified by the argument #' \code{maxlag}. If \code{x} is a matrix, each column of \code{x} is correlated #' with itself and every other column. #' #' The cross-correlation estimate between vectors \code{x} and \code{y} (of #' length \code{N}) for lag \code{k} is given by #' \if{latex}{ #' \deqn{R_{xy}(k) = \sum_{i=1}^{N} x_{i+k} Conj(y_i)} #' } #' \if{html}{\preformatted{ #' N #' Rxy = SUM x(i+k) . Conj(y(i)) #' i=1 #' }} #' where data not provided (for example \code{x[-1], y[N+1]}) is zero. Note the #' definition of cross-correlation given above. To compute a cross-correlation #' consistent with the field of statistics, see xcov. #' #' The cross-correlation estimate is calculated by a "spectral" method #' in which the FFT of the first vector is multiplied element-by-element #' with the FFT of second vector. The computational effort depends on #' the length N of the vectors and is independent of the number of lags #' requested. If you only need a few lags, the "direct sum" method may #' be faster. #' #' @param x Input, numeric or complex vector or matrix. Must not be missing. #' @param y Input, numeric or complex vector data. If \code{x} is a matrix (not #' a vector), \code{y} must be omitted. \code{y} may be omitted if \code{x} is #' a vector; in this case \code{xcorr} estimates the autocorrelation of #' \code{x}. #' @param maxlag Integer scalar. Maximum correlation lag. If omitted, the #' default value is \code{N-1}, where \code{N} is the greater of the lengths #' of \code{x} and \code{y} or, if \code{x} is a matrix, the number of rows in #' \code{x}. #' @param scale Character string. Specifies the type of scaling applied to the #' correlation vector (or matrix). matched to one of: #' \describe{ #' \item{"none"}{return the unscaled correlation, R} #' \item{"biased"}{return the biased average, R / N} #' \item{"unbiased"}{return the unbiased average, R(k) / (N - |k|)} #' \item{"coeff"}{return the correlation coefficient, R / (rms(x) . #' rms(y))}, where \code{k} is the lag, and \code{N} is the length of #' \code{x} #' } #' If omitted, the default value is \code{"none"}. If \code{y} is supplied but #' does not have the same length as \code{x}, scale must be \code{"none"}. #' #' @return A list containing the following variables: #' \describe{ #' \item{R}{array of correlation estimates} #' \item{lags}{vector of correlation lags \code{[-maxlag:maxlag]}} #' } #' The array of correlation estimates has one of the following forms: #' \enumerate{ #' \item Cross-correlation estimate if X and Y are vectors. #' \item Autocorrelation estimate if is a vector and Y is omitted. #' \item If \code{x} is a matrix, \code{R} is a matrix containing the #' cross-correlation estimate of each column with every other column. Lag #' varies with the first index so that \code{R} has \code{2 * maxlag + 1} rows #' and \eqn{P^2} columns where \code{P} is the number of columns in \code{x}. #' } #' @seealso \code{\link{xcov}}. #' #' @examples #' ## Create a vector x and a vector y that is equal to x shifted by 5 #' ## elements to the right. Compute and plot the estimated cross-correlation #' ## of x and y. The largest spike occurs at the lag value when the elements #' ## of x and y match exactly (-5). #' n <- 0:15 #' x <- 0.84^n #' y <- pracma::circshift(x, 5) #' rl <- xcorr(x, y) #' plot(rl$lag, rl$R, type="h") #' #' ## Compute and plot the estimated autocorrelation of a vector x. #' ## The largest spike occurs at zero lag, when x matches itself exactly. #' n <- 0:15 #' x <- 0.84^n #' rl <- xcorr(x) #' plot(rl$lag, rl$R, type="h") #' #' ## Compute and plot the normalized cross-correlation of vectors #' ## x and y with unity peak, and specify a maximum lag of 10. #' n <- 0:15 #' x <- 0.84^n #' y <- pracma::circshift(x, 5) #' rl <- xcorr(x, y, 10, 'coeff') #' plot(rl$lag, rl$R, type="h") #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Asbjorn Sabo, \email{asbjorn.sabo@@broadpark.no},\cr #' Peter Lanspeary. \email{peter.lanspeary@@adelaide.edu.au}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export xcorr <- function(x, y = NULL, maxlag = if (is.matrix(x)) nrow(x) - 1 else max(length(x), length(y)) - 1, scale = c("none", "biased", "unbiased", "coeff")) { if (is.array(x)) { ld <- length(dim(x)) if (ld == 1) { x <- as.vector(x) } else if (ld == 2) { x <- as.matrix(x) } else { stop("multidimensional arrays are not supported (x)") } } if (!is.null(y) && is.array(y)) { ld <- length(dim(y)) if (ld == 1) { y <- as.vector(y) } else if (ld == 2) { y <- as.matrix(y) } else { stop("multidimensional arrays are not supported (y)") } } if (is.vector(x)) { N <- max(length(x), length(y)) } else { N <- nrow(x) } scale <- match.arg(scale) ## check argument values if (!(is.vector(x) || is.matrix(x)) || !(is.numeric(x) || is.complex(x))) { stop("x must be a numeric or complex vector or matrix") } if (!is.null(y) && is.matrix(y) && !(is.numeric(y) || is.complex(y))) { stop("y must be a vector") } if (!is.null(y) && !is.vector(x)) { stop("x must be a vector if y is specified") } if (!isPosscal(maxlag) || !isWhole(maxlag)) { stop("maxlag must be a non-negative integer") } # Correlations for lags in excess of +/-(N-1) # (a) are not calculated by the FFT algorithm, # (b) are all zero; # so provide them by padding the results (with zeros) before returning. if (maxlag > (N - 1)) { pad_result <- maxlag - (N - 1) maxlag <- N - 1 } else { pad_result <- 0 } if (is.vector(x) && is.vector(y) && length(x) != length(y) && scale != "none") { stop("scale must be 'none' if length(x) != length(y)") } P <- ncol(x) M <- nextpow2(N + maxlag) if (!is.vector(x)) { # correlate each column "i" with all other "j" columns R <- matrix(0L, 2 * maxlag + 1, P^2) # do FFTs of padded column vectors pre <- stats::mvfft(postpad(prepad(x, N + maxlag), M)) post <- Conj(stats::mvfft(postpad(x, M))) # do autocorrelations (each column with itself) cor <- imvfft(post * pre) R[, seq(1, P^2, P + 1)] <- cor[1:(2 * maxlag + 1), ] # do the cross correlations for (i in 1:(P - 1)) { j <- (i + 1):P if (length(j) > 1) { cor <- imvfft(pre[, i * rep(1L, length(j))] * post[, j]) R[, ((i - 1) * P + j)] <- cor[1:(2 * maxlag + 1), ] R[, ((j - 1) * P + i)] <- Conj(pracma::flipud(cor[1:(2 * maxlag + 1), ])) } else { cor <- ifft(pre[, i * rep(1L, length(j))] * post[, j]) R[, ((i - 1) * P + j)] <- cor[1:(2 * maxlag + 1)] R[, ((j - 1) * P + i)] <- Conj(rev(cor[1:(2 * maxlag + 1)])) } } } else if (is.null(y)) { # compute autocorrelation of a single vector post <- stats::fft(postpad(x, M)) cor <- ifft(post * Conj(post)) R <- c(Conj(cor[seq((maxlag + 1), 2, -1)]), cor[1:(maxlag + 1)]) } else { # compute cross-correlation of x and y pre <- stats::fft(postpad(prepad(x, length(x) + maxlag), M)) post <- stats::fft(postpad(y, M)) cor <- ifft(pre * Conj(post)) R <- cor[1:(2 * maxlag + 1)] } # if inputs are real, outputs should be real, so ignore the # insignificant complex portion left over from the FFT if (is.numeric(x) && (is.null(y) || is.numeric(y))) { dr <- dim(R) R <- as.numeric(R) dim(R) <- dr } # correct for bias if (scale == "biased") { R <- R / N } else if (scale == "unbiased") { R <- R / (c((N - maxlag):(N - 1), N, rev((N - maxlag):(N - 1)))) * rep(1L, NCOL(R)) } else if (scale == "coeff") { ## R = R ./ R(maxlag+1) works only for autocorrelation ## For cross correlation coeff, divide by rms(X)*rms(Y). if (!is.vector(x)) { ## for matrix (more than 1 column) X rms <- sqrt(ssq(x)) R <- R / (rep(1L, nrow(R)) * rms) } else if (is.null(y)) { ## for autocorrelation, R(zero-lag) is the mean square. R <- R / R[maxlag + 1] } else { ## for vectors X and Y R <- R / sqrt(ssq(x) * ssq(y)) } } ## Pad result if necessary ## (most likely is not required, use "if" to avoid unnecessary code) ## At this point, lag varies with the first index in R; ## so pad **before** the transpose. if (pad_result) { R_pad <- matrix(0L, pad_result, ncol(R)) R <- cbind(R_pad, R, R_pad) } maxlag <- maxlag + pad_result lags <- -maxlag:maxlag list(R = R, lags = lags) } gsignal/R/pyulear.R0000644000176200001440000000777514420222025013714 0ustar liggesusers# pyule.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 2006 Peter V. Lanspeary # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201106 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Autoregressive PSD estimate - Yule-Walker method #' #' Calculate Yule-Walker autoregressive power spectral density. #' #' @param x input data, specified as a numeric or complex vector or matrix. In #' case of a vector it represents a single signal; in case of a matrix each #' column is a signal. #' @param p model order; number of poles in the AR model or limit to the number #' of poles if a valid criterion is provided. Must be < length(x) - 2. #' @param freq vector of frequencies at which power spectral density is #' calculated, or a scalar indicating the number of uniformly distributed #' frequency values at which spectral density is calculated. Default: 256. #' @param fs sampling frequency (Hz). Default: 1 #' @param range character string. one of: #' \describe{ #' \item{\code{"half"} or \code{"onesided"}}{frequency range of the spectrum #' is from zero up to but not including \code{fs / 2}. Power from negative #' frequencies is added to the positive side of the spectrum.} #' \item{\code{"whole"} or \code{"twosided"}}{frequency range of the spectrum #' is \code{-fs / 2} to \code{fs / 2}, with negative frequencies stored in #' "wrap around order" after the positive frequencies; e.g. frequencies for a #' 10-point \code{'twosided'} spectrum are 0 0.1 0.2 0.3 0.4 0.5 -0.4 -0.3 #' -0.2. -0.1.} #' \item{\code{"shift"} or \code{"centerdc"}}{same as \code{"whole"} but with #' the first half of the spectrum swapped with second half to put the #' zero-frequency value in the middle. If \code{freq} is vector, #' \code{"shift"} is ignored.} #' } #' Default: If model coefficients \code{a} are real, the default range is #' \code{"half"}, otherwise the default range is \code{"whole"}. #' @param method method used to calculate the power spectral density, either #' \code{"fft"} (use the Fast Fourier Transform) or \code{"poly"} (calculate #' the power spectrum as a polynomial). This argument is ignored if the #' \code{freq} argument is a vector. The default is \code{"poly"} unless the #' \code{freq} argument is an integer power of 2. #' #' @return An object of class "ar_psd" , which is a list containing two #' elements, \code{freq} and \code{psd} containing the frequency values and #' the estimates of power-spectral density, respectively. #' #' @note This function is a wrapper for \code{arburg} and \code{ar_psd}. #' #' @examples #' A <- Arma(1, c(1, -2.7607, 3.8106, -2.6535, 0.9238)) #' y <- filter(A, 0.2 * rnorm(1024)) #' py <- pyulear(y, 4) #' #' @author Peter V. Lanspeary, \email{pvl@@mecheng.adelaide.edu.au}.\cr #' Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com} #' #' @seealso \code{\link{ar_psd}}, \code{\link{arburg}} #' #' @export pyulear <- function(x, p, freq = 256, fs = 1, range = NULL, method = if (length(freq) == 1 && bitwAnd(freq, freq - 1) == 0) "fft" else "poly") { coefs <- aryule(x, p) if (is.null(range)) { range <- ifelse(is.numeric(coefs$a), "half", "whole") } rv <- ar_psd(coefs$a, coefs$e, freq, fs, range, method) rv } gsignal/R/wkeep.R0000644000176200001440000001005514420222025013327 0ustar liggesusers# wkeep.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2008 Sylvain Pelissier # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201128 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Keep part of vector or matrix #' #' Extract elements from a vector or matrix. #' #' @param x input data, specified as a numeric vector or matrix. #' @param l either a positive integer value, specifying the length to extract #' from the input *vector* \code{x}, or a vector of length 2, indicating the #' submatrix to extract from the *matrix* \code{x}. See the examples. #' @param opt One of: #' \describe{ #' \item{character string}{matched against \code{c("centered", "left", #' "right")}, indicating the location of the *vector* \code{x} to extract} #' \item{positive integer}{starting index of the input *vector* \code{x}} #' \item{two-element vector}{starting row and columns from the *matrix* #' \code{x}} #' } #' See the examples. Default: "centered". #' #' @return extracted vector or matrix #' #' @examples #' ## create a vector #' x <- 1:10 #' ## Extract a vector of length 6 from the central part of x. #' y <- wkeep(x, 6, 'c') #' #' ## Extract two vectors of length 6, one from the left part of x, and the #' ## other from the right part of x. #' y <- wkeep(x, 6, 'l') #' y <- wkeep(x, 6, 'r') #' #' ## Create a 5-by-5 matrix. #' x <- matrix(round(runif(25, 0, 25)), 5, 5) #' #' ## Extract a 3-by-2 matrix from the center of x #' y <- wkeep(x, c(3, 2)) #' #' ## Extract from x the 2-by-4 submatrix starting at x[3, 1]. #' y <- wkeep(x, c(2, 4), c(3, 1)) #' #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export wkeep <- function(x, l, opt = "centered") { if (is.vector(x) && !is.character(x)) { lx <- length(x) if (!isPosscal(l) || l > length(x)) { stop("l must be a positive integer <= length(x)") } if (is.character(opt)) { opt <- match.arg(opt, c("centered", "left", "right")) if (opt == "centered") { s <- (lx - l) / 2 y <- x[(1 + floor(s)):(lx - ceiling(s))] } else if (opt == "left") { y <- x[1:l] } else if (opt == "right") { y <- x[(lx - l + 1):lx] } else { stop('opt must be a character string ("centered", "left", or "right")') } } else if (isPosscal(opt)) { if (opt == 0 || opt + l - 1 > lx) { stop(paste("opt must be an integer value between 1 and", lx - l)) } else { y <- x[opt:(opt + l - 1)] } } else { stop("opt must be a character string or a positive scalar value") } } else if (is.matrix(x)) { nr <- nrow(x) nc <- ncol(x) lx <- max(nr, nr) if (!is.vector(l) || length(l) != 2) { stop("When x is a matrix l must be a vector of length 2") } else { s1 <- (lx - l[1]) / 2 s2 <- (lx - l[2]) / 2 } if (!is.numeric(opt)) { y <- x[(1 + floor(s1)):(nc - ceiling(s1)), (1 + floor(s2)):(nc - ceiling(s2))] } else { if (length(opt) == 2) { firstr <- opt[1] firstc <- opt[2] } else { stop("When x is a matrix opt must be a vector of length 2") } y <- x[firstr:(firstr + l[1] - 1), firstc:(firstc + l[2] - 1)] } } else { stop("x must be a vector or a matrix") } y } gsignal/R/ellipap.R0000644000176200001440000000410114420222025013635 0ustar liggesusers# ellipap.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2013 Carne Draug # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200527 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Low-pass analog elliptic filter #' #' Return the zeros, poles and gain of an analog elliptic low-pass filter #' prototype. #' #' This function exists for compatibility with 'Matlab' and 'OCtave' only, and #' is equivalent to \code{ellip(n, Rp, Rs, 1, "low", "s")}. #' #' @param n Order of the filter. #' @param Rp dB of passband ripple. #' @param Rs dB of stopband ripple. #' #' @return list of class \code{\link{Zpg}} containing zeros, poles and gain of #' the filter. #' #' @examples #' ## 9th order elliptic low-pass analog filter #' zp <- ellipap(9, .1, 40) #' w <- seq(0, 4, length.out = 128) #' freqs(zp, w) #' #' @author Carne Draug, \email{carandraug+dev@@gmail.com}. #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export ellipap <- function(n, Rp, Rs) { if (!isPosscal(n) || ! isWhole(n)) stop("n must be an integer strictly positive") if (!isPosscal(Rp) || !is.numeric(Rp)) { stop("passband ripple Rp must a non-negative scalar") } if (!isPosscal(Rs) || !is.numeric(Rs)) { stop("stopband ripple Rs must a non-negative scalar") } ellip(n, Rp, Rs, 1, "low", "s", "Zpg") } gsignal/R/meyeraux.R0000644000176200001440000000410714420222025014054 0ustar liggesusers# meyeraux.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2007 Sylvain Pelissier # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191123 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Meyer wavelet auxiliary function #' #' Compute the Meyer wavelet auxiliary function. #' #' The code \code{y = meyeraux(x)} returns values of the auxiliary function used #' for Meyer wavelet generation evaluated at the elements of \code{x}. The input #' \code{x} is a vector or matrix of real values. The function is \deqn{y = #' 35x^{4} - 84x^{5} + 70x^{6} - 20x^{7}.} \code{x} and \code{y} have the same #' dimensions. The range of \code{meyeraux} is the closed interval c(0, 1). #' #' @param x Input array, specified as a real scalar, vector, matrix, or #' multidimensional array. #' #' @return Output array, returned as a real-valued scalar, vector, matrix, or #' multidimensional array of the same size as x. #' #' @examples #' #' x <- seq(0, 1, length.out = 100) #' y <- meyeraux(x) #' plot(x, y, type="l", main = "Meyer wavelet auxiliary function", #' xlab = "", ylab = "") #' #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export meyeraux <- function(x) { y <- 35 * x^4 - 84 * x^5 + 70 * x^6 - 20 * x^7 y } gsignal/R/pwelch.R0000644000176200001440000004703314420222025013504 0ustar liggesusers# pwelch.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2006 Peter V. Lanspeary # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201001 GvB setup for gsignal v0.1.0 # 20201112 GvB bug in assigning colnames when ns > 1 # 20210302 GvB bug when x is matrix: xx[1:seg_len] -> xx[1:seg_len, ] # 20210408 GvB added range parameter ('half' o 'whole') # 20211021 GvB corrected bug in col ptr into coh, phase, trans matrices # 20220405 GvB remove padding to nearest power of 2 (Github Disc #6) # bug in returning vector when ncol is 1 (Github Issue #5) # 20220511 GvB use inherits() instead of direct comparison of class name # 20220512 GvB plot method for class 'pwelch' #------------------------------------------------------------------------------ #' Welch’s power spectral density estimate #' #' Compute power spectral density (PSD) using Welch's method. #' #' The Welch method [1] reduces the variance of the periodogram estimate to the #' PSD by splitting the signal into (usually) overlapping segments and windowing #' each segment, for instance by a Hamming window. The periodogram is then #' computed for each segment, and the squared magnitude is computed, which is #' then averaged for all segments. See also [2]. #' #' The spectral density is the mean of the modified periodograms, scaled so that #' area under the spectrum is the same as the mean square of the data. This #' equivalence is supposed to be exact, but in practice there is a mismatch of #' up to 0.5% when comparing area under a periodogram with the mean square of #' the data. #' #' In case of multivariate signals, Cross-spectral density, phase, and coherence #' are also returned. The input data can be demeaned or detrended, overall or #' for each segment separately. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param window If \code{window} is a vector, each segment has the same length #' as \code{window} and is multiplied by \code{window} before (optional) #' zero-padding and calculation of its periodogram. If \code{window} is a #' scalar, each segment has a length of \code{window} and a Hamming window is #' used. Default: \code{nextpow2(sqrt(length(x)))} (the square root of the #' length of \code{x} rounded up to the next power of two). The window length #' must be larger than 3. #' @param overlap segment overlap, specified as a numeric value expressed as a #' multiple of window or segment length. 0 <= overlap < 1. Default: 0.5. #' @param nfft Length of FFT, specified as an integer scalar. The default is the #' length of the \code{window} vector or has the same value as the scalar #' \code{window} argument. If \code{nfft} is larger than the segment length, #' (seg_len), the data segment is padded \code{nfft - seg_len} zeros. The #' default is no padding. Nfft values smaller than the length of the data #' segment (or window) are ignored. Note that the use of padding to increase #' the frequency resolution of the spectral estimate is controversial. #' @param fs sampling frequency (Hertz), specified as a positive scalar. #' Default: 1. #' @param detrend character string specifying detrending option; one of: #' \describe{ #' \item{\code{long-mean}}{remove the mean from the data before #' splitting into segments (default)} #' \item{\code{short-mean}}{remove the mean value of each segment} #' \item{\code{long-linear}}{remove linear trend from the data before #' splitting into segments} #' \item{\code{short-linear}}{remove linear trend from each segment} #' \item{\code{none}}{no detrending} #' } #' @param range character string. one of: #' \describe{ #' \item{\code{"half"} or \code{"onesided"}}{frequency range of the spectrum #' is from zero up to but not including \code{fs / 2}. Power from negative #' frequencies is added to the positive side of the spectrum.} #' \item{\code{"whole"} or \code{"twosided"}}{frequency range of the spectrum #' is \code{-fs / 2} to \code{fs / 2}, with negative frequencies stored in #' "wrap around order" after the positive frequencies; e.g. frequencies for a #' 10-point \code{"twosided"} spectrum are 0 0.1 0.2 0.3 0.4 0.5 -0.4 -0.3 #' -0.2. -0.1.} #' \item{\code{"shift"} or \code{"centerdc"}}{same as \code{"whole"} but with #' the first half of the spectrum swapped with second half to put the #' zero-frequency value in the middle.} #' } #' Default: If \code{x} are real, the default range is \code{"half"}, #' otherwise the default range is \code{"whole"}. #' @param plot.type character string specifying which plot to produce; one of #' \code{"spectrum"}, \code{"cross-spectrum"}, \code{"phase"}, #' \code{"coherence"}, \code{"transfer"} #' @param yscale character string specifying scaling of Y-axis; one of #' \code{"linear"}, \code{"log"}, \code{"dB"} #' @param xlab,ylab,main labels passed to plotting function. Default: NULL #' @param ... additional arguments passed to functions #' #' @return An object of class \code{"pwelch"}, which is a list containing the #' following elements: #' \describe{ #' \item{\code{freq}}{vector of frequencies at which the spectral variables #' are estimated. If \code{x} is numeric, power from negative frequencies is #' added to the positive side of the spectrum, but not at zero or Nyquist #' (fs/2) frequencies. This keeps power equal in time and spectral domains. #' If \code{x} is complex, then the whole frequency range is returned.} #' \item{\code{spec}}{Vector (for univariate series) or matrix (for #' multivariate series) of estimates of the spectral density at frequencies #' corresponding to freq.} #' \item{\code{cross}}{NULL for univariate series. For multivariateseries, a #' matrix containing the cross-spectral density estimates between different #' series. Column \eqn{i + (j - 1) * (j - 2)/2 } of contains the #' cross-spectral estimates between columns \eqn{i} and \eqn{j} of \eqn{x}, #' where \eqn{i < j}.} #' \item{\code{phase}}{NULL for univariate series. For multivariate series, #' a matrix containing the cross-spectrum phase between different series. #' The format is the same as \code{cross}.} #' \item{\code{coh}}{NULL for univariate series. For multivariate series, a #' matrix containing the squared coherence between different series. The #' format is the same as \code{cross}.} #' \item{\code{trans}}{NULL for univariate series. For multivariate series, #' a matrix containing estimates of the transfer function between different #' series. The format is the same as \code{cross}.} #' \item{\code{x_len}}{The length of the input series.} #' \item{\code{seg_len}}{The length of each segment making up the averages.} #' \item{\code{psd_len}}{The number of frequencies. See \code{freq}} #' \item{\code{nseries}}{The number of series} #' \item{\code{series}}{The name of the series} #' \item{\code{snames}}{For multivariate input, the names of the individual #' series} #' \item{\code{window}}{The window used to compute the modified periodogram} #' \item{\code{fs}}{The sampling frequency} #' \item{\code{detrend}}{Character string specifying detrending option} #' } #' #' @examples #' fs <- 256 #' secs <- 10 #' freq <- 30 #' ampl <- 1 #' t <- seq(0, secs, length.out = fs * secs) #' #' x <- ampl * cos(freq * 2 * pi * t) + runif(length(t)) #' Pxx <- pwelch(x, fs = fs) # no plot #' pwelch(x, fs = fs) # plot #' #' # 90 degrees phase shift with with respect to x #' y <- ampl * sin(freq * 2 * pi * t) + runif(length(t)) #' Pxy <- pwelch(cbind(x, y), fs = fs) #' plot(Pxy, yscale = "dB") #' plot(Pxy, plot.type = "phase") #' # note the phase shift around 30 Hz is pi/2 #' plot(Pxy, plot.type = "coherence") #' #' # Transfer function estimate example #' fs <- 1000 # Sampling frequency #' t <- (0:fs) / fs # One second worth of samples #' A <- c(1, 2) # Sinusoid amplitudes #' f <- c(150, 140) # Sinusoid frequencies #' xn <- A[1] * sin(2 * pi * f[1] * t) + #' A[2] * sin(2 * pi * f[2] * t) + 0.1 * runif(length(t)) #' h <- Ma(rep(1L, 10) / 10) # Moving average filter #' yn <- filter(h, xn) #' atfm <- freqz(h, fs = fs) #' etfm <- pwelch(cbind(xn, yn), fs = fs) #' op <- par(mfrow = c(2, 1)) #' xl <- "Frequency (Hz)"; yl <- "Magnitude" #' plot(atfm$w, abs(atfm$h), type = "l", main = "Actual", xlab = xl, ylab = yl) #' plot(etfm$freq, abs(etfm$trans), type = "l", main = "Estimated", #' xlab = xl, ylab = yl) #' par(op) #' #' @note Unlike the 'Octave' function 'pwelch', the current implementation #' does not compute confidence intervals because they can be inaccurate in #' case of overlapping segments. #' #' @author Peter V. Lanspeary \email{pvl@@mecheng.adelaide.edu.au}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references [1] Welch, P.D. (1967). The use of Fast Fourier Transform for #' the estimation of power spectra: A method based on time averaging over #' short, modified periodograms. IEEE Transactions on Audio and #' Electroacoustics, AU-15 (2): 70–73.\cr #' @references [2] \url{https://en.wikipedia.org/wiki/Welch\%27s_method} #' #' @rdname pwelch #' @export pwelch <- function(x, window = nextpow2(sqrt(NROW(x))), overlap = 0.5, nfft = if (isScalar(window)) window else length(window), fs = 1, detrend = c("long-mean", "short-mean", "long-linear", "short-linear", "none"), range = if (is.numeric(x)) "half" else "whole") { # check parameters if (!(is.vector(x) || is.matrix(x)) && !(is.numeric(x) || is.complex(x))) { stop("x must be a numeric or complex vector or matrix") } series <- deparse(substitute(x)) if (is.vector(x)) { vec <- TRUE x <- as.matrix(x, ncol = 1) snames <- "" } else { vec <- FALSE snames <- colnames(x) } x_len <- nrow(x) ns <- ncol(x) if (is.null(snames)) { snames <- colnames(x) <- as.character(seq_len(ns)) } if (!is.vector(window) || !is.numeric(window)) { stop("window must be a numeric vector or scalar") } else { if (isPosscal(window)) { if (window <= 3) { stop("window must be a scalar > 3 or a vector with length > 3") } else { window <- hamming(window) } } else if (length(window) <= 3) { stop("window must be a scalar > 3 or a vector with length > 3") } } if (!isScalar(overlap) || !(overlap >= 0 && overlap < 1)) { stop("overlap must be a numeric value >= 0 and < 1") } if (!isPosscal(nfft) || !isWhole(nfft)) { stop("nfft must be a positive integer") } if (!isPosscal(fs) || fs <= 0) { stop("fs must be a numeric value > 0") } detrend <- match.arg(detrend) range <- match.arg(range, c("half", "whole")) # initialize variables seg_len <- length(window) overlap <- trunc(seg_len * overlap) # GvB 20220405 removed nextpow2 # nfft <- nextpow2(max(nfft, seg_len)) nfft <- max(nfft, seg_len) win_meansq <- as.vector(window %*% window / seg_len) if (overlap >= seg_len) { stop("overlap must be smaller than windowlength") } # Pad data with zeros if shorter than segment. This should not happen. if (x_len < seg_len) { x <- c(x, rep(0, seg_len - x_len)) x_len <- seg_len } # MAIN CALCULATIONS # remove overall mean or linear trend if (detrend == "long-mean" || detrend == "long-linear") { n_ffts <- max(0, trunc((x_len - seg_len) / (seg_len - overlap))) + 1 x_len <- min(x_len, (seg_len - overlap) * (n_ffts - 1) + seg_len) if (detrend == "long-mean") { x <- detrend(x, p = 0) } else if (detrend == "long-linear") { x <- detrend(x, p = 1) } } # Calculate and accumulate periodograms xx <- Pxx <- matrix(0, nrow = nfft, ncol = ns) if (ns > 1) { Pxy <- phase <- matrix(0, nrow = nfft, ncol = ns * (ns - 1) / 2) } n_ffts <- 0 for (start_seg in seq(1, x_len - seg_len + 1, seg_len - overlap)) { end_seg <- start_seg + seg_len - 1 # Don't truncate/remove the zero padding in xx if (detrend == "short-mean") { xx[1:seg_len, ] <- window * detrend(x[start_seg:end_seg, ], p = 0) } else if (detrend == "short-linear") { xx[1:seg_len, ] <- window * detrend(x[start_seg:end_seg, ], p = 1) } else { xx[1:seg_len, ] <- window * x[start_seg:end_seg, ] } fft_x <- stats::mvfft(xx) # accumulate periodogram Pxx <- Pxx + Re(fft_x * Conj(fft_x)) # acculumulate crossspectrum for all signals if (ns > 1) { ptr <- 1 for (i in seq_len(ns - 1)) { for (j in seq(i + 1, ns)) { # corrected bug 20211021 # ptr <- i + (j - 1) * (j - 2) / 2 Pxy[, ptr] <- Pxy[, ptr] + fft_x[, i] * Conj(fft_x[, j]) ptr <- ptr + 1 } } } n_ffts <- n_ffts + 1 } # Convert two-sided spectra to one-sided spectra if range == 'half' # (normally if the input is numeric). For one-sided spectra, contributions # from negative frequencies are added to the positive side of the spectrum # -- but not at zero or Nyquist (half sampling) frequencies. # This keeps power equal in time and spectral domains, as required by # Parseval theorem. if (range == "half") { if (nfft %% 2 == 0) { # one-sided, nfft is even psd_len <- nfft / 2 + 1 Pxx <- apply(Pxx, 2, function(x) x[1:psd_len] + c(0, x[seq(nfft, psd_len + 1, -1)], 0)) if (ns > 1) { Pxy <- apply(Pxy, 2, function(x) x[1:psd_len] + Conj(c(0, x[seq(nfft, psd_len + 1, -1)], 0))) } } else { # one-sided, nfft is odd psd_len <- (nfft + 1) / 2 Pxx <- apply(Pxx, 2, function(x) x[1:psd_len] + c(0, x[seq(nfft, psd_len + 1, -1)])) if (ns > 1) { Pxy <- apply(Pxy, 2, function(x) x[1:psd_len] + Conj(c(0, x[seq(nfft, psd_len + 1, -1)]))) } } } else { # range equals 'whole' psd_len <- nfft } # end MAIN CALCULATIONS ## SCALING AND OUTPUT scale <- n_ffts * seg_len * fs * win_meansq spec <- Pxx / scale colnames(spec) <- snames if (ns > 1) { cross <- Mod(Pxy) / scale coh <- phase <- trans <- matrix(0, nrow = psd_len, ncol = ns * (ns - 1) / 2) cn <- NULL ptr <- 1 for (i in seq_len(ns - 1)) { for (j in seq(i + 1, ns)) { # corrected bug 20211021 # ptr <- i + (j - 1) * (j - 2) / 2 coh[, ptr] <- Mod(Pxy[, ptr])^2 / Pxx[, i] / Pxx[, j] phase[, ptr] <- Arg(Pxy[, ptr]) trans[, ptr] <- Pxy[, ptr] / Pxx[, i] cn <- c(cn, paste(snames[i], snames[j], sep = "-")) ptr <- ptr + 1 } } colnames(phase) <- colnames(cross) <- colnames(trans) <- colnames(coh) <- cn } else { cross <- coh <- phase <- trans <- NULL } freq <- seq.int(0, psd_len - 1) * (fs / nfft) if (vec) { spec <- as.vector(spec) } all <- list(freq = freq, spec = spec, cross = cross, phase = phase, coh = coh, trans = trans, x_len = x_len, seg_len = seg_len, psd_len = psd_len, nseries = ns, series = series, snames = snames, window = window, fs = fs, detrend = detrend) class(all) <- "pwelch" all } #' @rdname pwelch #' @export plot.pwelch <- function( x, xlab = NULL, ylab = NULL, main = NULL, plot.type = c("spectrum", "cross-spectrum", "phase", "coherence", "transfer"), yscale = c("linear", "log", "dB"), ...) { if (!inherits(x, "pwelch")) { stop("invalid object type") } plot.type <- match.arg(plot.type) yscale <- match.arg(yscale) if (is.null(xlab)) { if (x$fs == 1) { xlab <- expression(paste("Normalized frequency (\u00D7 ", pi, " rad/sample)")) } else if (x$fs == pi) { xlab <- "Frequency (rad/sample)" } else { xlab <- "Frequency (Hz)" } } sub <- paste("Resolution:", format(x$fs / x$psd_len, digits = 6, nsmall = 6)) if (plot.type == "spectrum" || plot.type == "cross-spectrum") { if (is.null(ylab)) { ylab <- switch(yscale, "linear" = "Power/Frequency", "log" = expression(paste("log"[10], "(Power/Frequency)")), "dB" = "Power/Frequency (dB)") } if (plot.type == "spectrum") { if (is.null(main)) { main <- paste("Welch Power Spectral Density Estimate\nSeries:", x$series) } plt <- switch(yscale, "linear" = x$spec, "log" = log10(x$spec), "dB" = 10 * log10(x$spec)) } if (plot.type == "cross-spectrum") { if (is.null(main)) { main <- paste("Welch Cross Power Spectral Density Estimate\nSeries:", x$series) } plt <- switch(yscale, "linear" = x$cross, "log" = log10(x$cross), "dB" = 10 * log10(x$cross)) } } if (plot.type == "phase") { if (is.null(main)) { main <- paste("Welch Cross Spectrum Phase\nSeries:", x$series) } if (is.null(ylab)) { ylab <- expression(paste(theta, " / Frequency")) } plt <- x$phase } if (plot.type == "coherence") { if (is.null(main)) { main <- paste("Squared coherence\nSeries:", x$series) } if (is.null(ylab)) { ylab <- "Magnitude Squared Coherence" } plt <- x$coh } if (plot.type == "transfer") { if (is.null(main)) { main <- paste("Welch Transfer Function Estimate\nSeries:", x$series) } if (is.null(ylab)) { ylab <- switch(yscale, "linear" = "Magnitude", "log" = expression(paste("log"[10], "(Magnitude)")), "dB" = "Magnitude (dB)") } plt <- switch(yscale, "linear" = Mod(x$trans), "log" = log10(Mod(x$trans)), "dB" = 10 * log10(Mod(x$trans))) } graphics::matplot(x$freq, plt, type = "l", xlab = xlab, ylab = "", ...) graphics::title(main = main, sub = sub) graphics::title(ylab = ylab, line = 2) if (plot.type == "phase") { graphics::abline(h = c(-pi, -pi / 2, 0, pi / 2, pi), col = "red", lty = 2) graphics::text(-1, -3, expression(-pi), col = "red") graphics::text(-1, -1.4, expression(-pi / 2), col = "red") graphics::text(-1, 1.4, expression(pi / 2), col = "red") graphics::text(-1, 3, expression(pi), col = "red") } } #' @rdname pwelch #' @export print.pwelch <- function(x, plot.type = c("spectrum", "cross-spectrum", "phase", "coherence", "transfer"), yscale = c("linear", "log", "dB"), xlab = NULL, ylab = NULL, main = NULL, ...) { plot.pwelch(x, plot.type, yscale, xlab, ylab, main, ...) } gsignal/R/ncauer.R0000644000176200001440000001265014420222025013474 0ustar liggesusers# ncauer.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2001 Paulo Neis # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200527 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' ncauer analog filter design #' #' Compute the transfer function coefficients of a Cauer analog filter. #' #' Cauer filters have equal maximum ripple in the passband and the stopband. The #' Cauer filter has a faster transition from the passband to the stopband than #' any other class of network synthesis filter. The term Cauer filter can be #' used interchangeably with elliptical filter, but the general case of #' elliptical filters can have unequal ripples in the passband and stopband. An #' elliptical filter in the limit of zero ripple in the passband is identical to #' a Chebyshev Type 2 filter. An elliptical filter in the limit of zero ripple #' in the stopband is identical to a Chebyshev Type 1 filter. An elliptical #' filter in the limit of zero ripple in both passbands is identical to a #' Butterworth filter. The filter is named after Wilhelm Cauer and the transfer #' function is based on elliptic rational functions.Cauer-type filters use #' generalized continued fractions.[1] #' #' @param Rp dB of passband ripple. #' @param Rs dB of stopband ripple. #' @param n filter order. #' #' @return A list of class Zpg with the following list elements: #' \describe{ #' \item{zero}{complex vector of the zeros of the model} #' \item{pole}{complex vector of the poles of the model} #' \item{gain}{gain of the model} #' } #' #' @examples #' zpg <- ncauer(1, 40, 5) #' freqz(zpg) #' zplane(zpg) #' #' @references [1] #' \url{https://en.wikipedia.org/wiki/Network_synthesis_filters#Cauer_filter} #' #' @seealso \code{\link{Zpg}}, \code{\link{filter}}, \code{\link{ellip}} #' #' @author Paulo Neis, \email{p_neis@@yahoo.com.br}.\cr #' Conversion to R Tom Short,\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export ncauer <- function(Rp, Rs, n) { # check input arguments if (!isPosscal(n) || !isWhole(n)) { stop("filter order n must be a positive integer") } if (!isPosscal(Rp) || !is.numeric(Rp)) { stop("passband ripple Rp must a non-negative scalar") } if (!isPosscal(Rs) || !is.numeric(Rs)) { stop("stopband ripple Rp must a non-negative scalar") } ## Calculate the stop band edge for the Cauer filter. ellip_ws <- function(n, rp, rs) { ellip_ws_min <- function(kl) { int <- pracma::ellipke(c(kl, 1 - kl))$k ql <- int[1] q <- int[2] abs((ql / q) - x) } kl0 <- ((10 ^ (0.1 * rp) - 1) / (10 ^ (0.1 * rs) - 1)) k0 <- 1 - kl0 int <- pracma::ellipke(c(kl0, k0))$k ql0 <- int[1] q0 <- int[2] x <- n * ql0 / q0 kl <- stats::optimize(ellip_ws_min, interval = c(.Machine$double.eps, 1 - .Machine$double.eps))$minimum ws <- sqrt(1 / kl) ws } ## Cutoff frequency = 1: wp <- 1 ## Stop band edge ws: ws <- ellip_ws(n, Rp, Rs) k <- wp / ws k1 <- sqrt(1 - k^2) q0 <- (1 / 2) * ((1 - sqrt(k1)) / (1 + sqrt(k1))) q <- q0 + 2 * q0^5 + 15 * q0^9 + 150 * q0^13 l <- (1 / (2 * n)) * log((10 ^ (0.05 * Rp) + 1) / (10 ^ (0.05 * Rp) - 1)) sig01 <- 0 sig02 <- 0 for (m in 0:30) { sig01 <- sig01 + (-1)^m * q ^ (m * (m + 1)) * sinh((2 * m + 1) * l) } for (m in 1:30) { sig02 <- sig02 + (-1)^m * q ^ (m^2) * cosh(2 * m * l) } sig0 <- abs((2 * q ^ (1 / 4) * sig01) / (1 + 2 * sig02)) w <- sqrt((1 + k * sig0^2) * (1 + sig0^2 / k)) r <- (n - (n %% 2)) / 2 wi <- matrix(0, 1, r) for (ii in 1:r) { mu <- ii - (1 - (n %% 2)) / 2 soma1 <- 0 for (m in 0:30) { soma1 <- soma1 + 2 * q ^ (1 / 4) * ((-1)^m * q ^ (m * (m + 1)) * sin(((2 * m + 1) * pi * mu) / n)) } soma2 <- 0 for (m in 1:30) { soma2 <- soma2 + 2 * ((-1)^m * q ^ (m^2) * cos((2 * m * pi * mu) / n)) } wi[ii] <- soma1 / (1 + soma2) } Vi <- sqrt((1 - (k * (wi^2))) * (1 - (wi^2) / k)) A0i <- 1 / wi^2 sqrA0i <- 1 / wi B0i <- ((sig0 * Vi)^2 + (w * wi)^2) / ((1 + sig0^2 * wi^2)^2) ## not used: ## B1i <- (2 * sig0 * Vi) / (1 + sig0^2 * wi^2) ##Gain T0: if (n %% 2) { # odd T0 <- sig0 * prod(B0i / A0i) * sqrt(ws) } else { T0 <- 10 ^ (-0.05 * Rp) * prod(B0i / A0i) } ##zeros: zer <- c(1i * sqrA0i, -1i * sqrA0i) ##poles: pol <- c((-2 * sig0 * Vi + 2 * 1i * wi * w) / (2 * (1 + sig0^2 * wi^2)), (-2 * sig0 * Vi - 2 * 1i * wi * w) / (2 * (1 + sig0^2 * wi^2))) ##If n odd, there is a real pole -sig0: if (n %% 2) { # odd pol <- c(pol, -sig0) } pole <- sqrt(ws) * pol zero <- sqrt(ws) * zer Zpg(z = zero, p = pole, g = T0) } gsignal/R/Sos.R0000644000176200001440000000553014420222025012762 0ustar liggesusers# Sos.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200402 GvB setup for gsignal v0.1.0 # 20210306 GvB as.Sos.Zpg()): x$g instead of x$k # 20210506 GvB default g = 1 #------------------------------------------------------------------------------ #' Second-order sections #' #' Create or convert filter models to second-order sections form. #' #' \code{as.Sos} converts from other forms, including \code{Arma}, \code{Ma}, #' and \code{Zpg}. #' #' @param sos second-order sections representation of the model #' @param g overall gain factor #' @param x model to be converted. #' @param ... additional arguments (ignored). #' #' @return A list of class \code{Sos} with the following list elements: #' \describe{ #' \item{sos}{second-order section representation of the model, returned as an #' \code{L x 6} matrix, one row for each section \code{1:L}. Each row #' consists of an \code{[B, A]}, pair, where \code{B = c(b0, b1, b2)}, and #' \code{A = c(1, a1, a2)}, the filer coefficients for each section. Each #' \code{b0} entry must be nonzero for each section.} #' \item{g}{overall gain factor that scales any one of the \eqn{B_i} vectors. #' Default: 1} #' } #' #' @seealso \code{\link{Arma}}, \code{\link{Ma}}, \code{\link{Zpg}} #' #' @author Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @examples #' ba <- butter(3, 0.2) #' sos <- as.Sos(ba) #' #' @rdname Sos #' @export Sos <- function(sos, g = 1) { res <- list(sos = sos, g = g) class(res) <- "Sos" res } #' @rdname Sos #' @export as.Sos <- function(x, ...) UseMethod("as.Sos") #' @rdname Sos #' @usage #' ## S3 method for class 'Arma' #' as.Sos(x, ...) #' @export as.Sos.Arma <- function(x, ...) { sosg <- tf2sos(x$b, x$a) Sos(sosg$sos, sosg$g) } #' @rdname Sos #' @usage #' ## S3 method for class 'Ma' #' as.Sos(x, ...) #' @export as.Sos.Ma <- function(x, ...) { as.Sos.Arma(as.Arma.Ma(x)) } #' @rdname Sos #' @usage #' ## S3 method for class 'Sos' #' as.Sos(x, ...) #' @export as.Sos.Sos <- function(x, ...) x #' @rdname Sos #' @usage #' ## S3 method for class 'Zpg' #' as.Sos(x, ...) #' @export as.Sos.Zpg <- function(x, ...) { ret <- zp2sos(x$z, x$p, x$g) class(ret) <- "Sos" ret } gsignal/R/dct.R0000644000176200001440000000750114420222025012770 0ustar liggesusers# dct.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2001 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201015 GvB setup for gsignal v0.1.0 # 20210506 GvB use matrix() instead of as.matrix() # 20220328 GvB copy dimnames of x to output object #------------------------------------------------------------------------------ #' Discrete Cosine Transform #' #' Compute the unitary discrete cosine transform of a signal. #' #' The discrete cosine transform (DCT) is closely related to the discrete #' Fourier transform. You can often reconstruct a sequence very accurately from #' only a few DCT coefficients. This property is useful for applications #' requiring data reduction. #' #' The DCT has four standard variants. This function implements the DCT-II #' according to the definition in [1], which is the most common variant, and #' the original variant first proposed for image processing. #' #' @note The transform is faster if \code{x} is real-valued and has even length. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param n transform length, specified as a positive integer scalar. Default: #' \code{NROW(x)}. #' #' @return Discrete cosine transform, returned as a vector or matrix. #' #' @examples #' x <- matrix(seq_len(100) + 50 * cos(seq_len(100) * 2 * pi / 40)) #' X <- dct(x) #' #' # Find which cosine coefficients are significant (approx.) #' # zero the rest #' nsig <- which(abs(X) < 1) #' N <- length(X) - length(nsig) + 1 #' X[nsig] <- 0 #' #' # Reconstruct the signal and compare it to the original signal. #' xx <- idct(X) #' plot(x, type = "l") #' lines(xx, col = "red") #' legend("bottomright", legend = c("Original", paste("Reconstructed, N =", N)), #' lty = 1, col = 1:2) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references [1] \url{https://en.wikipedia.org/wiki/Discrete_cosine_transform} #' #' @seealso \code{\link{idct}} #' #' @export dct <- function(x, n = NROW(x)) { # check parameters if (!(is.vector(x) || is.matrix(x)) || !(is.numeric(x) || is.complex(x))) { stop("x must be a numeric or complex vector or matrix") } else { realx <- is.numeric(x) } if (is.vector(x)) { vec <- TRUE x <- matrix(x, ncol = 1) } else { vec <- FALSE } nr <- nrow(x) nc <- ncol(x) if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer") } if (n != nr) { x <- postpad(x, n) } if (n == 1) { w <- 1 / 2 } else { w <- c(sqrt(1 / 4 / n), sqrt(1 / 2 / n) * exp((-1i * pi / 2 / n) * seq_len(n - 1))) %o% rep(1, nc) } if (realx && n %% 2 == 0) { y <- stats::mvfft(rbind(matrix(x[seq(1, n, 2), ], ncol = nc), matrix(x[seq(n, 1, -2), ], ncol = nc))) y <- 2 * Re(w * y) } else { y <- stats::mvfft(rbind(x, matrix(pracma::flipud(x), ncol = nc))) y <- w * y[1:n, ] } if (realx) { y <- Re(y) } if (vec) { y <- as.vector(y) } dimnames(y) <- dimnames(x) y } gsignal/R/besself.R0000644000176200001440000000745114420222025013645 0ustar liggesusers# besself.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1999 Paul Kienzle # Copyright (C) 2003 Doug Stewart # Copyright (C) 2009 Thomas Sailer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200428 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Bessel analog filter design #' #' Compute the transfer function coefficients of an analog Bessel filter. #' #' Bessel filters are characterized by an almost constant group delay across the #' entire passband, thus preserving the wave shape of filtered signals in the #' passband. #' #' Lowpass Bessel filters have a monotonically decreasing magnitude response, as #' do lowpass Butterworth filters. Compared to the Butterworth, Chebyshev, and #' elliptic filters, the Bessel filter has the slowest rolloff and requires the #' highest order to meet an attenuation specification. #' #' @note As the important characteristic of a Bessel filter is its #' maximally-flat group delay, and not the amplitude response, it is #' inappropriate to use the bilinear transform to convert the analog Bessel #' filter into a digital form (since this preserves the amplitude response but #' not the group delay) [1]. #' #' @param n filter order. #' @param w critical frequencies of the filter. \code{w} must be a scalar for #' low-pass and high-pass filters, and \code{w} must be a two-element vector #' c(low, high) specifying the lower and upper bands in radians/second. #' @param type filter type, one of \code{"low"} (default), \code{"high"}, #' \code{"stop"}, or \code{"pass"}. #' #' @return List of class \code{'\link{Zpg}'} containing poles and gain of the #' filter. #' #' @examples #' w <- seq(0, 4, length.out = 128) #' #' ## 5th order Bessel low-pass analog filter #' zp <- besself(5, 1.0) #' freqs(zp, w) #' #' ## 5th order Bessel high-pass analog filter #' zp <- besself(5, 1.0, 'high') #' freqs(zp, w) #' #' ## 5th order Bessel band-pass analog filter #' zp <- besself(5, c(1, 2), 'pass') #' freqs(zp, w) #' #' ## 5th order Bessel band-stop analog filter #' zp <- besself(5, c(1, 2), 'stop') #' freqs(zp, w) #' #' @references [1] \url{https://en.wikipedia.org/wiki/Bessel_filter} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Doug Stewart, \email{dastew@@sympatico.ca},\cr #' Thomas Sailer, \email{t.sailer@@alumni.ethz.ch}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export besself <- function(n, w, type = c("low", "high", "stop", "pass")) { if (!isPosscal(n)) { stop("filter order n must be a positive integer") } type <- match.arg(type) stop <- type == "stop" || type == "high" if (length(w) != 1 && length(w) != 2) { stop("frequency must be given as w0 or c(w0, w1)") } if (!all(w >= 0)) { stop("critical frequencies must be in [0 Inf]") } if ((length(w) == 2) && (w[2] <= w[1])) { stop("w[1] must be less than w[2]") } # Generate splane poles for the prototype Bessel filter zpg <- besselap(n) # splane frequency transform zpg <- sftrans(zpg, w, stop) zpg } gsignal/R/Zpg.R0000644000176200001440000000616714420222025012765 0ustar liggesusers# Zpg.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200127 GvB setup for gsignal v0.1.0 # 20200402 GvB adapted to Octave filter conversion functions # 20200406 GvB change parameter names to z, p, g; added example #------------------------------------------------------------------------------ #' Zero pole gain model #' #' Create an zero pole gain model of an ARMA filter, or convert other forms to a #' Zpg model. #' #' \code{as.Zpg} converts from other forms, including \code{Arma} and \code{Ma}. #' #' @param z complex vector of the zeros of the model. #' @param p complex vector of the poles of the model. #' @param g overall gain of the model. #' @param x model to be converted. #' @param ... additional arguments (ignored). #' #' @return A list of class Zpg with the following list elements: #' \describe{ #' \item{z}{complex vector of the zeros of the model} #' \item{p}{complex vector of the poles of the model} #' \item{g}{gain of the model} #' } #' #' @seealso See also \code{\link{Arma}} #' #' @examples #' ## design notch filter at pi/4 radians = 0.5/4 = 0.125 * fs #' w = pi/4 #' # 2 poles, 2 zeros #' # zeroes at r = 1 #' r <- 1 #' z1 <- r * exp(1i * w) #' z2 <- r * exp(1i * -w) #' # poles at r = 0.9 #' r = 0.9 #' p1 <- r * exp(1i * w) #' p2 <- r * exp(1i * -w) #' #' zpg <- Zpg(c(z1, z2), c(p1, p2), 1) #' zplane(zpg) #' freqz(zpg) #' #' ## Sharper edges: increase distance between zeros and poles #' r = 0.8 #' p1 <- r * exp(1i * w) #' p2 <- r * exp(1i * -w) #' zpg <- Zpg(c(z1, z2), c(p1, p2), 1) #' zplane(zpg) #' freqz(zpg) #' #' @author Tom Short, \email{tshort@@eprisolutions.com},\cr #' adapted by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com}. #' @rdname Zpg #' @export Zpg <- function(z, p, g) { res <- list(z = z, p = p, g = g) class(res) <- "Zpg" res } #' @rdname Zpg #' @export as.Zpg <- function(x, ...) UseMethod("as.Zpg") #' @rdname Zpg #' @usage #' ## S3 method for class 'Arma' #' as.Zpg(x, ...) #' @export as.Zpg.Arma <- function(x, ...) { zpk <- tf2zp(x$b, x$a) Zpg(zpk$z, zpk$p, zpk$k) } #' @rdname Zpg #' @usage #' ## S3 method for class 'Ma' #' as.Zpg(x, ...) #' @export as.Zpg.Ma <- function(x, ...) { as.Zpg(as.Arma(x)) } #' @rdname Zpg #' @usage #' ## S3 method for class 'Sos' #' as.Zpg(x, ...) #' #' @export as.Zpg.Sos <- function(x, ...) { zpk <- sos2zp(x$sos, x$g) Zpg(zpk$z, zpk$p, zpk$k) } #' @rdname Zpg #' @usage #' ## S3 method for class 'Zpg' #' as.Zpg(x, ...) #' @export as.Zpg.Zpg <- function(x, ...) x gsignal/R/ifftshift.R0000644000176200001440000000506414420222025014206 0ustar liggesusers# ifftshift.R # Copyright (C) 2020 Geert van Boxtel # Original Octave version: # Author: Vincent Cautaerts # Created: July 1997 # Adapted-By: jwe # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200823 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Inverse zero-frequency shift #' #' Rearranges a zero-frequency-shifted Fourier transform back to the original. #' #' Undo the action of the fftshift function. For even length \code{x}, #' \code{fftshift} is its own inverse, but not for odd length input. #' #' @param x input data, specified as a vector or matrix. #' @param MARGIN dimension to operate along, 1 = row, 2 = columns (default). #' Specifying \code{MARGIN = c(1, 2)} centers along both rows and columns. #' Ignored when \code{x} is a vector. #' #' @return back-transformed vector or matrix. #' #' @examples #' Xeven <- 1:6 #' res <- fftshift(fftshift(Xeven)) #' #' Xodd <- 1:7 #' res <- fftshift(fftshift(Xodd)) #' res <- ifftshift(fftshift(Xodd)) #' #' @seealso \code{\link{fftshift}} #' #' @author Vincent Cautaerts, \email{vincent@@comf5.comm.eng.osaka-u.ac.jp},\cr #' adapted by John W. Eaton.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export ifftshift <- function(x, MARGIN = 2) { y <- x if (is.vector(y)) { xl <- length(y) if (xl > 1) { xx <- floor(xl / 2) y <- x[c((xx + 1):xl, 1:xx)] } } else if (is.matrix(y)) { if (! (1 %in% MARGIN || 2 %in% MARGIN)) { stop("MARGIN must be 1, 2, or both") } if (1 %in% MARGIN) { nr <- NROW(y) if (nr > 1) { xx <- floor(nr / 2) y <- y[c((xx + 1):nr, 1:xx), ] } } if (2 %in% MARGIN) { nc <- NCOL(y) if (nc > 1) { xx <- floor(nc / 2) y <- y[, c((xx + 1):nc, 1:xx)] } } } else { stop("x must be a vector or matrix") } y } gsignal/R/kaiser.R0000644000176200001440000000542714420222025013501 0ustar liggesusers# kaiser.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1995, 1996, 1997 Kurt Hornik # Copyright (C) 2000 Paul Kienzle # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # 20191215 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Kaiser window #' #' Return the filter coefficients of a kaiser window of length \code{n}. #' #' The Kaiser, or Kaiser-Bessel, window is a simple approximation of the DPSS #' window using Bessel functions, discovered by James Kaiser. #' \if{latex}{ #' \deqn{w(x) = \frac{besselI(0, \beta \cdot \sqrt{(1 - #' (2*x/m)^{2}))}}{besselI(0, \beta)}; -m/2 <= x <= m/2} #' } #' \if{html}{\preformatted{ #' besselI(0, Beta * sqrt(1-(2*x/m)^2)) #' k(x) = -------------------------------------, -m/2 <= x <= m/2 #' besselO(0, Beta) #' }} #' The variable parameter \eqn{\beta} determines the trade-off between main lobe #' width and side lobe levels of the spectral leakage pattern. Increasing #' \eqn{\beta} widens the main lobe and decreases the amplitude of the side #' lobes (i.e., increases the attenuation). #' #' @param n Window length, specified as a positive integer. #' @param beta Shape factor, specified as a positive real scalar. The parameter #' \code{beta} affects the side lobe attenuation of the Fourier transform of #' the window. Default: 0.5 #' #' @return Kaiser window, returned as a vector. #' #' @examples #' #' k <- kaiser(200, 2.5) #' plot (k, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' @author Kurt Hornik, \email{Kurt.Hornik@@ci.tuwien.ac.at},\cr Paul Kienzle, #' \email{pkienzle@@users.sf.net}.\cr Conversion to R by Geert van Boxtel #' \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export kaiser <- function(n, beta = 0.5) { if (!isPosscal(n) || !isWhole(n) || n <= 0) stop("n must be an integer strictly positive") if (!isScalar(beta) || !is.double(beta)) stop("beta must be a real scalar") if (n == 1) { w <- 1 } else { N <- n - 1 k <- (0:N) k <- 2 * beta / N * sqrt(k * (N - k)) w <- besselI(k, 0) / besselI(beta, 0) } w } gsignal/R/gsignal.R0000644000176200001440000000127514420222025013644 0ustar liggesusers#' @details #' #' The package 'gsignal' is an implementation in R of the 'Octave' package #' 'signal'. It provides signal processing algorithms for use with R, include #' the creation of waveforms, FIR and IIR filter design, spectral analysis, #' Fourier and other transforms, window functions, and resampling and rate #' changing. #' #' The 'Octave' package 'signal' release 1.4.1 (2019-02-08) was used to port the #' functions to R. Note that compatibility of function parameters and return #' values was not explicitly pursued. #' #' @references \url{https://wiki.octave.org/Signal_package},\cr #' \url{https://octave.sourceforge.io/signal/} #' #' @keywords internal "_PACKAGE" #> [1] "_PACKAGE" gsignal/R/cplxreal.R0000644000176200001440000000625514420222025014035 0ustar liggesusers# cplxreal.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200327 GvB setup for gsignal v0.1.0 # 20200331 GvB return only positive imaginary numbers in zc # 20200402 GvB only test Im(v) against tol to determine whether # complex or real # 20210405 GvB changed 'dim' argument to MARGIN #------------------------------------------------------------------------------ #' Sort complex conjugate pairs and real #' #' Sort numbers into into complex-conjugate-valued and real-valued elements. #' #' An error is signaled if some complex numbers could not be paired and if all #' complex numbers are not exact conjugates (to within tol). Note that here is #' no defined order for pairs with identical real parts but differing imaginary #' parts. #' #' @param z Vector, matrix, or array of complex numbers. #' @param tol Weighting factor \code{0 < tol < 1}, which determines the #' tolerance of matching. Default: \code{100 * .Machine$double.eps}. #' @param MARGIN Vector giving the subscripts which the function will be applied #' over. E.g., for a matrix 1 indicates rows, 2 indicates columns, c(1, 2) #' indicates rows and columns. Where X has named dimnames, it can be a #' character vector selecting dimension names. Default: 2 (columns). #' #' @return A list containing two variables: #' \describe{ #' \item{zc}{Vector, matrix or array containing ordered complex conjugate #' pairs by increasing real parts. Only the positive imaginary complex numbers #' of each complex conjugate pair are returned.} #' \item{zr}{Vector, matrix or array containing ordered real numbers.} #' } #' #' @examples #' r <- cplxreal(c(1, 1 + 3i, 2 - 5i, 1-3i, 2 + 5i, 4, 3)) #' #' @author Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{cplxpair}} #' #' @export cplxreal <- function(z, tol = 100 * .Machine$double.eps, MARGIN = 2) { y <- cplxpair(z, tol, MARGIN) getr <- function(v) { lv <- length(v) ix <- rep(NA, lv) for (i in 1:lv) { if (abs(Im(v[i])) <= tol) ix[i] <- i } Re(v[which(!is.na(ix))]) } getc <- function(v) { lv <- length(v) ix <- rep(NA, lv) for (i in 1:lv) { if (abs(Im(v[i])) > tol) ix[i] <- i } v <- v[which(!is.na(ix))] if (length(v)) { v <- v[seq(2, length(v), 2)] # only pos imag numbers } else { v <- NULL } v } if (is.vector(y)) { zc <- getc(y) zr <- getr(y) } else { zc <- apply(y, MARGIN, getc) zr <- apply(y, MARGIN, getr) } list(zc = zc, zr = zr) } gsignal/R/fftconv.R0000644000176200001440000000514214420222025013662 0ustar liggesusers# fftconv.R # Copyright (C) 2020 Geert van Boxtel # Octave function: # Copyright (C) 1994-2017 John W. Eaton # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200420 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' FFT-based convolution #' #' Convolve two vectors using the FFT for computation. #' #' The computation uses the FFT by calling the function \code{fftfilt}. If the #' optional argument \code{n} is specified, an \code{n}-point overlap-add FFT is #' used. #' #' @param x,y input vectors. #' @param n FFT length, specified as a positive integer. The FFT size must be an #' even power of 2 and must be greater than or equal to the length of #' \code{filt}. If the specified \code{n} does not meet these criteria, it is #' automatically adjusted to the nearest value that does. If \code{n = NULL} #' (default), then the overlap-add method is not used. #' #' @return Convoluted signal, specified as a a vector of length equal to #' \code{length (x) + length (y) - 1}. If \code{x} and \code{y} are the #' coefficient vectors of two polynomials, the returned value is the #' coefficient vector of the product polynomial. #' #' @examples #' #' u <- rep(1L, 3) #' v <- c(1, 1, 0, 0, 0, 1, 1) #' w1 <- conv(u, v) # time-domain convolution #' w2 <- fftconv(u, v) # frequency domain convolution #' all.equal(w1, w2) # same results #' #' @seealso \code{\link{conv}}, \code{\link{conv2}} #' #' @author Kurt Hornik, \email{Kurt.Hornik@@wu-wien.ac.at},\cr #' adapted by John W. Eaton.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export fftconv <- function(x, y, n = NULL) { if (!(is.vector(x) && is.vector(y))) { stop("both x and y must be vectors") } lx <- length(x) ly <- length(y) if ((lx == 1) || (ly == 1)) { z <- x * y } else { lz <- lx + ly - 1 x <- postpad(x, lz) y <- postpad(y, lz) z <- fftfilt(x, y, n) } z } gsignal/R/wconv.R0000644000176200001440000000632414420222025013354 0ustar liggesusers# wconv.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function Copyright (C) 2013 Lukas F. Reichlin # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200228 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' 1-D or 2-D convolution #' #' Compute the one- or two-dimensional convolution of two vectors or matrices. #' #' @param type Numeric or character, specifies the type of convolution to #' perform: #' \describe{ #' \item{"1d"}{For \code{a} and \code{b} as (coerced to) vectors, #' perform 1-D convolution of \code{a} and \code{b};} #' \item{"2d}{For \code{a} and \code{b} as (coerced to) #' matrices, perform 2-D convolution of \code{a} and \code{b};} #' \item{"row"}{For \code{a} as (coerced to) a matrix, and \code{b} #' (coerced to) a vector, perform the 1-D convolution of the rows of \code{a} #' and \code{b};} #' \item{"column"}{For \code{a} as (coerced to) a matrix, and \code{b} #' (coerced to) a vector, perform the 1-D convolution of the colums of #' \code{a} and \code{b};} #' } #' @param a,b Input vectors or matrices, coerced to numeric. #' @param shape Subsection of convolution, partially matched to: #' \describe{ #' \item{"full"}{Return the full convolution (default)} #' \item{"same"}{Return the central part of the convolution with the same size #' as A. The central part of the convolution begins at the indices #' \code{floor(c(nrow(b), ncol(b)) / 2 + 1)}} #' \item{"valid"}{Return only the parts which do not include zero-padded edges. #' The size of the result is \code{max(c(nrow(a), ncol(b)) - c(nrow(b), #' ncol(b)) + 1, 0)}} #' } #' #' @return Convolution of input matrices, returned as a matrix or a vector. #' #' @examples #' a <- matrix(1:16, 4, 4) #' b <- matrix(1:9, 3,3) #' w <- wconv('2', a, b) #' w <- wconv('1', a, b, 'same') #' w <- wconv('r', a, b) #' w <- wconv('r', a, c(0,1), 'same') #' w <- wconv('c', a, c(0,1), 'valid') #' #' @seealso \code{\link{conv}} #' #' @author Lukas Reichlin, \email{lukas.reichlin@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export wconv <- function(type = c("1d", "2d", "row", "column"), a, b, shape = c("full", "same", "valid")) { type <- match.arg(type) shape <- match.arg(shape) y <- switch(type, "1d" = conv(as.vector(a), as.vector(b), shape), "2d" = conv2(as.matrix(a), as.matrix(b), shape), "row" = conv2(as.matrix(a), t(as.vector(b)), shape), "column" = t(conv2(t(as.matrix(a)), t(as.vector(b)), shape)) ) y } gsignal/R/polystab.R0000644000176200001440000000332314420222025014051 0ustar liggesusers# polystab.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 2001 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200623 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Stabilize polynomial #' #' Stabilize the polynomial transfer function by replacing all roots outside the #' unit circle with their reflection inside the unit circle. #' #' @param a vector of polynomial coefficients, normally in the z-domain #' #' @return Vector of stabilized polynomial coefficients. #' #' @examples #' unstable <- c(-0.5, 1) #' zplane(unstable, 1) #' stable <- polystab(unstable) #' zplane(stable, 1) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr Conversion to R by #' Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com} # #' @export polystab <- function(a) { r <- pracma::roots(a) v <- which(abs(r) > 1) if (length(v)) { r[v] <- 1 / Conj(r[v]) b <- a[1] * poly(r) if (is.numeric(a)) { b <- Re(b) } } else { b <- a } b } gsignal/R/diric.R0000644000176200001440000000536314661617343013336 0ustar liggesusers# diric.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2007 Sylvain Pelissier # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191123 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Dirichlet function #' #' Compute the Dirichlet or periodic sinc function. #' #' \code{y <- diric(x, n)} returns the Dirichlet Function of degree \code{n} #' evaluated at the elements of the input array \code{x}. #' #' The Dirichlet function, or periodic sinc function, has period \eqn{2 \pi} for #' odd \eqn{N} and period \eqn{4 \pi} for even \eqn{N}. Its maximum value is 1 #' for all N, and its minimum value is -1 for even N. The magnitude of the #' function is 1 / N times the magnitude of the discrete-time Fourier transform #' of the N-point rectangular window. #' #' @param x Input array, specified as a real scalar, vector, matrix, or #' multidimensional array. When \code{x} is non-scalar, \code{diric} is an #' element-wise operation. #' @param n Function degree, specified as a positive integer scalar. #' #' @return Output array, returned as a real-valued scalar, vector, matrix, or #' multidimensional array of the same size as x. #' #' @examples #' #' ## Compute and plot the Dirichlet function between -2pi and 2pi for N = 7 #' ## and N = 8. The function has a period of 2pi for odd N and 4pi for even N. #' x <- seq(-2*pi, 2*pi, len = 301) #' d7 <- diric(x, 7) #' d8 <- diric(x, 8) #' op <- par(mfrow = c(2,1)) #' plot(x/pi, d7, type="l", main = "Dirichlet function", #' xlab = "", ylab = "N = 7") #' plot(x/pi, d8, type="l", ylab = "N = 8", xlab = expression(x / pi)) #' par(op) #' #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export diric <- function(x, n) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) stop("n must be an integer strictly positive") y <- sin(n * x / 2) / (n * sin(x / 2)) y[x %% (2 * pi) == 0] <- (-1) ^ ((n - 1) * x[x %% (2 * pi) == 0] / (2 * pi)) y } gsignal/R/invimpinvar.R0000644000176200001440000000745314420222025014566 0ustar liggesusers# invimpinvar.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 2007 R.G.H. Eschauzier # Copyright (C) 2011 Carne Draug # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200622 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Inverse impulse invariance method #' #' Convert digital filter with coefficients b and a to analog, conserving #' impulse response. #' #' Because \code{invimpinvar} is generic, it can also accept input of class #' \code{\link{Arma}}. #' #' @param b coefficients of numerator polynomial #' @param a coefficients of denominator polynomial #' @param fs sampling frequency (Default: 1 Hz) #' @param tol tolerance. Default: 0.0001 #' @param ... additional arguments (not used) #' #' @return A list of class \code{\link{Arma}} containing numerator and #' denominator polynomial filter coefficients of the A/D converted filter. #' #' @examples #' f <- 2 #' fs <- 10 #' but <- butter(6, 2 * pi * f, 'low', 's') #' zbut <- impinvar(but, fs) #' sbut <- invimpinvar(zbut, fs) #' all.equal(but, sbut, tolerance = 1e-7) #' #' @author R.G.H. Eschauzier, \email{reschauzier@@yahoo.com},\cr #' Carne Draug, \email{carandraug+dev@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com} #' #' @seealso \code{\link{impinvar}} #' #' @references Thomas J. Cavicchi (1996) Impulse invariance and multiple-order #' poles. IEEE transactions on signal processing, Vol 40 (9): 2344--2347. #' #' @rdname invimpinvar #' @export invimpinvar <- function(b, ...) UseMethod("invimpinvar") #' @rdname invimpinvar #' @export invimpinvar.Arma <- function(b, ...) invimpinvar(b$b, b$a, ...) #' @rdname invimpinvar #' @export invimpinvar.default <- function(b, a, fs = 1, tol = 0.0001, ...) { if (!isPosscal(fs)) { stop("fs must be a positive scalar") } if (!isPosscal(tol)) { stop("tol must be a positive scalar") } ts <- 1 / fs b <- c(b, 0) rpk_in <- residue(b, a) n <- length(rpk_in$r) if (length(rpk_in$k) > 1) { stop("Order numerator > order denominator") } r_out <- rep(0L, n) sm_out <- rep(0L, n) i <- 1 while (i <= n) { m <- 1 first_pole <- rpk_in$p[i] while (i < n && abs(first_pole - rpk_in$p[i + 1]) < tol) { i <- i + 1 m <- m + 1 } rpk_out <- inv_z_res(rpk_in$r[(i - m + 1):i], first_pole, ts) rpk_in$k <- rpk_in$k - rpk_out$k sm_out[(i - m + 1):i] <- rpk_out$p r_out[(i - m + 1):i] <- rpk_out$r i <- i + 1 } ba <- inv_residue(r_out, sm_out, 0, tol) a <- zapIm(ba$a) b <- zapIm(ba$b) b <- polyreduce(zapsmall(b)) Arma(b, a) } ## Inverse function of z_res (see impinvar source) inv_z_res <- function(r_in, p_in, ts) { n <- length(r_in) r_out <- rep(0L, n) j <- n while (j > 1) { r_out[j] <- r_in[j] / ((ts * p_in)^j) r_in[1:j] <- r_in[1:j] - r_out[j] * rev(h1_z_deriv(j - 1, p_in, ts)) j <- j - 1 } r_out[1] <- r_in[1] / ((ts * p_in)) k_out <- r_in[1] / p_in sm_out <- log(p_in) / ts list(r = r_out, p = sm_out, k = k_out) } # Source code of h1_deriv and h1_z_deriv in impinvar.R gsignal/R/sgolay.R0000644000176200001440000001163514420222025013517 0ustar liggesusers# sgolay.R # Copyright (C) 2020 Geert van Boxtel # Original Matlab/Octave version: # Copyright (C) 2001 Paul Kienzle # Copyright (C) 2004 Pascal Dupuis # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200322 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Savitzky-Golay filter design #' #' Compute the filter coefficients for all Savitzky-Golay FIR smoothing filters. #' #' The early rows of the resulting filter smooth based on future values and #' later rows smooth based on past values, with the middle row using half future #' and half past. In particular, you can use row \code{i} to estimate #' \code{x(k)} based on the \code{i-1} preceding values and the \code{n-i} #' following values of \code{x} values as \code{y(k) = F[i, ] * #' x[(k - i + 1):(k + n -i)]}. #' #' Normally, you would apply the first \code{(n-1)/2} rows to the first \code{k} #' points of the vector, the last \code{k} rows to the last \code{k} points of #' the vector and middle row to the remainder, but for example if you were #' running on a real-time system where you wanted to smooth based on the all the #' data collected up to the current time, with a lag of five samples, you could #' apply just the filter on row \code{n - 5} to your window of length \code{n} #' each time you added a new sample. #' #' @param p Polynomial filter order; must be smaller than \code{n}. #' @param n Filter length; must a an odd positive integer. #' @param m Return the m-th derivative of the filter coefficients. Default: 0 #' @param ts Scaling factor. Default: 1 #' #' @return An square matrix with dimensions \code{length(n)} that is of class #' \code{"sgolayFilter"}, so it can be used with \code{filter}. #' #' @examples #' ## Generate a signal that consists of a 0.2 Hz sinusoid embedded #' ## in white Gaussian noise and sampled five times a second for 200 seconds. #' dt <- 1 / 5 #' t <- seq(0, 200 - dt, dt) #' x <- 5 * sin(2 * pi * 0.2 * t) + rnorm(length(t)) #' ## Use sgolay to smooth the signal. #' ## Use 21-sample frames and fourth order polynomials. #' p <- 4 #' n <- 21 #' sg <- sgolay(p, n) #' ## Compute the steady-state portion of the signal by convolving it #' ## with the center row of b. #' ycenter <- conv(x, sg[(n + 1)/2, ], 'valid') #' ## Compute the transients. Use the last rows of b for the startup #' ## and the first rows of b for the terminal. #' ybegin <- sg[seq(nrow(sg), (n + 3) / 2, -1), ] %*% x[seq(n, 1, -1)] #' yend <- sg[seq((n - 1)/2, 1, -1), ] %*% #' x[seq(length(x), (length(x) - (n - 1)), -1)] #' ## Concatenate the transients and the steady-state portion to #' ## generate the complete smoothed signal. #' ## Plot the original signal and the Savitzky-Golay estimate. #' y = c(ybegin, ycenter, yend) #' plot(t, x, type = "l", xlab = "", ylab = "", ylim = c(-8, 10)) #' lines(t, y, col = 2) #' legend("topright", c('Noisy Sinusoid','S-G smoothed sinusoid'), #' lty = 1, col = c(1,2)) #' #' @seealso \code{\link{sgolayfilt}} #' #' @author Paul Kienzle \email{pkienzle@@users.sf.net},\cr #' Pascal Dupuis, \email{Pascal.Dupuis@@esat.kuleuven.ac.be}.\cr #' Conversion to R Tom Short,\cr #' adapted by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export sgolay <- function(p, n, m = 0, ts = 1) { if (!(isPosscal(p) && isWhole(p))) { stop("p must be a positive integer") } if (!(isPosscal(n) && isWhole(n) && n %% 2 == 1 && n > p)) { stop("n must be an odd positive integer > p") } Fm <- matrix(0L, n, n) k <- floor(n / 2) for (row in 1:(k + 1)) { ## Construct a matrix of weights Cij = xi ^ j. The points xi are ## equally spaced on the unit grid, with past points using negative ## values and future points using positive values. Ce <- (((1:n) - row) %*% matrix(1, 1, p + 1)) ^ (matrix(1, n) %*% (0:p)) ## A = pseudo-inverse (C), so C*A = I; this is constructed from the SVD A <- pracma::pinv(Ce, tol = .Machine$double.eps) ## Take the row of the matrix corresponding to the derivative ## you want to compute. Fm[row, ] <- A[(1 + m), ] } ## The filters shifted to the right are symmetric with those to the left. Fm[((k + 2):n), ] <- (-1)^m * Fm[k:1, n:1] if (m > 0) { Fm <- Fm * prod(1:m) / (ts^m) } class(Fm) <- "sgolayFilter" Fm } gsignal/R/specgram.R0000644000176200001440000002231014420222025014012 0ustar liggesusers# specgram.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1999-2001 Paul Kienzle # Original conversion to R by Tom Short # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191204 Geert van Boxtel First version for v0.1.0 # 20210418 GvB v0.3.0 plotting via S3 method # 20220512 GvB plot method for class 'specgram' #------------------------------------------------------------------------------ #' Spectrogram #' #' Spectrogram using short-time Fourier transform. #' #' Generate a spectrogram for the signal \code{x}. The signal is chopped into #' overlapping segments of length \code{n}, and each segment is windowed and #' transformed into the frequency domain using the FFT. The default segment size #' is 256. If \code{fs} is given, it specifies the sampling rate of the input #' signal. The argument \code{window} specifies an alternate window to apply #' rather than the default of \code{hanning(n)}. The argument overlap specifies #' the number of samples overlap between successive segments of the input #' signal. The default overlap is \code{length (window)/2}. #' #' When results of \code{specgram} are printed, a spectrogram will be plotted. #' As with \code{lattice} plots, automatic printing does not work inside loops #' and function calls, so explicit calls to \code{print} or \code{plot} are #' needed there. #' #' The choice of window defines the time-frequency resolution. In speech for #' example, a wide window shows more harmonic detail while a narrow window #' averages over the harmonic detail and shows more formant structure. The shape #' of the window is not so critical so long as it goes gradually to zero on the #' ends. #' #' Step size (which is window length minus overlap) controls the horizontal #' scale of the spectrogram. Decrease it to stretch, or increase it to compress. #' Increasing step size will reduce time resolution, but decreasing it will not #' improve it much beyond the limits imposed by the window size (you do gain a #' little bit, depending on the shape of your window, as the peak of the window #' slides over peaks in the signal energy). The range 1-5 msec is good for #' speech. #' #' FFT length controls the vertical scale. Selecting an FFT length greater than #' the window length does not add any information to the spectrum, but it is a #' good way to interpolate between frequency points which can make for prettier #' spectrograms. #' #' AFTER you have generated the spectral slices, there are a number of decisions #' for displaying them. First the phase information is discarded and the energy #' normalized: #' #' \code{S <- abs(S); S <- S / max(S)} #' #' Then the dynamic range of the signal is chosen. Since information in speech #' is well above the noise floor, it makes sense to eliminate any dynamic range #' at the bottom end. This is done by taking the max of the magnitude and some #' minimum energy such as minE = -40dB. Similarly, there is not much information #' in the very top of the range, so clipping to a maximum energy such as maxE = #' -3dB makes sense: #' #' \code{S <- max(S, 10^(minE / 10)); S <- min(S, 10^(maxE / 10))} #' #' The frequency range of the FFT is from 0 to the Nyquist frequency of one half #' the sampling rate. If the signal of interest is band limited, you do not need #' to display the entire frequency range. In speech for example, most of the #' signal is below 4 kHz, so there is no reason to display up to the Nyquist #' frequency of 10 kHz for a 20 kHz sampling rate. In this case you will want to #' keep only the first 40% of the rows of the returned \code{S} and \code{f}. #' More generally, to display the frequency range from minF to maxF, you could #' use the following row index: #' #' \code{idx <- (f >= minF & f <= maxF)} #' #' Then there is the choice of colormap. A brightness varying colormap such as #' copper or bone gives good shape to the ridges and valleys. A hue varying #' colormap such as jet or hsv gives an indication of the steepness of the #' slopes. In the field that I am working in (neuroscience / electrophysiology) #' rainbow color palettes such as jet are very often used. This is an #' unfortunate choice mainly because (a) colors do not have a natural order, and #' (b) rainbow palettes are not perceptually linear. It would be better to use a #' grayscale palette or the 'cool-to-warm' scheme. The examples show how to do #' this in R. #' #' The final spectrogram is displayed in log energy scale and by convention has #' low frequencies on the bottom of the image. #' #' @param x Input signal, specified as a vector. #' @param n Size of the FFT window. Default: 256 (or less if \code{x} is #' shorter). #' @param fs Sample rate in Hz. Default: 2 #' @param window Either an integer indicating the length of a Hanning window, or #' a vector of values representing the shape of the FFT tapering window. #' Default: hanning(n) #' @param overlap Overlap with previous window. Default: half the window length #' @param col Colormap to use for plotting. Default: \code{grDevices::gray(0:512 #' / 512)} #' @param xlab Label for x-axis of plot. Default: \code{"Time"} #' @param ylab Label for y-axis of plot. Default: \code{"Frequency"} #' @param ... Additional arguments passed to the \code{image} plotting function #' #' @return A list of class \code{specgram} consisting of the following elements: #' \describe{ #' \item{S}{the complex output of the FFT, one row per slice} #' \item{f}{the frequency indices corresponding to the rows of S} #' \item{t}{the time indices corresponding to the columns of S} #' } #' #' @examples #' #' sp <- specgram(chirp(seq(-2, 15, by = 0.001), 400, 10, 100, 'quadratic')) #' specgram(chirp(seq(0, 5, by = 1/8000), 200, 2, 500, #' "logarithmic"), fs = 8000) #' #' # use other color palettes than grayscale #' jet <- grDevices::colorRampPalette( #' c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", #' "yellow", "#FF7F00", "red", "#7F0000")) #' plot(specgram(chirp(seq(0, 5, by = 1/8000), 200, 2, 500, "logarithmic"), #' fs = 8000), col = jet(20)) #' c2w <- grDevices::colorRampPalette(colors = c("red", "white", "blue")) #' plot(specgram(chirp(seq(0, 5, by = 1/8000), 200, 2, 500, "logarithmic"), #' fs = 8000), col = c2w(50)) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Tom Short\cr #' This conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @rdname specgram #' @export #' #' @import grDevices specgram <- function(x, n = min(256, length(x)), fs = 2, window = hanning(n), overlap = ceiling(n / 2)) { if (!is.numeric(x) || !is.vector(x)) stop("x must be a numeric vector") if (!isPosscal(n) || !isWhole(n)) stop("n must be a positive integer") if (n > length(x)) { n <- length(x) warning(paste("FFT segment size adjusted to", n)) } ## if only the window length is given, generate hanning window if (isScalar(window)) { if (!isPosscal(window) || !isWhole(window)) stop("if window is a scalar, it must be a positive integer") window <- hanning(window) } if (!isPosscal(overlap) || !isWhole(overlap)) stop("if window is a scalar, it must be a positive integer") ## compute window offsets win_size <- length(window) if (win_size > n) { n <- win_size warning(paste("FFT segment size adjusted to", n)) } if (overlap >= n) stop("overlap should be smaller than n") step <- win_size - overlap ## build matrix of windowed data slices if (length(x) > win_size) { offset <- seq(1, length(x) - win_size, step) } else { offset <- 1 } S <- matrix(0L, n, length(offset)) for (i in seq_along(offset)) { S[1:win_size, i] <- x[offset[i]:(offset[i] + win_size - 1)] * window } ## compute Fourier transform S <- stats::mvfft(S) ## extract the positive frequency components if (n %% 2 == 1) { ret_n <- (n + 1) / 2 } else { ret_n <- n / 2 } S <- S[1:ret_n, ] f <- (0:(ret_n - 1)) * fs / n t <- offset / fs ret <- list(S = S, f = f, t = t) class(ret) <- "specgram" ret } #' @rdname specgram #' @export plot.specgram <- function(x, col = grDevices::gray(0:512 / 512), xlab = "Time", ylab = "Frequency", ...) { graphics::image(x$t, x$f, 20 * log10(t(abs(x$S))), col = col, xlab = xlab, ylab = ylab, ...) } #' @rdname specgram #' @export print.specgram <- function(x, col = grDevices::gray(0:512 / 512), xlab = "Time", ylab = "Frequency", ...) { graphics::image(x$t, x$f, 20 * log10(t(abs(x$S))), col = col, xlab = xlab, ylab = ylab, ...) }gsignal/R/fwhm.R0000644000176200001440000000721714420222025013163 0ustar liggesusers# fwhm.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Author: Petr Mikulik (2009) # This program is granted to the public domain. # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200415 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Full width at half maximum #' #' Compute peak full-width at half maximum or at another level of peak maximum #' for a vector or matrix. #' #' @param x samples at which \code{y} is measured, specified as a vector. I.e., #' \code{y} is sampled as \code{y[x]}. Default: \code{seq_len(length(y))}. #' @param y signal to find the width of. If \code{y} is a matrix, widths of all #' columns are computed. #' @param ref reference. Compute the width with reference to: #' \describe{ #' \item{\code{"max" | "zero"}}{\code{max(y)}} #' \item{\code{"middle" | "min"}}{\code{min(y) + max(y)}} #' \item{\code{"absolute"}}{an absolute level of \code{y}} #' } #' @param level the level at which to compute the width. Default: 0.5. #' #' @return Full width at half maximum, returned as a vector with a length equal #' to the number of columns in \code{y}, or 1 in case of a vector. #' #' @examples #' x <- seq(-pi, pi, 0.001) #' y <- cos(x) #' w <- fwhm(x, y) #' m <- x[which.max(y)] #' f <- m - w/2 #' t <- m + w/2 #' plot(x, y, type="l", #' panel.first = { #' usr <- par('usr') #' rect(f, usr[3], t, usr[4], col = rgb(0, 1, 0, 0.4), border = NA) #' }) #' abline(h = max(y) / 2, lty = 2, col = "gray") #' #' @author Petr Mikulik.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export fwhm <- function(x = seq_len(length(y)), y, ref = c("max", "zero", "middle", "min", "absolute"), level = 0.5) { if (!is.vector(x)) { stop("x must be a vector") } if (length(x) != NROW(y)) { stop("length of x must match length or number of rows in y") } if (is.vector(y)) { y <- as.matrix(y) } if (is.array(y) && length(dim(y)) > 2) { stop("y must be a vector or a matrix") } nc <- ncol(y) ref <- match.arg(ref) if (!is.numeric(level)) { stop("level must be numeric") } w <- rep(0L, nc) for (icol in seq_len(nc)) { yy <- y[, icol] ly <- length(yy) if (ref == "absolute") { yy <- yy - level } else if (ref == "max" || ref == "zero") { yy <- yy - level * max(yy) } else if (ref == "middle" || ref == "min") { yy <- yy - level * (max(yy) + min(yy)) } ind <- which(yy[1:(ly - 1)] * yy[2:ly] <= 0) if (length(ind) >= 2 && yy[ind[1]] > 0) { ind <- ind[2:length(ind)] } imax <- which.max(yy)[1] li <- length(ind) if (li >= 2 && imax >= ind[1] && imax <= ind[li]) { ind1 <- ind[1] ind2 <- ind1 + 1 xx1 <- x[ind1] - yy[ind1] * (x[ind2] - x[ind1]) / (yy[ind2] - yy[ind1]) ind1 <- ind[li] ind2 <- ind1 + 1 xx2 <- x[ind1] - yy[ind1] * (x[ind2] - x[ind1]) / (yy[ind2] - yy[ind1]) w[icol] <- xx2 - xx1 } } w } gsignal/R/residued.R0000644000176200001440000000511014420222025014014 0ustar liggesusers# residued.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 2005 Julius O. Smith III # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200805 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' delayed z-transform partial fraction expansion #' #' Finds the residues, poles, and direct term of a Partial Fraction Expansion of #' the ratio of two polynomials. #' #' In the usual PFE function \code{residuez}, the IIR part (poles \code{p} and #' residues \code{r}) is driven in parallel with the FIR part (\code{f}). In #' this variant, the IIR part is driven by the output of the FIR part. This #' structure can be more accurate in signal modeling applications. #' #' @param b coefficients of numerator polynomial #' @param a coefficients of denominator polynomial #' #' @return A \code{\link{list}} containing #' \describe{ #' \item{r}{vector of filter pole residues of the partial fraction} #' \item{p}{vector of partial fraction poles} #' \item{k}{vector containing FIR part, if any (empty if \code{length(b) < #' length(a)})} #' } #' #' @seealso \code{\link{residue}}, \code{\link{residuez}} #' #' @references \url{https://ccrma.stanford.edu/~jos/filters/residued.html} #' #' @examples #' b <- c(2, 6, 6, 2) #' a <- c(1, -2, 1) #' resd <- residued(b, a) #' resz <- residuez(b, a) #' #' @author Julius O. Smith III, \email{jos@@ccrma.stanford.edu}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com} #' #' @export residued <- function(b, a) { num <- Conj(b) den <- Conj(a) nb <- length(num) na <- length(den) k <- NULL if (na <= nb) { k <- filter(num, den, c(1L, rep(0L, nb - na))) num <- num - conv(den, k) num <- num[(nb - na + 2):nb] } rpk <- residuez(num, den) if (!is.null(rpk$k)) { stop("rpk$f not empty as expected") } r <- zapIm(rpk$r) p <- zapIm(rpk$p) list(r = r, p = p, k = k) } gsignal/R/gsignal-internal.R0000644000176200001440000000644314473616630015501 0ustar liggesusers# gsignal-internal.R - internal or barely commented # functions not exported from the namespace # # Copyright (C) 2019 Geert van Boxtel, # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20191029 GvB Initial setup # 20200112 GvB Added ssq() msq() rmsq() # 20200507 GvB adapted isWhole() # 20200709 GvB normalized sinc function # 20200820 GvB added strReverse() function # 20211031 GvB added isConjSymm() function # 20230830 GvB check is.null(x) in zapIm #------------------------------------------------------------------------------ #' Internal functions not exported to the namespace #' #' @keywords internal #' @noRd # test if x is a scalar isScalar <- function(x) ifelse(is.character(x), nchar(x) == 1L, (is.atomic(x) && length(x) == 1L)) # test if x is a positive scalar isPosscal <- function(x) isScalar(x) && is.numeric(x) && x >= 0 # test if x is a whole number isWhole <- function(x, tol = .Machine$double.eps * 5) !(is.null(x) || is.character(x)) && any(abs(x - round(x)) < tol) # convert factor to numeric unfactor <- function(f) if (is.factor(f)) as.numeric(levels(f)[as.integer(f)]) else NULL # sinc function sinc <- function(x) ifelse(x == 0, 1, sin(pi * x) / (pi * x)) # sum of squares (assume input is a vector) ssq <- function(x) ifelse(is.complex(x), sum(Re(x * Conj(x))), sum(x * x)) # mean sum of squares (assume input is a vector) msq <- function(x) ssq(x) / length(x) # root mean square (assume input is a vector) rmsq <- function(x) sqrt(msq(x)) # compute next power of 2 nextpow2 <- function(x) 2^ceiling(log2(x)) # convert complex number to real if imaginary part is zero # zapIm <- function(x, nd = 10) if (all(Im(z <- zapsmall(x, nd)) == 0)) # Re(z) else x zapIm <- function(x, tol = .Machine$double.eps * 5) { if (is.null(x)) return(x) z <- all(abs(Im(x)) < tol) if (!is.na(z) && z) Re(x) else x } # reverse string (taken from strsplit examples) strReverse <- function(x) sapply(lapply(strsplit(x, NULL), rev), paste, collapse = "") # convert decimal to binary string # Joshua Ulrich # https://stackoverflow.com/questions/6614283/converting-decimal-to-binary-in-r dec2bin <- function(x) paste(as.integer(rev(intToBits(x))), collapse = "") # convert binary string to decimal bin2dec <- function(x) strtoi(x, 2) # test if vector is conjugate symmetrical # length of x assumed to be > 1 isConjSymm <- function(x) { if (!is.vector(x) || is.character(x)) rv <- FALSE l <- length(x) if (l <= 0) { rv <- FALSE } else if (l == 1) { rv <- TRUE } else { rv <- isTRUE(all.equal(Conj(x[c(1, seq(length(x), 2, -1))]), x, tolerance = 10 * .Machine$double.eps)) } rv } gsignal/R/iirlp2mb.R0000644000176200001440000001701614420222025013740 0ustar liggesusers# iirlp2mb.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2011 Alan J. Greenberger # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200604 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' IIR lowpass filter to IIR multiband #' #' Transform an IIR lowpass filter prototype to an IIR multiband filter. #' #' The utility of a prototype filter comes from the property that all other #' filters can be derived from it by applying a scaling factor to the components #' of the prototype. The filter design need thus only be carried out once in #' full, with other filters being obtained by simply applying a scaling factor. #' Especially useful is the ability to transform from one bandform to another. #' In this case, the transform is more than a simple scale factor. Bandform here #' is meant to indicate the category of passband that the filter possesses. The #' usual bandforms are lowpass, highpass, bandpass and bandstop, but others are #' possible. In particular, it is possible for a filter to have multiple #' passbands. In fact, in some treatments, the bandstop filter is considered to #' be a type of multiple passband filter having two passbands. Most commonly, #' the prototype filter is expressed as a lowpass filter, but other techniques #' are possible[1]. #' #' Filters with multiple passbands may be obtained by applying the general #' transformation described in [2]. #' #' Because \code{iirlp2mb} is generic, it can be extended to accept other #' inputs. #' #' @param b numerator polynomial of prototype low pass filter #' @param a denominator polynomial of prototype low pass filter #' @param Wo (normalized angular frequency)/pi to be transformed #' @param Wt vector of (norm. angular frequency)/pi transform targets #' @param type one of "pass" or "stop". Specifies to filter to produce: bandpass #' (default) or bandstop. #' @param ... additional arguments (not used) #' #' @return List of class \code{\link{Arma}} numerator and denominator #' polynomials of the resulting filter. #' #' @examples #' ## Design a prototype real IIR lowpass elliptic filter with a gain of about #' ## –3 dB at 0.5pi rad/sample. #' el <- ellip(3, 0.1, 30, 0.409) #' ## Create a real multiband filter with two passbands. #' mb1 <- iirlp2mb(el, 0.5, c(.2, .4, .6, .8), 'pass') #' ## Create a real multiband filter with two stopbands. #' mb2 <- iirlp2mb(el, 0.5, c(.2, .4, .6, .8), 'stop') #' ## Compare the magnitude responses of the filters. #' hfl <- freqz(el) #' hf1 <- freqz(mb1) #' hf2 <- freqz(mb2) #' plot(hfl$w, 20 * log10(abs(hfl$h)), type = "l", #' xlab = "Normalized frequency (* pi rad/sample)", #' ylab = "Magnitude (dB)") #' lines(hf1$w, 20 * log10(abs(hf1$h)), col="red") #' lines(hf2$w, 20 * log10(abs(hf2$h)), col="blue") #' legend('bottomleft', #' legend = c('Prototype', 'Two passbands', 'Two Stopbands'), #' col=c("black", "red", "blue"), lty = 1) #' #' @references [1] \url{https://en.wikipedia.org/wiki/Prototype_filter}\cr #' [2] \url{https://en.wikipedia.org/wiki/Prototype_filter#Lowpass_to_multi-band} #' #' @author Alan J. Greenberger, \email{alanjg@@ptd.net}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @rdname iirlp2mb #' @export iirlp2mb <- function(b, ...) UseMethod("iirlp2mb") #' @rdname iirlp2mb #' @export iirlp2mb.Arma <- function(b, Wo, Wt, type, ...) { iirlp2mb(b$b, b$a, Wo, Wt, type, ...) } #' @rdname iirlp2mb #' @export iirlp2mb.Zpg <- function(b, Wo, Wt, type, ...) { ba <- as.Arma(b) iirlp2mb(ba$b, ba$a, Wo, Wt, type, ...) } #' @rdname iirlp2mb #' @export iirlp2mb.Sos <- function(b, Wo, Wt, type, ...) { ba <- as.Arma(b) iirlp2mb(ba$b, ba$a, Wo, Wt, type, ...) } #' @rdname iirlp2mb #' @export iirlp2mb.default <- function(b, a, Wo, Wt, type = c("pass", "stop"), ...) { # input validation type <- match.arg(type) if (type == "pass") { pass_stop <- -1 } else if (type == "stop") { pass_stop <- 1 } if (!isPosscal(Wo) || Wo > 1) { stop(paste("Frequency value Wo of prototype filter", "must be a scalar between 0 and 1")) } if (any(Wt < 0) || any(Wt > 1)) { stop("Frequency values Wt of target filter must be between 0 and 1") } Wt <- unique(sort(Wt)) ## The first stage allpass denominator computation K <- apd(pi * Wo) ## The second stage allpass computation phi <- pi * Wt P <- apd(phi) PP <- rev(P) AllpassDen <- P - (K[2] * PP) AllpassDen <- AllpassDen / AllpassDen[1] # normalize AllpassNum <- pass_stop * rev(AllpassDen) ba <- transform(b, a, AllpassNum, AllpassDen, pass_stop) ba } ############################################################################### # Helper functions for iirlp2mb, not exported from the namespace # all pass denominator apd <- function(phi) { Pkm1 <- 1 # P0 initial condition from [FFM] eq. 22 for (k in seq_along(phi)) { P <- pk(Pkm1, k, phi[k]) Pkm1 <- P } P } # kth iteration of P(z) pk <- function(Pkm1, k, phik) { Pk <- rep(0L, k + 1) sin_k <- sin(phik / 2) cos_k <- cos(phik / 2) for (i in 1:k) { Pk[i] <- Pk[i] + sin_k * Pkm1[i] - ((-1)^k * cos_k * Pkm1[k + 1 - i]) Pk[i + 1] <- Pk[i + 1] + sin_k * Pkm1[i] + ((-1)^k * cos_k * Pkm1[k + 1 - i]) } Pk <- Pk / Pk[1] Pk } # Regenerate ith power of P from stored PPower ppower <- function(Ppower, i, powcols) { if (i == 0) { p <- 1 } else { p <- NULL for (j in 1:powcols) { if (is.na(Ppower[i, j])) break p <- cbind(p, Ppower[i, j]) } } p } # add polynomials of possibly different length polysum <- function(p1, p2) { n1 <- length(p1) n2 <- length(p2) if (n1 > n2) { ## pad p2 p2 <- c(p2, rep(0L, n1 - n2)) } else if (n2 > n1) { ## pad p1 p1 <- c(p1, rep(0L, n2 - n1)) } poly <- p1 + p2 poly } transform <- function(B, A, PP, P, pass_stop) { na <- length(A) nb <- length(B) n <- max(na, nb) np <- length(P) powcols <- np + (np - 1) * (n - 2) Ppower <- matrix(NA, nrow = n - 1, ncol = powcols) Ptemp <- P for (i in 1:(n - 1)) { for (j in seq_along(Ptemp)) { Ppower[i, j] <- Ptemp[j] } Ptemp <- conv(Ptemp, P) } ## Compute numerator and denominator of transformed filter Num <- Den <- NULL for (i in 1:n) { if ((n - i) == 0) { p_pownmi <- 1 } else { p_pownmi <- ppower(Ppower, n - i, powcols) } if (i == 1) { pp_powim1 <- 1 } else { pp_powim1 <- rev(ppower(Ppower, i - 1, powcols)) } if (i <= nb) { Bterm <- (pass_stop ^ (i - 1)) * B[i] * conv(pp_powim1, p_pownmi) Num <- polysum(Num, Bterm) } if (i <= na) { Aterm <- (pass_stop ^ (i - 1)) * A[i] * conv(pp_powim1, p_pownmi) Den <- polysum(Den, Aterm) } } ## Scale both numerator and denominator to have Den(1) = 1 Den <- Den / Den[1] Num <- Num / Den[1] Arma(Num, Den) } gsignal/R/mpoles.R0000644000176200001440000000711114420222025013512 0ustar liggesusers# mpoles.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 2007-2017 Ben Abbott # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200606 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Multiplicity of poles #' #' Identify unique poles and their associated multiplicity. #' #' @param p vector of poles. #' @param tol tolerance. If the relative difference of two poles is less than #' \code{tol} then they are considered to be multiples. The default value for #' \code{tol} is 0.001. #' @param reorder logical. If \code{TRUE}, (default), the output is ordered from #' largest pole to smallest pole. #' @param index.return logical indicating if index vector should be returned as #' well. See examples. Default: \code{FALSE}. #' #' @return If \code{index.return = TRUE}, a list consisting of two vectors: #' \describe{ #' \item{m}{vector specifying the multiplicity of the poles} #' \item{n}{index} #' } #' If \code{index.return = FALSE}, only \code{m} is returned (as a vector). #' #' @examples #' p <- c(2, 3, 1, 1, 2) #' ret <- mpoles(p, index = TRUE) #' #' @seealso \code{\link{poly}}, \code{\link{residue}} #' #' @author Ben Abbott, \email{bpabbott@@mac.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com} # #' @export mpoles <- function(p, tol = 0.001, reorder = TRUE, index.return = FALSE) { ## Force the poles to be a vector. p <- as.vector(p) np <- length(p) # tol must be a positive scalar tol <- tol[1] if (!isPosscal(tol)) { stop("'tol' must be a positive scalar") } tol <- abs(tol) # reorder and index.return shuuld be logical if (!is.logical(reorder)) { stop("'reorder' should be TRUE or FALSE") } if (!is.logical(index.return)) { stop("'index.return' should be TRUE or FALSE") } ## Sort the poles according to their magnitidues, largest first. if (reorder) { ## Sort with smallest magnitude first. s <- sort(p, index.return = TRUE) ## Reverse order, largest maginitude first. n <- seq(np, 1, -1) p <- s$x[n] ordr <- s$ix[n] } else { ordr <- seq_len(np) } ## Find pole multiplicty by comparing the relative differnce in the ## poles. multp <- array(0L, np) indx <- NULL n <- which(multp == 0)[1] while (!is.na(n) & n > 0) { dp <- abs(p - p[n]) if (p[n] == 0.0) { if (any(abs(p) > 0 & is.finite(p))) { p0 <- mean(abs(p[abs(p) > 0 & is.finite(p)])) } else { p0 <- 1 } } else { p0 <- abs(p[n]) } k <- which(dp < tol * p0) ## Poles can only be members of one multiplicity group. if (length(indx)) { k <- k[!(k %in% indx)] } m <- seq_len(length(k)) multp[k] <- m indx <- c(indx, k) n <- which(multp == 0)[1] } multp <- as.numeric(multp[indx]) indx <- as.numeric(ordr[indx]) if (index.return) { ret <- list(m = multp, n = indx) } else { ret <- multp } ret } gsignal/R/fir2.R0000644000176200001440000001326114525371607013101 0ustar liggesusers# fir2.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2000 Paul Kienzle # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200703 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Frequency sampling-based FIR filter design #' #' Produce a FIR filter with arbitrary frequency response over frequency bands. #' #' The function linearly interpolates the desired frequency response onto a #' dense grid and then uses the inverse Fourier transform and a Hamming window #' to obtain the filter coefficients. #' #' @param n filter order (1 less than the length of the filter). #' @param f vector of frequency points in the range from 0 to 1, where 1 #' corresponds to the Nyquist frequency. The first point of \code{f} must be 0 #' and the last point must be 1. \code{f} must be sorted in increasing order. #' Duplicate frequency points are allowed and are treated as steps in the #' frequency response. #' @param m vector of the same length as \code{f} containing the desired #' magnitude response at each of the points specified in \code{f}. #' @param grid_n length of ideal frequency response function. \code{grid_n} #' defaults to 512, and should be a power of 2 bigger than \code{n}. #' @param ramp_n transition width for jumps in filter response (defaults to #' \code{grid_n / 20}). A wider ramp gives wider transitions but has better #' stopband characteristics. #' @param window smoothing window. The returned filter is the same shape as the #' smoothing window. Default: \code{hamming(n + 1)}. #' #' @return The FIR filter coefficients, a vector of length \code{n + 1}, of #' class \code{Ma}. #' #' @examples #' f <- c(0, 0.3, 0.3, 0.6, 0.6, 1) #' m <- c(0, 0, 1, 1/2, 0, 0) #' fh <- freqz(fir2(100, f, m)) #' op <- par(mfrow = c(1, 2)) #' plot(f, m, type = "b", ylab = "magnitude", xlab = "Frequency") #' lines(fh$w / pi, abs(fh$h), col = "blue") #' # plot in dB: #' plot(f, 20*log10(m+1e-5), type = "b", ylab = "dB", xlab = "Frequency") #' lines(fh$w / pi, 20*log10(abs(fh$h)), col = "blue") #' par(op) #' #' @seealso \code{\link{Ma}}, \code{\link{filter}}, \code{\link{fftfilt}}, #' \code{\link{fir1}} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R Tom Short,\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export fir2 <- function(n, f, m, grid_n = 512, ramp_n = NULL, window = hamming(n + 1)) { # filter length must be a scalar > 0 if (!isPosscal(n) || !isWhole(n) || n <= 0) { stop("n must be an integer > 0") } ## verify frequency and magnitude vectors are reasonable t <- length(f) if (!is.vector(f) || t < 2 || f[1] != 0 || f[t] != 1 || any(diff(f) < 0)) { stop("frequency vector f must be nondecreasing between 0 and 1") } if (t != length(m)) { stop("frequency vector f and magnitude vector m must be the same length") } ## find the grid spacing and ramp width if (!isPosscal(grid_n)) { stop("grid_n must be a positive scalar") } ## find the window parameter, or default to hamming if (length(window) != n + 1) { stop("window must be of length n+1") } ## ML behavior appears to always round the grid size up to a power of 2 grid_n <- nextpow2(grid_n) ## make sure grid is big enough for the window if (2 * grid_n < n + 1) { grid_n <- nextpow2(n + 1) } # do this AFTER adapting grid_n (hence also the clumsy NULL argument) if (is.null(ramp_n)) { ramp_n <- floor(grid_n / 20) } ## Apply ramps to discontinuities if (ramp_n > 0) { ## remember original frequency points prior to applying ramps basef <- f basem <- m ## separate identical frequencies, but keep the midpoint idx <- which(diff(f) == 0) f[idx] <- f[idx] - ramp_n / grid_n / 2 f[(idx + 1)] <- f[(idx + 1)] + ramp_n / grid_n / 2 f <- c(f, basef[idx]) ## make sure the grid points stay monotonic in [0,1] f[f < 0] <- 0 f[f > 1] <- 1 f <- sort(unique(c(f, basef[idx]))) ## preserve window shape even though f may have changed m <- stats::approx(basef, basem, f, method = "linear", ties = "ordered")$y } ## interpolate between grid points grid <- stats::approx(f, m, seq(0, 1, length = grid_n + 1), method = "linear", ties = "ordered")$y ## Transform frequency response into time response and ## center the response about n/2, truncating the excess if ((n %% 2) == 0) { b <- ifft(c(grid, grid[seq(grid_n, 2, by = -1)])) mid <- (n + 1) / 2 b <- Re(c(b[(2 * grid_n - floor(mid) + 1):(2 * grid_n)], b[1:ceiling(mid)])) } else { ## Add zeros to interpolate by 2, then pick the odd values below. b <- ifft(c(grid, rep(0L, grid_n * 2), grid[seq(grid_n, 2, by = -1)])) b <- 2 * Re(c(b[seq(length(b) - n + 1, length(b), by = 2)], b[seq(2, n + 1, by = 2)])) } ## Multiplication in the time domain is convolution in frequency, ## so multiply by our window now to smooth the frequency response. b <- b * window Ma(b) } gsignal/R/primitive.R0000644000176200001440000000474014420222025014230 0ustar liggesusers# primitive.R # Copyright (C) 2020 Geert van Bxtel # Original OCtave code: # Copyright (C) 2013 Juan Pablo Carbajal # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201123 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Primitive #' #' Calculate the indefinitive integral of a function. #' #' This function is a fancy way of calculating the cumulative sum. #' #' @param FUN the function to calculate the primitive of. #' @param t points at which the function \code{FUN} is evaluated, specified as a #' vector of ascending values #' @param C constant of integration. Default: 0 #' #' @return Vector of integrated function values. #' #' @examples #' f <- function(t) sin(2 * pi * 3 * t) #' t <- c(0, sort(runif(100))) #' F <- primitive (f, t, 0) #' t_true <- seq(0, 1, length.out = 1e3) #' F_true <- (1 - cos(2 * pi * 3 * t_true)) / (2 * pi * 3) #' plot (t, F, xlab = "", ylab = "") #' lines (t_true, F_true, col = "red") #' legend("topright", legend = c("Numerical primitive", "True primitive"), #' lty = c(0, 1), pch = c(1, NA), col = 1:2) #' #' @author Juan Pablo Carbajal.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com} #' #' @seealso \code{\link{cumsum}} # #' @export primitive <- function(FUN, t, C = 0) { FUN <- match.fun(FUN) if (!is.vector(t) || !all(sort(t) == t)) { stop("t must be a vector of ascending values") } if (!isScalar(C)) { stop("C must be a scalar") } F_prev <- t0 <- NULL i_chunk <- function(t, f, init) { if (is.null(init)) { F_prev <<- NULL t0 <<- 0 } else if (is.null(F_prev)) { F_prev <<- init } else { F_prev <<- F_prev + pracma::quadgk(f, t0, t) t0 <<- t } F <- F_prev invisible(F) } i_chunk(0, 0, NULL) y <- unlist(lapply(t, i_chunk, f = FUN, init = C)) y } gsignal/R/cceps.R0000644000176200001440000000661014420222025013313 0ustar liggesusers# cceps.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200828 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Complex cepstral analysis #' #' Return the complex cepstrum of the input vector. #' #' Cepstral analysis is a nonlinear signal processing technique that is applied #' most commonly in speech and image processing, or as a tool to investigate #' periodic structures within frequency spectra, for instance resulting from #' echos/reflections in the signal or to the occurrence of harmonic frequencies #' (partials, overtones). #' #' The cepstrum is used in many variants. Most important are the power cepstrum, #' the complex cepstrum, and real cepstrum. The function \code{cceps} implements #' the complex cepstrum by computing the inverse of the log-transformed FFT, #' i.e., #' #' \deqn{cceps(x) <- ifft(log(fft(x)))} #' #' However, because taking the logarithm of a complex number can lead to #' unexpected results, the phase of \code{fft(x)} needs to be unwrapped before #' taking the log. #' #' @note This function returns slightly different results in comparison with the #' 'Matlab' and 'Octave' equivalents. The 'Octave' version does not apply phase #' unwrapping, but has an optional correction procedure in case of zero phase #' at \eqn{\pi} radians. The present implementation does apply phase #' unwrapping so that the correction procedure is unnecessary. The 'Matlab' #' implementation also applies phase unwrapping, and a circular shift if #' necessary to avoid zero phase at \eqn{\pi} radians. The circular shift is #' not done here. In addition, the 'Octave' version shifts the zero frequency to #' the center of the series, which neither the 'Matlab' nor the present #' implementation do. #' #' @param x input data, specified as a real vector. #' #' @return Complex cepstrum, returned as a vector. #' #' @examples #' ## Generate a sine of frequency 45 Hz, sampled at 100 Hz. #' fs <- 100 #' t <- seq(0, 1.27, 1/fs) #' s1 <- sin(2 * pi * 45 * t) #' ## Add an echo with half the amplitude and 0.2 s later. #' s2 <- s1 + 0.5 * c(rep(0L, 20), s1[1:108]) #' ## Compute the complex cepstrum of the signal. Notice the echo at 0.2 s. #' cep <- cceps(s2) #' plot(t, cep, type="l") #' #' @references \url{https://en.wikipedia.org/wiki/Cepstrum} #' #' @seealso \code{\link{rceps}} #' #' @author Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export cceps <- function(x) { if (!is.vector(x) || !is.numeric(x)) { stop("x must be a numeric vector") } X <- stats::fft(x) if (min(abs(X)) == 0) { stop("signal has Fourier coefficients equal to 0") } uw <- unwrap(Arg(X)) logX <- complex(real = log(Mod(X)), imaginary = uw) y <- Re(ifft(logX)) y } gsignal/R/blackmannuttall.R0000644000176200001440000000545214420222025015375 0ustar liggesusers# blackmannuttall.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2007 Muthiah Annamalai # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191210 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Blackman-Nuttall window #' #' Return the filter coefficients of a Blackman-Nuttal window. #' #' The Blackman-Nuttall window is a member of the family of cosine sum windows. #' #' @param n Window length, specified as a positive integer. #' @param method Character string. Window sampling method, specified as: #' \describe{ #' \item{"symmetric" (Default)}{Use this option when using windows for filter #' design.} #' \item{"periodic"}{This option is useful for spectral analysis because it #' enables a windowed signal to have the perfect periodic extension implicit #' in the discrete Fourier transform. When "periodic" is specified, the #' function computes a window of length \code{n + 1} and returns the first #' \code{n} points.} #' } #' #' @return Blackman-Nuttall window, returned as a vector. #' #' @examples #' #' b <- blackmannuttall(64) #' plot (b, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' bs = blackmannuttall(64,'symmetric') #' bp = blackmannuttall(63,'periodic') #' plot (bs, type = "l", xlab = "Samples", ylab =" Amplitude") #' lines(bp, col="red") #' #' @author Muthiah Annamalai, \email{muthiah.annamalai@@uta.edu}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export blackmannuttall <- function(n, method = c("symmetric", "periodic")) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) { stop("n must be an integer strictly positive") } method <- match.arg(method) if (method == "periodic") { N <- n } else if (method == "symmetric") { N <- n - 1 } else { stop("method must be either 'periodic' or 'symmetric'") } if (n == 1) { w <- 1 } else { a0 <- 0.3635819 a1 <- 0.4891775 a2 <- 0.1365995 a3 <- 0.0106411 k <- 0:(n - 1) w <- a0 - a1 * cos(2 * pi * k / N) + a2 * cos(4 * pi * k / N) - a3 * cos(6 * pi * k / N) } w } gsignal/R/buffer.R0000644000176200001440000003422214420222025013467 0ustar liggesusers# buffer.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2008 David Bateman # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191120 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Buffer signal vector into matrix of data segments #' #' Partition a signal vector into nonoverlapping, overlapping, or underlapping #' data segments. #' #' \code{y <- buffer(x, n)} partitions a signal vector \code{x} of length #' \code{L} into nonoverlapping data segments of length \code{n}. Each data #' segment occupies one column of matrix output \code{y}, which has \code{n} #' rows and \code{ceil(L / n)} columns. If \code{L} is not evenly divisible by #' \code{n}, the last column is zero-padded to length \code{n}. #' #' \code{y <- buffer(x, n, p)} overlaps or underlaps successive frames in the #' output matrix by \code{p} samples. #' \itemize{ #' \item {For \code{0 < p < n} (overlap), buffer repeats the final \code{p} #' samples of each segment at the beginning of the following segment. See the #' example where \code{x = 1:30}, \code{n = 7}, and an overlap of \code{p = 3}. #' In this case, the first segment starts with \code{p} zeros (the default #' initial condition), and the number of columns in \code{y} is \code{ceil(L / #' (n - p))}.} #' \item {For \code{p < 0} (underlap), buffer skips \code{p} samples between #' consecutive segments. See the example where \code{x = 1:30}, \code{n = 7}, #' and \code{p = -3}. The number of columns in \code{y} is \code{ceil(L / (n - #' p))}.} #' } #' #' In \code{y <- buffer(x, n, p, opt)}, \code{opt} specifies a vector of samples #' to precede \code{x[1]} in an overlapping buffer, or the number of initial #' samples to skip in an underlapping buffer. #' \itemize{ #' \item {For \code{0 < p < n} (overlap), \code{opt} specifies a vector of #' length \code{p} to insert before \code{x[1]} in the buffer. This vector can #' be considered an initial condition, which is needed when the current #' buffering operation is one in a sequence of consecutive buffering #' operations. To maintain the desired segment overlap from one buffer to the #' next, \code{opt} should contain the final \code{p} samples of the previous #' buffer in the sequence. Set \code{opt} to \code{"nodelay"} to skip the #' initial condition and begin filling the buffer immediately with #' \code{x[1]}. In this case, \code{L} must be \code{length(p)} or longer. See #' the example where \code{x = 1:30}, \code{n = 7}, \code{p = 3}, and #' \code{opt = "nodelay"}.} #' \item {For \code{p < 0} (underlap), \code{opt} is an integer value in the #' range \code{0 : -p} specifying the number of initial input samples, #' \code{x[1:opt]}, to skip before adding samples to the buffer. The first #' value in the buffer is therefore \code{x[opt + 1]}.} #' } #' The \code{opt} option is especially useful when the current buffering #' operation is one in a sequence of consecutive buffering operations. To #' maintain the desired frame underlap from one buffer to the next, \code{opt} #' should equal the difference between the total number of points to skip #' between frames (\code{p}) and the number of points that were available to be #' skipped in the previous input to buffer. If the previous input had fewer than #' p points that could be skipped after filling the final frame of that buffer, #' the remaining opt points need to be removed from the first frame of the #' current buffer. See Continuous Buffering for an example of how this works in #' practice. #' #' \code{buf <- buffer(..., zopt = TRUE)} returns the last \code{p} samples of a #' overlapping buffer in output \code{buf$opt}. In an underlapping buffer, #' \code{buf$opt} is the difference between the total number of points to skip #' between frames (\code{-p}) and the number of points in \code{x} that were #' available to be skipped after filling the last frame: #' \itemize{ #' \item {For \code{0 < p < n} (overlap), \code{buf$opt} contains the final #' \code{p} samples in the last frame of the buffer. This vector can be used #' as the initial condition for a subsequent buffering operation in a sequence #' of consecutive buffering operations. This allows the desired frame overlap #' to be maintained from one buffer to the next. See Continuous Buffering #' below.} #' \item {For \code{p < 0} (underlap), \code{buf$opt} is the difference #' between the total number of points to skip between frames \code{(-p)} and #' the number of points in \code{x} that were available to be skipped after #' filling the last frame: \code{buf$opt = m*(n-p) + opt - L} where \code{opt} #' on the right is the input argument to buffer, and \code{buf$opt} on the #' left is the output argument. Note that for an underlapping buffer output #' \code{buf$opt} is always zero when output \code{buf$z} contains data.\cr #' The opt output for an underlapping buffer is especially useful when the #' current buffering operation is one in a sequence of consecutive buffering #' operations. The \code{buf$opt} output from each buffering operation #' specifies the number of samples that need to be skipped at the start of the #' next buffering operation to maintain the desired frame underlap from one #' buffer to the next. If fewer than \code{p} points were available to be #' skipped after filling the final frame of the current buffer, the remaining #' opt points need to be removed from the first frame of the next buffer.} #' } #' In a sequence of buffering operations, the \code{buf$opt} output from each #' operation should be used as the \code{opt} input to the subsequent buffering #' operation. This ensures that the desired frame overlap or underlap is #' maintained from buffer to buffer, as well as from frame to frame within the #' same buffer. See Continuous Buffering below for an example of how this works #' in practice. #' \cr #' #' \strong{Continuous Buffering}\cr\cr #' In a continuous buffering operation, the vector input to the buffer function #' represents one frame in a sequence of frames that make up a discrete signal. #' These signal frames can originate in a frame-based data acquisition process, #' or within a frame-based algorithm like the FFT.\cr #' As an example, you might acquire data from an A/D card in frames of 64 #' samples. In the simplest case, you could rebuffer the data into frames of 16 #' samples; \code{buffer} with \code{n = 16} creates a buffer of four frames #' from each 64-element input frame. The result is that the signal of frame size #' 64 has been converted to a signal of frame size 16; no samples were added or #' removed.\cr #' In the general case where the original signal frame size, \code{L}, is not #' equally divisible by the new frame size, \code{n}, the overflow from the last #' frame needs to be captured and recycled into the following buffer. You can do #' this by iteratively calling buffer on input x with the \code{zopt} parameter #' set to \code{TRUE}. This simply captures any buffer overflow in \code{buf$z}, #' and prepends the data to the subsequent input in the next call to buffer.\cr #' Note that continuous buffering cannot be done without the \code{zopt} #' parameter being set to \code{TRUE}, because the last frame of y (\code{buf$y} #' in this case) is zero padded, which adds new samples to the signal.\cr #' Continuous buffering in the presence of overlap and underlap is handled with #' the \code{opt} parameter, which is used as both an input (\code{opt} and #' output (\code{buf$opt}) to buffer. The two examples on this page demonstrate #' how the \code{opt} parameter should be used. #' #' @param x The data to be buffered. #' @param n The number of rows in the produced data buffer. This is an positive #' integer value and must be supplied. #' @param p An integer less than \code{n} that specifies the under- or overlap #' between column in the data frame. Default 0. #' @param opt In the case of an overlap, \code{opt} can be either a vector of #' length \code{p} or the string \code{'nodelay'}. If \code{opt} is a vector, #' then the first \code{p} entries in \code{y} will be filled with these #' values. If \code{opt} is the string \code{'nodelay'}, then the first value #' of \code{y} corresponds to the first value of \code{x}. In the case of an #' underlap, \code{opt} must be an integer between 0 and \code{-p}. The #' represents the initial underlap of the first \code{y}. The default value #' for \code{opt} the vector \code{matrix (0L, 1, p)} in the case of an #' overlap, or 0 otherwise. #' @param zopt Logical. If TRUE, return values for \code{z} and \code{opt} in #' addition to \code{y}. Default is FALSE (return only \code{y}). #' #' @return If \code{zopt} equals FALSE (the default), this function returns a #' single numerical array containing the buffered data (\code{y}). If #' \code{zopt} equals TRUE, then a \code{list} containing 3 variables is #' returned: \code{y}: the buffered data, \code{z}: the over or underlap (if #' any), \code{opt}: the over- or underlap that might be used for a future #' call to \code{buffer} to allow continuous buffering. #' #' @examples #' ## Examples without continuous buffering #' y <- buffer(1:10, 5) #' y <- buffer(1:10, 4) #' y <- buffer(1:30, 7, 3) #' y <- buffer(1:30, 7, -3) #' y <- buffer(1:30, 7, 3, 'nodelay') #' #' ## Continuous buffering examples #' # with overlap: #' data <- buffer(1:1100, 11) #' n <- 4 #' p <- 1 #' buf <- list(y = NULL, z = NULL, opt = -5) #' for (i in 1:ncol(data)) { #' x <- data[,i] #' buf <- buffer(x = c(buf$z,x), n, p, opt=buf$opt, zopt = TRUE) #' } #' # with underlap: #' data <- buffer(1:1100, 11) #' n <- 4 #' p <- -2 #' buf <- list(y = NULL, z = NULL, opt = 1) #' for (i in 1:ncol(data)) { #' x <- data[,i] #' buf <- buffer(x = c(buf$z,x), n, p, opt=buf$opt, zopt = TRUE) #' } #' #' @author David Bateman, \email{adb014@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com} #' #' @export buffer <- function(x, n, p = 0, opt, zopt = FALSE) { # parameter checking etc. if (is.data.frame(x)) x <- as.vector(x[, 1]) else x <- as.vector(x) if (!isScalar(n) || !isWhole(n)) stop("n must be an integer") if (!isScalar(p) || !isWhole(p) || p >= n) stop("p must be an integer less than n") if (missing(opt)) { if (p < 0) { opt <- 0 } else { opt <- matrix(0L, 1, p) } } if (p < 0) { if (isScalar(opt) && isWhole(opt) && opt >= 0 && opt <= -p) { lopt <- opt } else { stop("expecting opt to be an integer between 0 and -p") } } else { lopt <- 0 } if (!is.logical(zopt)) stop("zopt must be a logical") l <- length(x) m <- ceiling((l - lopt) / (n - p)) y <- matrix(0L, n - p, m) y [1:(l - lopt)] <- x[(lopt + 1):l] if (p < 0) { y <- y[- ((nrow(y) + p + 1):nrow(y)), ] } else if (p > 0) { if (is.character(opt)) { if (opt == "nodelay") { y <- rbind(y, matrix(0L, p, m)) if (p > n / 2) { iis <- n - p + 1 iin <- n - p iie <- iis + iin - 1 off <- 1 while (iin > 0) { y[iis:iie, 1:(ncol(y) - off)] <- y[1:iin, (1 + off):ncol(y)] off <- off + 1 iis <- iie + 1 iie <- iie + iin if (iie > n) { iie <- n } iin <- iie - iis + 1 } i <- ((l - 1) %% (n - p)) + 1 j <- floor((l - 1) / (n - p)) + 1 if (all(c(i, j) == c(n - p, m))) { off <- off - 1 } y <- y[, -c((ncol(y) - off + 2):ncol(y))] } else { y[(nrow(y) - p + 1):nrow(y), 1:(ncol(y) - 1)] <- y[(1:p), 2:ncol(y)] if ((m - 1) * (n - p) + p >= l) { y <- y[, -ncol(y)] } } } else { stop(paste("Unexpected string argument to 'opt':", opt)) } } else if (is.numeric(opt)) { if (length(opt) == p) { lopt <- p y <- rbind(matrix(0L, p, m), y) iin <- p off <- 1 out <- 1 while (iin > 0) { y[1:iin, off] <- opt[out:length(opt)] off <- off + 1 iin <- iin - (n - p) out <- out + (n - p) } if (p > n / 2) { iin <- n - p iie <- p iis <- p - iin + 1 off <- 1 while (iie > 0) { y[iis:iie, (1 + off):ncol(y)] <- y[(nrow(y) - iin + 1):nrow(y), 1:(ncol(y) - off)] off <- off + 1 iie <- iis - 1 iis <- iis - iin if (iis < 1) { iis <- 1 } iin <- iie - iis + 1 } } else { y[1:p, 2:ncol(y)] <- y[(nrow(y) - p + 1):nrow(y), 1:(ncol(y) - 1)] } } else { stop("'opt' vector should be of length 'p'") } } else { stop("Unrecognized 'opt' argument") } } if (zopt) { if (p >= 0) { i <- (((l + lopt + p * (ncol(y) - 1)) - 1) %% nrow(y)) + 1 j <- floor(((l + lopt + p * (ncol(y) - 1)) - 1) / nrow(y)) + 1 if (any(c(i, j) != c(nrow(y), ncol(y)))) { z <- y[(1 + p):i, ncol(y)] y <- y[, -ncol(y)] } else { z <- NULL } } else { i <- ((l - lopt - 1) %% (nrow(y) - p)) + 1 if (i < nrow(y)) { z <- y[1:i, ncol(y)] y <- y[, -ncol(y)] } else { z <- NULL } } if (p < 0) { opt <- max(0, ncol(y) * (n - p) + opt - l) } else if (p > 0) { opt <- y[(nrow(y) - p + 1):nrow(y), ncol(y)] } else { opt <- NA } return(list(y = y, z = z, opt = opt)) } else { return(y) } } gsignal/R/residue.R0000644000176200001440000001444614420222025013664 0ustar liggesusers# residue.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 1994-2017 John W. Eaton # Copyright (C) 2007 Ben Abbott # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200612 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Partial fraction expansion #' #' Finds the residues, poles, and direct term of a Partial Fraction Expansion of #' the ratio of two polynomials. #' #' The call \code{res <- residue(b, a)} computes the partial fraction expansion #' for the quotient of the polynomials, \code{b} and \code{a}. #' #' The call \code{res <- rresidue(r, p, k)} performs the inverse operation and #' computes the reconstituted quotient of polynomials, b(s) / a(s), from the #' partial fraction expansion; represented by the residues, poles, and a direct #' polynomial specified by \code{r}, \code{p} and \code{k}, and the pole #' multiplicity \code{e}. #' #' @param b coefficients of numerator polynomial #' @param a coefficients of denominator polynomial #' @param r residues of partial fraction expansion #' @param p poles of partial fraction expansion #' @param k direct term #' @param tol tolerance. Default: 0.001 #' #' @return For \code{residue}, a list containing \code{r}, \code{p} and #' \code{k}. For \code{rresidue}, a list containing \code{b} and \code{a}. #' #' @examples #' b <- c(-4, 8) #' a <- c(1, 6, 8) #' rpk <- residue(b, a) #' ba <- rresidue(rpk$r, rpk$p, rpk$k) #' #' @author Tony Richardson, \email{arichard@@stark.cc.oh.us},\cr #' Ben Abbott, \email{bpabbott@@mac.com},\cr #' adapted by John W. Eaton.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com} #' #' @rdname residue #' @export residue <- function(b, a, tol = 0.001) { if (!is.vector(b) || !is.vector(a)) { stop("b and a must be vectors") } tol <- abs(tol[1]) ## Make sure both polynomials are in reduced form. a <- polyreduce(a) b <- polyreduce(b) b <- b / a[1] a <- a / a[1] la <- length(a) lb <- length(b) ## Handle special cases here. if (la == 0 || lb == 0) { return(list(r = NULL, p = NULL, k = NULL)) } else if (la == 1) { k <- b / a return(list(r = NULL, p = NULL, k = k)) } ## Find the poles. p <- pracma::roots(a) lp <- length(p) ## Sort poles so that multiplicity loop will work. mn <- mpoles(p, tol = tol, reorder = TRUE, index.return = TRUE) p <- p[mn$n] ## For each group of pole multiplicity, set the value of each ## pole to the average of the group. This reduces the error in ## the resulting poles. p_group <- cumsum(mn$m == 1) for (ng in seq_len(length(p_group))) { m <- which(p_group == ng) p[m] <- mean(p[m]) } ## Find the direct term if there is one. if (lb >= la) { ## Also return the reduced numerator. qr <- pracma::deconv(b, a) k <- qr$q b <- qr$r lb <- length(b) } else { k <- NULL } ## Determine if the poles are (effectively) zero. small <- max(abs(p)) small <- max(small, 1) * .Machine$double.eps * 1e4 * (1 + length(p))^2 p[abs(p) < small] <- 0 ## Determine if the poles are (effectively) real, or imaginary. index <- (abs(Im(p)) < small) if (any(index)) { p[index] <- Re(p[index]) } index <- (abs(Re(p)) < small) if (any(index)) { p[index] <- 1i * Im(p[index]) } ## The remainder determines the residues. The case of one pole ## is trivial. if (lp == 1) { r <- pracma::polyval(b, p) } else { ## Determine the order of the denominator and remaining numerator. ## With the direct term removed the potential order of the numerator ## is one less than the order of the denominator. aorder <- length(a) - 1 border <- aorder - 1 ## Construct a system of equations relating the individual ## contributions from each residue to the complete numerator. A <- matrix(0L, nrow = border + 1, ncol = border + 1) B <- prepad(b, border + 1, 0) for (ip in seq_along(p)) { ri <- rep(0L, length(p)) ri[ip] <- 1 A[, ip] <- prepad(rresidue(ri, p, NULL, tol)$b, border + 1, 0) } ## Solve for the residues. r <- as.vector(pracma::mldivide(A, B, pinv = FALSE)) } r <- zapIm(r) p <- zapIm(p) list(r = r, p = p, k = k) } #' @rdname residue #' @export rresidue <- function(r, p, k, tol = 0.001) { if (!is.vector(r) || !is.vector(p)) { stop("r and p must be vectors") } tol <- abs(tol[1]) mn <- mpoles(p, tol, reorder = FALSE, index.return = TRUE) indx <- mn$n p <- p[indx] r <- r[indx] indx <- seq_along(p) for (n in indx) { pn <- c(1, -p[n]) if (n == 1) { pden <- pn } else { pden <- fftconv(pden, pn) } } ## D is the order of the denominator ## K is the order of the direct polynomial ## N is the order of the resulting numerator ## pnum(1:(N+1)) is the numerator's polynomial ## pden(1:(D+1)) is the denominator's polynomial ## pm is the multible pole for the nth residue ## pn is the numerator contribution for the nth residue D <- length(pden) - 1 K <- length(k) - 1 N <- K + D pnum <- rep(0L, N + 1) for (n in indx[abs(r) > 0]) { p1 <- c(1, -p[n]) pn <- 1 if (n > 1) { for (j in 1:(n - 1)) { pn <- fftconv(pn, c(1, -p[j])) } } if (n + 1 <= length(p)) { for (j in (n + 1):length(p)) { pn <- fftconv(pn, c(1, -p[j])) } } if (mn$m[n] > 1) { for (j in 1:(mn$m[n] - 1)) { pn <- pracma::deconv(pn, p1)$q } } pn <- r[n] * pn pnum <- pnum + prepad(pn, N + 1, 0, 2) } ## Add the direct term. if (length(k)) { pnum <- pnum + fftconv(pden, k) } pnum <- polyreduce(pnum) pden <- polyreduce(pden) list(b = zapIm(pnum), a = zapIm(pden)) } gsignal/R/signals.R0000644000176200001440000000360614420222025013660 0ustar liggesusers# signals.R # Copyright (C) 2021 Geert van Boxtel, # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20210414 GvB Initial setup (v0.3-1) #------------------------------------------------------------------------------ #' signals #' #' Sample EEG and ECG data. #' #' @author Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com} #' #' @examples #' data(signals) #' time <- seq(0, 10, length.out = nrow(signals)) #' op <- par(mfcol = c(2, 1)) #' plot(time, signals[, 1], type = "l", xlab = "Time", ylab = "EEG (uV)") #' plot(time, signals[, 2], type = "l", xlab = "Time", ylab = "ECG (uV)") #' par(op) #' #' @format A \code{\link{data.frame}} containing 10 seconds of data #' electrophysiological data, sampled at 256 Hz with a 24 bit A/D converter, #' measured in microVolts. The data frame consists of 2 columns (channels): #' \describe{ #' \item{eeg}{electroencephalogram (EEG) data measured from electrode Pz #' according to the 10-20 system, referred to algebraically linked mastoids #' (the brain's alpha rhythm is clearly visible).} #' \item{ecg}{electrocardiogram (ECG) data, recorded bipolarly with a V6 #' versus V1 chest lead (this lead maximizes the R wave of the ECG with #' respect to the P, Q, S, T and U waves of the cardiac cycle).} #' } #' "signals" gsignal/R/hilbert.R0000644000176200001440000000773514420222025013660 0ustar liggesusers# hilbert.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 2000 Paul Kienzle # Copyright (C) 2007 Peter L. Soendergaard # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200709 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Hilbert transform #' #' Computes the extension of a real valued signal to an analytic signal. #' #' The function returns returns a complex helical sequence, sometimes called the #' analytic signal, from a real data sequence. The analytic signal has a real #' part, which is the original data, and an imaginary part, which contains the #' Hilbert transform. The imaginary part is a version of the original real #' sequence with a 90 degrees phase shift. Sines are therefore transformed to #' cosines, and conversely, cosines are transformed to sines. The #' Hilbert-transformed series has the same amplitude and frequency content as #' the original sequence. The transform includes phase information that depends #' on the phase of the original. #' #' @param x Input array, specified as a vector or a matrix. In case of a matrix, #' the Hilbert transform of all columns is computed. #' @param n use an n-point FFT to compute the Hilbert transform. The input data #' is zero-padded or truncated to length n, as appropriate. #' #' @return Analytic signal, of length \code{n}, returned as a complex vector or #' matrix, the real part of which contains the original signal, and the #' imaginary part of which contains the Hilbert transform of \code{x}. #' #' @examples #' ## notice that the imaginary signal is phase-shifted 90 degrees #' t <- seq(0, 10, length = 256) #' z <- hilbert(sin(2 * pi * 0.5 * t)) #' plot(t, Re(z), type = "l", col="blue") #' lines (t, Im(z), col = "red") #' legend('topright', lty = 1, legend = c("Real", "Imag"), #' col = c("blue", "red")) #' #' ## the magnitude of the hilbert transform eliminates the carrier #' t <- seq(0, 10, length = 1024) #' x <- 5 * cos(0.2 * t) * sin(100 * t) #' plot(t, x, type = "l", col = "green") #' lines (t, abs(hilbert(x)), col = "blue") #' legend('topright', lty = 1, legend = c("x", "|hilbert(x)|"), #' col = c("green", "blue")) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Peter L. Soendergaard.\cr #' Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com} #' #' @references \url{https://en.wikipedia.org/wiki/Hilbert_transform}, #' \url{https://en.wikipedia.org/wiki/Analytic_signal} #' #' @export hilbert <- function(x, n = ifelse(is.vector(x), length(x), nrow(x))) { # check arguments if (!(is.vector(x) || is.matrix(x))) { stop("x must be a vector or a matrix") } if (is.character(x)) { stop("x must be a numeric vector or matrix") } if (!is.numeric(x)) { warning("imaginary parts discarded in coercion") x <- Re(x) } if (!isPosscal(n)) { stop("n must be a positive scalar") } # pad input to length n x <- postpad(x, n) # construct multiplication vector if (n %% 2 == 0) { v <- c(1, rep(2, n / 2 - 1), 1, rep(0, n / 2 - 1)) } else { v <- c(1, rep(2, (n - 1) / 2), rep(0, (n - 1) / 2)) } # compute the Hilbert transform if (is.vector(x)) { X <- stats::fft(x) Xv <- X * v y <- ifft(Xv) } else { X <- stats::mvfft(x) Xv <- X * v y <- imvfft(Xv) } y } gsignal/R/bartlett.R0000644000176200001440000000402714420222025014037 0ustar liggesusers# bartlett.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1995-2017 Andreas Weingessel # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191209 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Bartlett window #' #' Return the filter coefficients of a Bartlett (triangular) window. #' #' The Bartlett window is very similar to a triangular window as returned by the #' \code{\link{triang}} function. However, the Bartlett window always has zeros #' at the first and last samples, while the triangular window is nonzero at #' those points. #' #' @param n Window length, specified as a positive integer. #' #' @return Bartlett window, returned as a vector. If you specify a one-point #' window \code{(n = 1)}, the value 1 is returned. #' #' @examples #' #' bw <- bartlett(64) #' plot (bw, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' @seealso \code{\link{triang}} #' #' @author Andreas Weingessel, \email{Andreas.Weingessel@@ci.tuwien.ac.at}. #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export bartlett <- function(n) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) { stop("n must be an integer strictly positive") } if (n == 1) { w <- 1 } else { n <- n - 1 m <- trunc(n / 2) w <- c(2 * (0:m) / n, 2 - 2 * ((m + 1):n) / n) } w } gsignal/R/digitrevorder.R0000644000176200001440000001146314420222025015071 0ustar liggesusers# digitrevorder.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2013-2019 Mike Miller # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200821 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Permute input to digit-reversed order #' #' Reorder the elements of the input vector in digit-reversed order. #' #' This function is useful for pre-ordering a vector of filter coefficients for #' use in frequency-domain filtering algorithms, in which the fft and ifft #' transforms are computed without digit-reversed ordering for improved run-time #' efficiency. #' #' @param x input data, specified as a vector. The length of \code{x} must be an #' integer power of \code{r}. #' @param r radix base used for the number conversion, which can be any integer #' from 2 to 36. The elements of \code{x} are converted to radix \code{r} and #' reversed. #' @param index.return logical indicating if the ordering index vector should be #' returned as well. Default \code{FALSE}. #' #' @return The digit-reversed input vector. If \code{index.return = TRUE}, then #' a list containing the digit-reversed input vector (\code{y}, and the #' digit-reversed indices (\code{i}). #' #' @examples #' #' res <- digitrevorder(0:8, 3) #' #' @author Mike Miller.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{bitrevorder}}, \code{\link{fft}}, \code{\link{ifft}} #' #' @export digitrevorder <- function(x, r, index.return = FALSE) { if (!is.vector(x)) { stop("x must be a vector") } else if (!isPosscal(r) || !isWhole(r) || !(r >= 2 && r <= 36)) { stop("r must be an integer between 2 and 36") } else { tmp <- log(length(x)) / log(r) if (trunc(tmp) != tmp) { stop(paste("x must have length equal to an integer power of", r)) } } if (!is.logical(index.return)) { stop("index.return must be TRUE or FALSE") } old_ind <- seq(0, length(x) - 1) new_ind <- gdec2base(old_ind, r) i <- new_ind + 1 y <- rep(0L, length(x)) y[old_ind + 1] <- x[i] if (index.return) { retval <- list(y, i) } else { retval <- y } retval } # R version of Octave function dec2base, simplified and adapted for use with # digitrevorder, not exported to the namespace) ## Original Octave dec2base: ## Author: Daniel Calvelo ## Adapted-by: Paul Kienzle gdec2base <- function(d, base, len = 0) { # better safe than sorry d <- as.vector(round(abs(as.numeric(d)))) symbols <- c(as.character(0:9), LETTERS) if (is.character(base)) { symbols <- unique(unlist(strsplit(gsub("[[:space:]]", "", base), ""))) base <- length(symbols) } else if (!isScalar(base)) { base <- base[1] } else if (base < 2 || base > length(symbols)) { base <- max(min(base, length(symbols)), 2) } ## determine number of digits required to handle all numbers, can overflow ## by 1 digit max_len <- round(log(max(max(d), 1)) / log(base)) + 1 max_len <- max(max_len, len) ## determine digits for each number digits <- matrix(0L, length(d), max_len) for (k in seq(max_len, 1, -1)) { digits[, k] <- d %% base d <- round((d - digits[, k]) / base) } ## convert digits to symbols retval <- matrix(symbols[digits + 1], nrow = NCOL(digits), ncol = NROW(digits), byrow = TRUE) ## Check if the first element is the zero symbol. It seems possible ## that LEN is provided, and is less than the computed MAX_LEN and ## MAX_LEN is computed to be one larger than necessary, so we would ## have a leading zero to remove. But if LEN >= MAX_LEN, we should ## not remove any leading zeros. if ((len == 0 || (len != 0 && max_len > len)) && NROW(retval) != 1 && !any(retval[1, ] != symbols[1])) { retval <- retval[-1, ] } # GvB: flip and convert back to numeric if retval is a matrix nc <- NCOL(retval); nr <- NROW(retval) if (nc > 1) { if (nr > 1) { retval <- pracma::flipud(retval) } tmp <- array("", nc) for (k in seq_len(nc)) { tmp[k] <- paste0(retval[, k], collapse = "") } retval <- tmp } strtoi(retval, base) } gsignal/R/udecode.R0000644000176200001440000001406114420222025013625 0ustar liggesusers# udecode.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2014 Georgios Ouzounis # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191208 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Uniform decoder #' #' Decode \eqn{2^n}-level quantized integer inputs to floating-point outputs. #' #' \code{y <- udecode(u, n)} inverts the operation of \code{uencode} and #' reconstructs quantized floating-point values from an encoded multidimensional #' array of integers \code{u}. The input argument \code{n} must be an integer #' between 2 and 32. The integer \code{n} specifies that there are \eqn{2^{n}} #' quantization levels for the inputs, so that entries in \code{u} must be #' either: #' \itemize{ #' \item Signed integers in the range \eqn{-2^{n}/2} to \eqn{(2^{n}/2) - 1} #' \item Unsigned integers in the range 0 to \eqn{2^{n} - 1} #' } #' #' Inputs can be real or complex values of any integer data type. Overflows #' (entries in u outside of the ranges specified above) are saturated to the #' endpoints of the range interval. The output has the same dimensions as the #' input \code{u}. Its entries have values in the range -1 to 1. #' #' \code{y <- udecode(u, n, v)} decodes \code{u} such that the output has values #' in the range \code{-v} to \code{v}, where the default value for \code{v} is #' 1. #' #' \code{y <- udecode(u, n, v, saturate)} decodes \code{u} and treats input #' overflows (entries in \code{u} outside of the range \code{-v} to \code{v} #' according to \code{saturate}, which can be set to one of the following: #' \itemize{ #' \item TRUE (default). Saturate overflows. #' \itemize{ #' \item Entries in signed inputs \code{u} whose values are outside of the #' range \eqn{-2^{n}/2} to \eqn{(2^{n}/2) – 1} are assigned the value #' determined by the closest endpoint of this interval. #' \item Entries in unsigned inputs \code{u} whose values are outside of #' the range 0 to \eqn{2^{n}-1} are assigned the value determined by the #' closest endpoint of this interval. #' } #' \item FALSE Wrap all overflows according to the following: #' \itemize{ #' \item Entries in signed inputs \code{u} whose values are outside of the #' range \eqn{-2^{n}/2} to \eqn{(2^{n}/2) – 1} are wrapped back into that #' range using modulo \eqn{2^{n}} arithmetic (calculated using \eqn{u = #' mod(u+2^{n}/2, 2^{n})-(2^{n}/2))}. #' \item Entries in unsigned inputs \code{u} whose values are outside of #' the range 0 to \eqn{2^{n}-1} are wrapped back into the required range #' before decoding using modulo \eqn{2^{n}} arithmetic (calculated using #' \eqn{u = mod(u,2^{n}))}. #' } #' } #' #' @param u Input, a multidimensional array of integer numbers (can be complex). #' @param n Number of levels used in \eqn{2^{n}}-level quantization. \code{n} #' must be between 2 and 32 #' @param v Limit on the range of \code{u} to the range from \code{-v} to #' \code{v} before saturating them. Default 1. #' @param saturate Logical indicating to saturate (TRUE, default) or to wrap #' (FALSE) overflows. See Details. #' #' @return Multidimensional array of the same size as \code{u} containing #' floating point numbers. #' #' @note The real and imaginary components of complex inputs are decoded #' independently. #' #' @examples #' #' u <- c(-1, 1, 2, -5) #' ysat <- udecode(u, 3) #' #' # Notice the last entry in u saturates to 1, the default peak input #' # magnitude. Change the peak input magnitude to 6. #' ysatv <- udecode(u, 3, 6) #' #' # The last input entry still saturates. Wrap the overflows. #' ywrap = udecode(u, 3, 6, FALSE) #' #' # Add more quantization levels. #' yprec <- udecode(u, 5) #' #' @author Georgios Ouzounis, \email{ouzounis_georgios@@hotmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export udecode <- function(u, n, v = 1, saturate = TRUE) { if (!isScalar(n) || n < 2 || n > 32 || !isWhole(n)) stop("n must be an integer in the range 2 to 32") if (!isPosscal(v) || !isWhole(v) || v <= 0) stop("v must be a positive integer") if (!is.logical(saturate)) stop("signed must be a logical") # function to do the actual decoding. # needed because it is run twice for complex input (real + imaginary) decode_it <- function(x) { if (all(x >= 0)) { signed <- FALSE lowerlevel <- 0 upperlevel <- (2^n) - 1 } else { signed <- TRUE lowerlevel <- - 2 ^ (n - 1) upperlevel <- (2 ^ (n - 1)) - 1 } if (saturate) { if (signed) { x[x < lowerlevel] <- lowerlevel x[x > upperlevel] <- upperlevel } else { x[x > upperlevel] <- upperlevel } } else { if (signed) { idx <- which(x < lowerlevel | x > upperlevel) x[idx] <- ((x[idx] + 2 ^ (n - 1)) %% (2^n)) - 2 ^ (n - 1) } else { idx <- which(x > upperlevel) x[idx] <- x[idx] %% 2^n } } width <- 2 * v / 2^n y <- x * width if (!signed) y <- y - v y } if (is.complex(u)) { real_part <- decode_it(Re(u)) imag_part <- decode_it(Im(u)) y <- complex(real = real_part, imaginary = imag_part) # complex() returns a vector not a matrix if (is.matrix(u)) { y <- matrix(y, nrow(u), ncol(u), byrow = TRUE) } } else { y <- decode_it(u) } y } gsignal/R/cheb1ord.R0000644000176200001440000001771014420222025013710 0ustar liggesusers# cheb1ord.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2000 Paul Kienzle # Copyright (C) 2000 Laurent S. Mazet # Copyright (C) 2018 Charles Praplan # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200517 Geert van Boxtel First version for v0.1.0 # 20200708 GvB renamed IIRfspec to FilterSpecs #------------------------------------------------------------------------------ #' Chebyshev Type I filter order #' #' Compute Chebyshev type-I filter order and cutoff for the desired #' response characteristics. #' #' @param Wp,Ws pass-band and stop-band edges. For a low-pass or high-pass #' filter, \code{Wp} and \code{Ws} are scalars. For a band-pass or #' band-rejection filter, both are vectors of length 2. For a low-pass filter, #' \code{Wp < Ws}. For a high-pass filter, \code{Ws > Wp}. For a band-pass #' \code{(Ws[1] < Wp[1] < Wp[2] < Ws[2])} or band-reject \code{(Wp[1] < Ws[1] #' < Ws[2] < Wp[2])} filter design, \code{Wp} gives the edges of the pass #' band, and \code{Ws} gives the edges of the stop band. For digital filters, #' frequencies are normalized to [0, 1], corresponding to the range [0, fs/2]. #' In case of an analog filter, all frequencies are specified in radians per #' second. #' @param Rp allowable decibels of ripple in the pass band. #' @param Rs minimum attenuation in the stop band in dB. #' @param plane "z" for a digital filter or "s" for an analog filter. #' #' @return A list of class \code{'FilterSpecs'} with the following list #' elements: #' \describe{ #' \item{n}{filter order} #' \item{Wc}{cutoff frequency} #' \item{type}{filter type, normally one of \code{"low"}, \code{"high"}, #' \code{"stop"}, or \code{"pass"}.} #' } #' @examples #' ## low-pass 30 Hz filter #' fs <- 128 #' spec <- cheb1ord(30/(fs/2), 40/(fs/2), 0.5, 40) #' cf <- cheby1(spec) #' freqz(cf, fs = fs) #' #' @author Paul Kienzle, Laurent S. Mazet, Charles Praplan.\cr #' Conversion to R by Tom Short, adapted by Geert van Boxtel, #' \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{cheby1}} #' #' @export cheb1ord <- function(Wp, Ws, Rp, Rs, plane = c("z", "s")) { #input validation plane <- match.arg(plane) if (! (is.vector(Wp) && is.vector(Ws) && (length(Wp) == length(Ws)))) { stop("Wp and Ws must both be scalars or vectors of length 2") } if (! ((length(Wp) == 1) || (length(Wp) == 2))) { stop("Wp and Ws must both be scalars or vectors of length 2") } if (plane == "z" && !(is.numeric(Wp) && all(Wp >= 0) && all(Wp <= 1))) { stop("all elements of Wp must be in the range [0,1]") } if (plane == "z" && !(is.numeric(Ws) && all(Ws >= 0) && all(Ws <= 1))) { stop("all elements of Ws must be in the range [0,1]") } if (plane == "s" && !(is.numeric(Wp) && all(Wp >= 0))) { stop("all elements of Wp must be non-negative") } if (plane == "s" && !(is.numeric(Ws) && all(Ws >= 0))) { stop("all elements of Ws must be non-negative") } if ((length(Wp) == 2) && (Wp[2] <= Wp[1])) { stop("Wp[1] must be smaller than Wp[2]") } if ((length(Ws) == 2) && (Ws[2] <= Ws[1])) { stop("Ws[1] must be smaller than Ws[2]") } if ((length(Wp) == 2) && (all(Wp > Ws) || all(Ws > Wp))) { stop("Wp must be contained by Ws or Ws must be contained by Wp") } if (plane == "s") { # No prewarp in case of analog filter Wpw <- Wp Wsw <- Ws } else { ## sampling frequency of 2 Hz T <- 2 Wpw <- (2 / T) * tan(pi * Wp / T) # prewarp Wsw <- (2 / T) * tan(pi * Ws / T) # prewarp } ## pass/stop band to low pass filter transform: if (length(Wpw) == 2 && length(Wsw) == 2) { ## Band-pass filter if (Wpw[1] > Wsw[1]) { ## Modify band edges if not symmetrical. For a band-pass filter, ## the lower or upper stopband limit is moved, resulting in a smaller ## stopband than the caller requested. if (Wpw[1] * Wpw[2] < Wsw[1] * Wsw[2]) { Wsw[2] <- Wpw[1] * Wpw[2] / Wsw[1] } else { Wsw[1] <- Wpw[1] * Wpw[2] / Wsw[2] } w02 <- Wpw[1] * Wpw[2] wp <- Wpw[2] - Wpw[1] ws <- Wsw[2] - Wsw[1] ## Band-stop / band-reject / notch filter } else { ## Modify band edges if not symmetrical. For a band-stop filter, ## the lower or upper passband limit is moved, resulting in a smaller ## rejection band than the caller requested. if (Wpw[1] * Wpw[2] > Wsw[1] * Wsw[2]) { Wpw[2] <- Wsw[1] * Wsw[2] / Wpw[1] } else { Wpw[1] <- Wsw[1] * Wsw[2] / Wpw[2] } w02 <- Wpw[1] * Wpw[2] wp <- w02 / (Wpw[2] - Wpw[1]) ws <- w02 / (Wsw[2] - Wsw[1]) } ws <- ws / wp wp <- 1 ## High-pass filter } else if (Wpw > Wsw) { wp <- Wsw ws <- Wpw ## Low-pass filter } else { wp <- Wpw ws <- Wsw } Wa <- ws / wp ## compute minimum n which satisfies all band edge conditions stop_atten <- 10 ^ (abs(Rs) / 10) pass_atten <- 10 ^ (abs(Rp) / 10) n <- ceiling(acosh(sqrt((stop_atten - 1) / (pass_atten - 1))) / acosh(Wa)) ## compute stopband frequency limits to make the the filter characteristic ## touch either at least one stop band corner or one pass band corner. epsilon <- 1 / sqrt(10 ^ (.1 * abs(Rs)) - 1) k <- cosh(1 / n * acosh(sqrt(1 / (10 ^ (.1 * abs(Rp)) - 1)) / epsilon)) # or k = fstop / fpass ## compute -3dB cutoff given Wp, Rp and n if (length(Wpw) == 2 && length(Wsw) == 2) { ## Band-pass filter if (Wpw[1] > Wsw[1]) { type <- "pass" w_prime_p <- Wpw # same formula as for LP w_prime_s <- Wsw / k # " ## Band-stop / band-reject / notch filter } else { type <- "stop" w_prime_p <- Wpw # same formula as for HP w_prime_s <- k * Wsw # " } ## freq to be returned to match pass band w0 <- sqrt(prod(Wpw)) Q <- w0 / diff(Wpw) # BW at -Rp dB not at -3dB wc <- Wpw W_prime <- w_prime_p[1] / wc[1] # same with w_prime(2)/wc(2) wa <- abs(W_prime + sqrt(W_prime^2 + 4 * Q ^ 2)) / (2 * Q / w0) wb <- abs(W_prime - sqrt(W_prime^2 + 4 * Q ^ 2)) / (2 * Q / w0) Wcw_p <- c(wb, wa) ## freq to be returned to match stop band w0 <- sqrt(prod(Wsw)) Q <- w0 / diff(Wsw) # BW at -Rs dB not at -3dB wc <- Wsw W_prime <- w_prime_s[1] / wc[1] # same with w_prime(2)/wc(2) wa <- abs(W_prime + sqrt(W_prime^2 + 4 * Q ^ 2)) / (2 * Q / w0) wb <- abs(W_prime - sqrt(W_prime^2 + 4 * Q ^ 2)) / (2 * Q / w0) Wcw_s <- c(wb, wa) ## High-pass filter } else if (Wpw > Wsw) { type <- "high" Wcw_p <- Wpw # to match pass band Wcw_s <- Wsw * k # to match stop band ## Low-pass filter } else { type <- "low" Wcw_p <- Wpw # to match pass band Wcw_s <- Wsw / k # to match stop band } if (plane == "s") { # No prewarp in case of analog filter Wc_p <- Wcw_p Wc_s <- Wcw_s } else { # Inverse frequency warping for discrete-time filter Wc_p <- atan(Wcw_p * (T / 2)) * (T / pi) Wc_s <- atan(Wcw_s * (T / 2)) * (T / pi) } FilterSpecs(n = n, Wc = Wc_p, type = type, Wc_s = Wc_s, plane = plane, Rp = Rp) } gsignal/R/grpdelay.R0000644000176200001440000001442414420222025014027 0ustar liggesusers# grpdelay.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 2000 Paul Kienzle # Copyright (C) 2004 Julius O. Smith III # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200422 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Group delay #' #' Compute the average delay of a filter (group delay). #' #' If the denominator of the computation becomes too small, the group delay is #' set to zero. (The group delay approaches infinity when there are poles or #' zeros very close to the unit circle in the z plane.) #' #' @param filt for the default case, the moving-average coefficients of an ARMA #' model or filter. Generically, filt specifies an arbitrary model or filter #' operation. #' @param a the autoregressive (recursive) coefficients of an ARMA filter. #' @param n number of points at which to evaluate the frequency response. If #' \code{n} is a vector with a length greater than 1, then evaluate the #' frequency response at these points. For fastest computation, \code{n} #' should factor into a small number of small primes. Default: 512. #' @param whole FALSE (the default) to evaluate around the upper half of the #' unit circle or TRUE to evaluate around the entire unit circle. #' @param fs sampling frequency in Hz. If not specified, the frequencies are in #' radians. #' @param x object to be plotted. #' @param xlab,ylab,type as in plot, but with more sensible defaults. #' @param ... for methods of grpdelay, arguments are passed to the default #' method. For plot.grpdelay, additional arguments are passed through to plot. #' #' @return A list of class \code{grpdelay} with items: #' \describe{ #' \item{gd}{the group delay, in units of samples. It can be converted to #' seconds by multiplying by the sampling period (or dividing by the sampling #' rate fs).} #' \item{w}{frequencies at which the group delay was calculated.} #' \item{ns}{number of points at which the group delay was calculated.} #' \item{Hzflag}{TRUE for frequencies in Hz, FALSE for frequencies in #' radians.} #' #' } #' #' @examples #' # Two Zeros and Two Poles #' b <- poly(c(1 / 0.9 * exp(1i * pi * 0.2), 0.9 * exp(1i * pi * 0.6))) #' a <- poly(c(0.9 * exp(-1i * pi * 0.6), 1 / 0.9 * exp(-1i * pi * 0.2))) #' gpd <- grpdelay(b, a, 512, whole = TRUE, fs = 1) #' print(gpd) #' plot(gpd) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Julius O. Smith III, \email{jos@@ccrma.stanford.edu}.\cr #' Conversion to R by Tom Short,\cr #' adapted by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com} #' #' @references #' \url{https://ccrma.stanford.edu/~jos/filters/Numerical_Computation_Group_Delay.html}\cr #' \url{https://en.wikipedia.org/wiki/Group_delay} #' #' @rdname grpdelay #' @export grpdelay <- function(filt, ...) UseMethod("grpdelay") #' @rdname grpdelay #' @export print.grpdelay <- function(x, ...) { cat("- Group delay (gd) calculated at", x$ns, "points.\n") cat("- Frequencies (w) given in", if (x$HzFlag) "*Hz*." else "*radians*.", "\n") temp <- data.frame(do.call("cbind", x[c("gd", "w")])) if (nrow(temp) > 8L) { print(utils::head(temp, n = 4L), row.names = FALSE, ...) cat(" ....... .......\n") } else print(temp, row.names = FALSE, ...) invisible(x) } #' @rdname grpdelay #' @export plot.grpdelay <- function(x, xlab = if (x$HzFlag) "Frequency (Hz)" else "Frequency (rad/sample)", ylab = "Group delay (samples)", type = "l", ...) { graphics::plot(x$w[1:x$ns], x$gd[1:x$ns], xlab = xlab, ylab = ylab, type = type, ...) } #' @rdname grpdelay #' @export grpdelay.default <- function(filt, a = 1, n = 512, whole = FALSE, fs = NULL, ...) { b <- as.vector(filt) a <- as.vector(a) n <- as.vector(n) if (whole == "whole" || whole) { whole <- TRUE } else { whole <- FALSE } if (is.null(fs)) { HzFlag <- FALSE fs <- 1 } else { HzFlag <- TRUE } if (length(n) == 1) { nfft <- n if (!whole) { nfft <- 2 * nfft } w <- fs * (0:(nfft - 1)) / nfft if (!HzFlag) { w <- w * 2 * pi } } else if (length(n) > 1) { w <- n nfft <- length(w) * 2 whole <- FALSE } else { stop("n must be a vector with a length >= 1") } oa <- length(a) - 1 # order of a(z) if (oa < 0) { a <- 1 oa <- 0 } ob <- length(b) - 1 # order of b(z) if (ob < 0) { b <- 1 ob <- 0 } oc <- oa + ob # order of c(z) c <- fftconv(b, rev(Conj(a))) cr <- c * (0:oc) num <- stats::fft(postpad(cr, nfft)) den <- stats::fft(postpad(c, nfft)) polebins <- which(abs(den) < 2 * .Machine$double.eps) if (any(polebins)) { warning("setting group delay to 0 at singularity") num[polebins] <- 0 den[polebins] <- 1 } gd <- Re(num / den) - oa if (!whole) { ns <- nfft / 2 # Matlab convention ... should be nfft/2 + 1 gd <- gd[1:ns] w <- w[1:ns] } else { ns <- nfft # used in plot below } res <- list(gd = gd, w = w, ns = ns, HzFlag = HzFlag) class(res) <- "grpdelay" res } #' @rdname grpdelay #' @export grpdelay.Arma <- function(filt, ...) # IIR grpdelay(filt$b, filt$a, ...) #' @rdname grpdelay #' @export grpdelay.Ma <- function(filt, ...) # FIR grpdelay(as.Arma(filt), ...) #' @rdname grpdelay #' @export grpdelay.Sos <- function(filt, ...) # Second-order sections grpdelay(as.Arma(filt), ...) #' @rdname grpdelay #' @export grpdelay.Zpg <- function(filt, ...) # Zero-pole-gain ARMA grpdelay(as.Arma(filt), ...) gsignal/R/boxcar.R0000644000176200001440000000371414420222025013476 0ustar liggesusers# boxcar.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2000 Paul Kienzle # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191209 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Rectangular window #' #' Return the filter coefficients of a boxcar (rectangular) window. #' #' The rectangular window (sometimes known as the boxcar or Dirichlet window) is #' the simplest window, equivalent to replacing all but \code{n} values of a #' data sequence by zeros, making it appear as though the waveform suddenly #' turns on and off. Other windows are designed to moderate these sudden #' changes, which reduces scalloping loss and improves dynamic range. #' #' @param n Window length, specified as a positive integer. #' #' @return rectangular window, returned as a vector. #' #' @examples #' #' b <- boxcar(64) #' plot (b, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' @seealso \code{\link{triang}} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export boxcar <- function(n) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) { stop("n must be an integer strictly positive") } w <- rep(1L, n) w } gsignal/R/shanwavf.R0000644000176200001440000000560014420222025014031 0ustar liggesusers# shanwavf.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2007 Sylvain Pelissier # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191130 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Complex Shannon Wavelet #' #' Compute the Complex Shannon wavelet. #' #' The complex Shannon wavelet is defined by a bandwidth parameter \code{fb}, a #' wavelet center frequency \code{fc}, and the expression #' \deqn{\psi(x) = (fb^{0.5} * (sinc(fb * x) * e^{2 * 1i * pi * fc * x}))} #' on an \code{n}-point regular grid in the interval of \code{lb} to \code{ub}. #' #' @param lb,ub Lower and upper bounds of the interval to evaluate the waveform #' on. Default: -8 to 8. #' @param n Number of points on the grid between \code{lb} and \code{ub} (length #' of the wavelet). Default: 1000. #' @param fb Time-decay parameter of the wavelet (bandwidth in the frequency #' domain). Must be a positive scalar. Default: 5. #' @param fc Center frequency of the wavelet. Must be a positive scalar. #' Default: 1. #' #' @return A list containing 2 variables; \code{x}, the grid on which the #' complex Shannon wavelet was evaluated, and \code{psi} (\eqn{\Psi}), the #' evaluated wavelet on the grid \code{x}. #' #' @examples #' #' fb <- 1 #' fc <- 1.5 #' lb <- -20 #' ub <- 20 #' n <- 1000 #' sw <- shanwavf(lb, ub, n, fb, fc) #' op <- par(mfrow = c(2,1)) #' plot(sw$x, Re(sw$psi), type="l", main = "Complex Shannon Wavelet", #' xlab = "real part", ylab = "") #' plot(sw$x, Im(sw$psi), type="l", xlab = "imaginary part", ylab = "") #' par(op) #' #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export shanwavf <- function(lb = -8, ub = 8, n = 1000, fb = 5, fc = 1) { if (!isPosscal(n) || !isWhole(n) || n <= 0) stop("n must be an integer strictly positive") if (!isPosscal(fb) || fb <= 0) stop("fb must be a positive scalar > 0") if (!isPosscal(fc) || fc <= 0) stop("fc must be a positive scalar > 0") x <- seq(lb, ub, length.out = n) psi <- (fb^0.5) * (sinc(fb * x) * exp(2 * 1i * pi * fc * x)) list(x = x, psi = psi) } gsignal/R/pulstran.R0000644000176200001440000001557214420222025014075 0ustar liggesusers# pulstran.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2000 Paul Kienzle # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191126 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Pulse train #' #' Generate a train of pulses based on samples of a continuous function. #' #' Generate the signal \code{y <- sum(func(t + d, ...))} for each \code{d}. If #' \code{d} is a matrix of two columns, the first column is the delay \code{d} #' and the second column is the amplitude \code{a}, and \code{y <- sum(a * #' func(t + d))} for each \code{d, a}. Clearly, \code{func} must be a function #' which accepts a vector of times. Any extra arguments needed for the function #' must be tagged on the end. #' #' If instead of a function name you supply a pulse shape sampled at frequency #' \code{fs} (default 1 Hz), an interpolated version of the pulse is added at #' each delay \code{d}. The interpolation stays within the the time range of the #' delayed pulse. The interpolation method defaults to linear, but it can be any #' interpolation method accepted by the function \code{interp1} #' #' @param t Time values at which \code{func} is evaluated, specified as a #' vector. #' @param d Offset removed from the values of the array \code{t}, specified as a #' real vector, matrix, or array. You can apply an optional gain factor to #' each delayed evaluation by specifying \code{d} as a two-column matrix, with #' offset defined in column 1 and associated gain in column 2. If you specify #' \code{d} as a vector, the values are interpreted as delays only. #' @param func Continuous function used to generate a pulse train based on its #' samples, specified as 'rectpuls', 'gauspuls', 'tripuls', or a function #' handle. If you use \code{func} as a function handle, you can pass the #' function parameters as follows:\cr \code{y <- pulstran(t, d, 'gauspuls', #' 10e3, bw = 0.5)}.\cr This creates a pulse train using a 10 kHz Gaussian #' pulse with 50\% bandwidth. Alternatively, \code{func} can be a prototype #' function, specified as a vector. The interval of the function \code{0} to #' \code{(length(p) - 1) / fs}, and its samples are identically zero outside #' this interval. By default, linear interpolation is used for generating #' delays. #' @param fs Sample rate in Hz, specified as a real scalar. #' @param method Interpolation method, specified as one of the following #' options: #' \describe{ #' \item{"linear" (default)}{Linear interpolation. The interpolated value at a #' query point is based on linear interpolation of the values at neighboring #' grid points in each respective dimension. This is the default interpolation #' method.} #' \item{"nearest"}{Nearest neighbor interpolation. The interpolated value at a #' query point is the value at the nearest sample grid point.} #' \item{"cubic"}{Shape-preserving piecewise cubic interpolation. The #' interpolated value at a query point is based on a shape-preserving #' piecewise cubic interpolation of the values at neighboring grid points.} #' \item{"spline"}{Spline interpolation using not-a-knot end conditions. The #' interpolated value at a query point is based on a cubic interpolation of #' the values at neighboring grid points in each respective dimension.} #' } #' Interpolation is performed by the function \code{'interp1'} function in the #' library \code{'pracma'}, and any interpolation method accepted by the #' function \code{'interp1'} can be specified here. #' #' @param ... Further arguments passed to \code{func}. #' #' @return Pulse train generated by the function, returned as a vector. #' #' @examples #' #' ## periodic rectangular pulse #' t <- seq(0, 60, 1/1e3) #' d <- cbind(seq(0, 60, 2), sin(2 * pi * 0.05 * seq(0, 60, 2))) #' y <- pulstran(t, d, 'rectpuls') #' plot(t, y, type = "l", xlab = "Time (s)", ylab = "Waveform", #' main = "Periodic rectangular pulse") #' #' ## assymetric sawtooth waveform #' fs <- 1e3 #' t <- seq(0, 1, 1/fs) #' d <- seq(0, 1, 1/3) #' x <- tripuls(t, 0.2, -1) #' y <- pulstran(t, d, x, fs) #' plot(t, y, type = "l", xlab = "Time (s)", ylab = "Waveform", #' main = "Asymmetric sawtooth waveform") #' #' ## Periodic Gaussian waveform #' fs <- 1e7 #' tc <- 0.00025 #' t <- seq(-tc, tc, 1/fs) #' x <- gauspuls(t, 10e3, 0.5) #' plot(t, x, type="l", xlab = "Time (s)", ylab = "Waveform", #' main = "Gaussian pulse") #' ts <- seq(0, 0.025, 1/50e3) #' d <- cbind(seq(0, 0.025, 1/1e3), sin(2 * pi * 0.1 * (0:25))) #' y <- pulstran(ts, d, x, fs) #' plot(ts, y, type = "l", xlab = "Time (s)", ylab = "Waveform", #' main = "Gaussian pulse train") #' #' # Custom pulse trains #' fnx <- function(x, fn) sin(2 * pi * fn * x) * exp(-fn * abs(x)) #' ffs <- 1000 #' tp <- seq(0, 1, 1/ffs) #' pp <- fnx(tp, 30) #' plot(tp, pp, type = "l",xlab = 'Time (s)', ylab = 'Waveform', #' main = "Custom pulse") #' fs <- 2e3 #' t <- seq(0, 1.2, 1/fs) #' d <- seq(0, 1, 1/3) #' dd <- cbind(d, 4^-d) #' z <- pulstran(t, dd, pp, ffs) #' plot(t, z, type = "l", xlab = "Time (s)", ylab = "Waveform", #' main = "Custom pulse train") #' #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export pulstran <- function(t, d, func, fs = 1, method = c("linear", "nearest", "cubic", "spline"), ...) { if (missing(t) || length(t) <= 0) stop("t must be an array") y <- rep(0L, length(t)) if (missing(d) || length(d) <= 0) return(y) if (is.vector(d) || (is.array(d) && length(dim(d)) == 1)) { a <- rep(1L, length(d)) } else if ((is.matrix(d) || is.array(d)) && ncol(d) == 2) { a <- d[, 2] d <- d[, 1] } else stop("invalid value specified for d") if (is.character(func)) { for (i in seq_along(d)) { y <- y + a[i] * do.call(func, list(t - d[i], ...)) } } else { method <- match.arg(method) span <- (length(func) - 1) / fs t_pulse <- (0:(length(func) - 1)) / fs for (i in seq_along(d)) { dt <- t - d[i] idx <- which(dt >= 0 & dt <= span) if (length(idx) > 0) { y[idx] <- y[idx] + a[i] * pracma::interp1(t_pulse, func, dt[idx], method) } } } y } gsignal/R/gsignal-package.R0000644000176200001440000000020514420222025015225 0ustar liggesusers## usethis namespace: start #' @importFrom Rcpp sourceCpp #' @useDynLib gsignal, .registration = TRUE ## usethis namespace: end NULL gsignal/R/impz.R0000644000176200001440000001275714420222025013206 0ustar liggesusers# impz.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 1999 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200423 GvB setup for gsignal v0.1.0 # 20210420 GvB bugfix, added impz.Zpg #------------------------------------------------------------------------------ #' Impulse response of digital filter #' #' Compute the z-plane impulse response of an ARMA model or rational IIR #' filter. A plot of the impulse and step responses is generated. #' #' @note When results of \code{impz} are printed, \code{plot} will be called to #' display a plot of the impulse response against frequency. As with lattice #' plots, automatic printing does not work inside loops and function calls, so #' explicit calls to print or plot are needed there. #' #' @param filt for the default case, the moving-average coefficients of an ARMA #' model or filter. Generically, \code{filt} specifies an arbitrary model or #' filter operation. #' @param a the autoregressive (recursive) coefficients of an ARMA filter. #' @param n number of points at which to evaluate the frequency response. If #' \code{n} is a vector with a length greater than 1, then evaluate the #' frequency response at these points. For fastest computation, \code{n} #' should factor into a small number of small primes. Default: 512. #' @param fs sampling frequency in Hz. If not specified (default = 2 * pi), the #' frequencies are in radians. #' @param x object to be printed or plotted. #' @param ... for methods of \code{freqz}, arguments are passed to the default #' method. For \code{plot.impz}, additional arguments are passed through to #' plot. #' #' @return For \code{impz}, a list of class \code{"impz"} with items: #' \describe{ #' \item{x}{impulse response signal.} #' \item{t}{time.} #' } #' #' @examples #' ## elliptic low-pass filter #' elp <- ellip(4, 0.5, 20, 0.4) #' impz(elp) #' #' xt <- impz(elp) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Tom Short;\cr #' adapted by Geert van Boxtel, \email{gjmvanboxtel@@gmail.com} #' #' @rdname impz #' @export impz <- function(filt, ...) UseMethod("impz") #' @rdname impz #' @export print.impz <- plot.impz <- function(x, ...) { mini <- min(x$x) maxi <- max(x$x) op <- graphics::par(mfrow = c(2, 1), mar = c(4, 4, 1.5, 1)) on.exit(graphics::par(op)) graphics::plot(x$t, x$x, type = "l", xlab = "", ylab = "Impulse response", ylim = c(min(0, mini), max(1, maxi)), main = "", yaxp = c(0, 1, 1), ...) graphics::abline(h = 0, col = "red") graphics::arrows(0, 0, 0, 1, col = "red", length = 0.1) step <- cumsum(x$x) mini <- min(step) maxi <- max(step) graphics::plot(x$t, cumsum(x$x), type = "l", xlab = "", ylab = "Step response", ylim = c(min(0, mini), max(1, maxi)), main = "", yaxp = c(0, 1, 1), ...) graphics::segments(0, 0, 0, 1, col = "red", lty = 2) graphics::segments(0, 1, x$t[length(x$t)], 1, col = "red", lty = 2) } #' @rdname impz #' @export impz.Arma <- function(filt, ...) impz(filt$b, filt$a, ...) #' @rdname impz #' @export impz.Ma <- function(filt, ...) impz(filt$b, 1, ...) #' @rdname impz #' @export impz.Sos <- function(filt, ...) impz(as.Arma(filt), ...) #' @rdname impz #' @export impz.Zpg <- function(filt, ...) impz(as.Arma(filt), ...) #' @rdname impz #' @export impz.default <- function(filt, a = 1, n = NULL, fs = 1, ...) { b <- filt if (length(n) == 0 && length(a) > 1) { precision <- 1e-6 r <- pracma::roots(a) maxpole <- max(abs(r)) if (maxpole > 1 + precision) { # unstable -- cutoff at 120 dB n <- floor(6 / log10(maxpole)) } else if (maxpole < 1 - precision) { # stable -- cutoff at -120 dB n <- floor(-6 / log10(maxpole)) } else { # periodic -- cutoff after 5 cycles n <- 30 ## find longest period less than infinity ## cutoff after 5 cycles (w=10*pi) rperiodic <- r[abs(r) >= 1 - precision & abs(Arg(r)) > 0] if (!is.null(rperiodic) && length(rperiodic) > 0) { n_periodic <- ceiling(10 * pi / min(abs(Arg(rperiodic)))) if (n_periodic > n) { n <- n_periodic } } ## find most damped pole ## cutoff at -60 dB rdamped <- r[abs(r) < 1 - precision] if (!is.null(rdamped) && length(rdamped) > 0) { n_damped <- floor(-3 / log10(max(abs(rdamped)))) } if (n_damped > n) { n <- n_damped } } n <- n + length(b) } else if (is.null(n)) { n <- length(b) } else if (length(n) > 1) { t <- n n <- length(t) } if (length(a) == 1) { x <- fftfilt(b / a, c(1, numeric(n - 1))) } else { x <- filter(b, a, c(1, numeric(n - 1))) } t <- (0:(length(x) - 1)) / fs res <- list(x = x, t = t) class(res) <- "impz" res } gsignal/R/cl2bp.R0000644000176200001440000001505414420222025013222 0ustar liggesusers# cl2bp.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 1995, Author: Ivan Selesnick, Rice University # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200808 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Constrained L2 bandpass FIR filter design #' #' Constrained least square band-pass FIR filter design without specified #' transition bands. #' #' This is a fast implementation of the algorithm cited below. Compared to #' \code{remez}, it offers implicit specification of transition bands, a higher #' likelihood of convergence, and an error criterion combining features of both #' L2 and Chebyshev approaches #' #' @param m degree of cosine polynomial, resulting in a filter of length #' \code{2 * m + 1}. Must be an even number. Default: 30. #' @param w1,w2 bandpass filter cutoffs in the range \code{0 <= w1 < w2 <= pi}, #' where pi is the Nyquist frequency. #' @param up vector of 3 upper bounds for c(stopband1, passband, stopband2). #' @param lo vector of 3 lower bounds for c(stopband1, passband, stopband2). #' @param L search grid size; larger values may improve accuracy, but greatly #' increase calculation time. Default: 2048, maximum: 1e6. #' #' @return The FIR filter coefficients, a vector of length \code{2 * m + 1}, of #' class \code{Ma}. #' #' @references Selesnick, I.W., Lang, M., and Burrus, C.S. (1998) A modified #' algorithm for constrained least square design of multiband FIR filters #' without specified transition bands. IEEE Trans. on Signal Processing, #' 46(2), 497-501. \cr #' \url{https://www.ece.rice.edu/dsp/software/cl2.shtml} #' #' @examples #' w1 <- 0.3 * pi #' w2 <- 0.6 * pi #' up <- c(0.02, 1.02, 0.02) #' lo <- c(-0.02, 0.98, -0.02) #' h <- cl2bp(30, w1, w2, up, lo, 2^11) #' freqz(h) #' #' @seealso \code{\link{Ma}}, \code{\link{filter}}, \code{\link{remez}} #' #' @author Ivan Selesnick, Rice University, 1995, #' downloaded from \url{https://www.ece.rice.edu/dsp/software/cl2.shtml}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export cl2bp <- function(m = 30, w1, w2, up, lo, L = 2048) { # parameter checking if (!isPosscal(m) || !isWhole(m) || m %% 2 != 0) { stop("polynomial degree m must be a positive even integer") } if (!is.numeric(w1) || w1 < 0 || w1 >= pi || !is.numeric(w2) || w2 <= 0 || w2 > pi || w1 >= w2) { stop("bandpass filter cutoffs must be in the range 0 <= w1 < w2 <= pi") } if (!is.vector(up) || length(up) != 3 || !is.vector(lo) || length(lo) != 3) { stop(paste("the up and lo vectors must contain 3 values", "[stopband1, passband, stopband2]")) } if (!isPosscal(L) || L > 1000000) { stop("L must be a positive scalar <= 1000000") } # ----- calculate Fourier coefficients and upper --- # ----- and lower bound functions ------------------ q1 <- round(L * w1 / pi) q2 <- round(L * (w2 - w1) / pi) q3 <- L + 1 - q1 - q2 u <- c(up[1] * rep(1, q1), up[2] * rep(1, q2), up[3] * rep(1, q3)) l <- c(lo[1] * rep(1, q1), lo[2] * rep(1, q2), lo[3] * rep(1, q3)) w <- (0:L) * pi / L Z <- rep(0L, 2 * L - 1 - 2 * m) r <- sqrt(2) c <- c((w2 - w1) * r, 2 * (sin(w2 * (1:m)) - sin(w1 * (1:m))) / (1:m)) / pi a <- c # best L2 cosine coefficients mu <- NULL # Lagrange multipliers SN <- 1e-9 # Small Number kmax <- NULL; uvo <- 0 kmin <- NULL; lvo <- 0 counter <- 0 while (TRUE) { counter <- counter + 1 if ((uvo > SN / 2) | (lvo > SN / 2)) { # ----- include old extremal ---------------- if (uvo > lvo) { kmax <- c(kmax, okmax[k1]); okmax <- okmax[-k1] } else { kmin <- c(kmin, okmin[k2]); okmin <- okmin[-k2] } } else { # ----- calculate A ------------------------- A <- stats::fft(c(a[1] * r, a[2:(m + 1)], Z, a[seq(m + 1, 2, -1)])) A <- Re(A[1:(L + 1)]) / 2 # ----- find extremals ---------------------- okmax <- kmax; okmin <- kmin kmax <- local_max(A); kmin <- local_max(-A) kmax <- kmax[A[kmax] > u[kmax] - SN / 10] kmin <- kmin[A[kmin] < l[kmin] + SN / 10] # ----- check stopping criterion ------------ Eup <- A[kmax] - u[kmax] Elo <- l[kmin] - A[kmin] E <- max(c(Eup, Elo, 0)) if (E < SN) break } # ----- calculate new multipliers ----------- n1 <- length(kmax); n2 <- length(kmin) O <- rbind(matrix(1L, n1, m + 1), matrix(-1L, n2, m + 1)) G <- O * cos(w[c(kmax, kmin)] %o% (0:m)) G[, 1] <- G[, 1] / r d <- c(u[kmax], -l[kmin]) mu <- pracma::mldivide(G %*% t(G), G %*% c - d, pinv = FALSE) # ----- remove negative multiplier ---------- min_mu <- min(mu); K <- which.min(mu) while (min_mu < 0) { G <- G[-K, ] d <- d[-K] mu <- pracma::mldivide(G %*% t(G), G %*% c - d, pinv = FALSE) if (K > n1) { kmin <- kmin[- (K - n1)]; n2 <- n2 - 1 } else { kmax <- kmax[-K]; n1 <- n1 - 1 } min_mu <- min(mu); K <- which.min(mu) } # ----- determine new coefficients ---------- a <- c - t(G) %*% mu if (length(okmax) > 0) { Aokmax <- a[1] / r + cos(w[okmax] %o% (1:m)) %*% a[2:(m + 1)] uvo <- max(c(Aokmax - u[okmax], 0)) k1 <- which.max(c(Aokmax - u[okmax], 0)) } else { uvo <- 0 } if (length(okmin) > 0) { Aokmin <- a[1] / r + cos(w[okmin] %o% (1:m)) %*% a[2:(m + 1)] lvo <- max(c(l[okmin] - Aokmin, 0)) k2 <- which.max(c(l[okmin] - Aokmin, 0)) } else { lvo <- 0 } } h <- c(a[seq(m + 1, 2, -1)], a[1] * r, a[2:(m + 1)]) / 2 # return filter coefficients as Ma structure Ma(h) } local_max <- function(x) { # finds location of local maxima N <- length(x) b1 <- x[1:(N - 1)] <= x[2:N] b2 <- x[1:(N - 1)] > x[2:N] k <- which(b1[1:(N - 2)] & b2[2:(N - 1)]) + 1 if (x[1] > x[2]) k <- c(k, 1) if (x[N] > x[N - 1]) k <- c(k, N) k <- sort(k) k } gsignal/R/triang.R0000644000176200001440000000366314420222025013507 0ustar liggesusers# triang.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1995-2017 Andreas Weingessel # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191209 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Triangular window #' #' Return the filter coefficients of a triangular window of length \code{n}. #' #' Unlike the Bartlett window, \code{triang} does not go to zero at the edges of #' the window. For odd \code{n}, \code{triang(n)} is equal to \code{bartlett(m + #' 2)} except for the zeros at the edges of the window. #' #' @param n Window length, specified as a positive integer. #' #' @return triangular window, returned as a vector. If you specify a one-point #' window \code{(n = 1)}, the value 1 is returned. #' #' @examples #' #' t <- triang(64) #' plot (t, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' @seealso \code{\link{bartlett}} #' #' @author Andreas Weingessel, \email{Andreas.Weingessel@@ci.tuwien.ac.at}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export triang <- function(n) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) stop("n must be an integer strictly positive") w <- 1 - abs(seq(- (n - 1), (n - 1), by = 2) / (n + n %% 2)) w } gsignal/R/filtfilt.R0000644000176200001440000001611114420222025014030 0ustar liggesusers# filtfilt.R # Copyright (C) 2020 Geert van Boxtel # Octave version: # Copyright (C) 1999 Paul Kienzle # Copyright (C) 2007 Francesco Potortì # Copyright (C) 2008 Luca Citi # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200217 GvB setup for gsignal v0.1 # 20200413 GvB added S3 method method for Sos # 20210402 GvB use padding and Gustafsson method for initial conditions # 20210712 GvB copy attributes of input x to output y # 20220330 GvB corrected bug in nfact (default and Sos) # 20221222 GvB merged pull request from Rafael Laboissière # Negate the signal reversed in time at both ends #------------------------------------------------------------------------------ #' Zero-phase digital filtering #' #' Forward and reverse filter the signal. #' #' Forward and reverse filtering the signal corrects for phase distortion #' introduced by a one-pass filter, though it does square the magnitude response #' in the process. That’s the theory at least. In practice the phase correction #' is not perfect, and magnitude response is distorted, particularly in the stop #' band. #' #' Before filtering the input signal is extended with a reflected part of both #' ends of the signal. The length of this extension is 3 times the filter order. #' The Gustafsson [1] method is then used to specify the initial conditions used #' to further handle the edges of the signal. #' #' @param filt For the default case, the moving-average coefficients of an ARMA #' filter (normally called \code{b}). Generically, \code{filt} specifies an #' arbitrary filter operation. #' @param a the autoregressive (recursive) coefficients of an ARMA filter, #' specified as a vector. If \code{a[1]} is not equal to 1, then filter #' normalizes the filter coefficients by \code{a[1]}. Therefore, \code{a[1]} #' must be nonzero. #' @param x the input signal to be filtered. If \code{x} is a matrix, all #' colums are filtered. #' @param ... additional arguments (ignored). #' #' @return The filtered signal, normally of the same length of the input signal #' \code{x}, returned as a vector or matrix. #' #' @examples #' bf <- butter(3, 0.1) # 10 Hz low-pass filter #' t <- seq(0, 1, len = 100) # 1 second sample #' x <- sin(2* pi * t * 2.3) + 0.25 * rnorm(length(t)) # 2.3 Hz sinusoid+noise #' z <- filter(bf, x) # apply filter #' plot(t, x, type = "l") #' lines(t, z, col = "red") #' zz <- filtfilt(bf, x) #' lines(t, zz, col="blue") #' legend("bottomleft", legend = c("original", "filter", "filtfilt"), lty = 1, #' col = c("black", "red", "blue")) #' #' @seealso \code{\link{filter}}, \code{\link{filter_zi}}, \code{\link{Arma}}, #' \code{\link{Sos}}, \code{\link{Zpg}} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net},\cr Francesco Potortì, #' \email{pot@@gnu.org},\cr Luca Citi, \email{lciti@@essex.ac.uk}.\cr #' Conversion to R and adapted by Geert van Boxtel #' \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references [1] Gustafsson, F. (1996). Determining the initial states in #' forward-backward filtering. IEEE Transactions on Signal Processing, 44(4), #' 988 - 992. #' #' @rdname filtfilt #' @export filtfilt <- function(filt, ...) UseMethod("filtfilt") #' @rdname filtfilt #' @method filtfilt default #' @export filtfilt.default <- function(filt, a, x, ...) { if (!is.vector(filt) || ! is.vector(a) || !is.numeric(filt) || !is.numeric(a)) { stop("b and a must be numeric vectors") } la <- length(a) lb <- length(filt) lab <- max(la, lb) nfact <- max(1, 3 * (lab - 1)) #length of edge transients # Compute initial conditions as per [1] if (lab > 1) { zi <- filter_zi(filt, a) } else { zi <- NULL } #save attributes of x atx <- attributes(x) if (is.vector(x)) { x <- as.matrix(x, ncol = 1) vec <- TRUE } else { vec <- FALSE } nrx <- nrow(x) ncx <- ncol(x) # nfact <- min(nfact - 1, nrx) # corrected bug 20220328 nfact <- min(nfact - 1, nrx - 1) y <- matrix(0, nrx, ncx) for (icol in seq_len(ncx)) { if (nfact > 0) { temp <- c(2 * x[1, icol] - x[seq(nfact + 1, 2, -1), icol], x[, icol], 2 * x[nrx, icol] - x[seq(nrx - 1, nrx - nfact, -1), icol]) temp <- filter(filt, a, temp, zi * temp[1])$y temp <- rev(temp) temp <- rev(filter(filt, a, temp, zi * temp[1])$y) } else { temp <- x[, icol] temp <- filter(filt, a, temp) temp <- rev(temp) temp <- rev(filter(filt, a, temp)) } y[, icol] <- temp[(nfact + 1):(length(temp) - nfact)] } if (vec) { y <- as.vector(y) } # set attributes of y nd return attributes(y) <- atx y } #' @rdname filtfilt #' @method filtfilt Arma #' @export filtfilt.Arma <- function(filt, x, ...) # IIR filtfilt(filt$b, filt$a, x, ...) #' @rdname filtfilt #' @method filtfilt Ma #' @export filtfilt.Ma <- function(filt, x, ...) # FIR filtfilt(unclass(filt), 1, x, ...) #' @rdname filtfilt #' @method filtfilt Sos #' @export filtfilt.Sos <- function(filt, x, ...) { # Second-order sections if (!is.matrix(filt$sos) || !is.numeric(filt$sos)) { stop("sos must be a numeric matrix") } nfact <- max(1, 3 * length(as.Zpg(filt)$p)) # filter order # Compute initial conditions as per [1] if (nfact > 1) { zi <- filter_zi(filt) } else { zi <- NULL } #save attributes of x atx <- attributes(x) if (is.vector(x)) { x <- as.matrix(x, ncol = 1) vec <- TRUE } else { vec <- FALSE } nrx <- nrow(x) ncx <- ncol(x) # nfact <- min(nfact - 1, nrx) # corrected bug 20220328 nfact <- min(nfact - 1, nrx - 1) y <- matrix(0, nrx, ncx) for (icol in seq_len(ncx)) { if (nfact > 0) { temp <- c(2 * x[1, icol] - x[seq(nfact + 1, 2, -1), icol], x[, icol], 2 * x[nrx, icol] - x[seq(nrx - 1, nrx - nfact, -1), icol]) temp <- filter(filt, temp, zi * temp[1])$y temp <- rev(temp) temp <- rev(filter(filt, temp, zi * temp[1])$y) } else { temp <- x[, icol] temp <- filter(filt, temp) temp <- rev(temp) temp <- rev(filter(filt, temp)) } y[, icol] <- temp[(nfact + 1):(length(temp) - nfact)] } if (vec) { y <- as.vector(y) } # set attributes of y and return attributes(y) <- atx y } #' @rdname filtfilt #' @method filtfilt Zpg #' @export filtfilt.Zpg <- function(filt, x, ...) # zero-pole-gain form filtfilt(as.Arma(filt), x) gsignal/R/resample.R0000644000176200001440000001313414420222025014025 0ustar liggesusers# resample.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2008 Eric Chassande-Mottin, CNRS (France) # # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200929 GvB setup for gsignal v0.1.0 # 20220328 GvB copy dimnames of x to output object #------------------------------------------------------------------------------ #' Change sampling rate #' #' Resample using a polyphase algorithm. #' #' If \code{h} is not specified, this function will design an optimal FIR filter #' using a Kaiser-Bessel window. The filter length and the parameter \eqn{\beta} #' are computed based on ref [2], Chapter 7, Eq. 7.63 (p. 476), and Eq. 7.62 (p. #' 474), respectively. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param p,q resampling factors, specified as positive integers. \code{p / q} #' is the resampling factor. #' @param h Impulse response of the FIR filter specified as a numeric vector or #' matrix. If it is a vector, then it represents one FIR filter to may be #' applied to multiple signals in \code{x}; if it is a matrix, then each #' column is a separate FIR impulse response. If not specified, a FIR filter #' based on a Kaiser window is designed. #' #' @return output signal, returned as a vector or matrix. Each column has length #' \code{ceiling(((length(x) - 1) * p + length(h)) / q)}.. #' #' @examples #' lx <- 60 #' tx <- seq(0, 360, length.out = lx) #' x <- sin(2 * pi * tx / 120) #' #' # upsample #' p <- 3; q <- 2 #' ty <- seq(0, 360, length.out = lx * p / q) #' y <- resample(x, p, q) #' #' # downsample #' p <- 2; q <- 3 #' tz <- seq(0, 360, length.out = lx * p / q) #' z <- resample(x, p, q) #' #' # plot #' plot(tx, x, type = "b", col = 1, pch = 1, #' xlab = "", ylab = "") #' points(ty, y, col = 2, pch = 2) #' points(tz, z, col = 3, pch = 3) #' legend("bottomleft", legend = c("original", "upsampled", "downsampled"), #' lty = 1, pch = 1:3, col = 1:3) #' #' @references [1] Proakis, J.G., and Manolakis, D.G. (2007). #' Digital Signal Processing: Principles, Algorithms, and Applications, #' 4th ed., Prentice Hall, Chap. 6.\cr #' [2] Oppenheim, A.V., Schafer, R.W., and Buck, J.R. (1999). #' Discrete-time signal processing, Signal processing series, #' Prentice-Hall. #' #' @seealso \code{\link{kaiser}} #' #' @author Eric Chassande-Mottin, \email{ecm@@apc.univ-paris7.fr}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export resample <- function(x, p, q, h) { if (!is.numeric(x)) { stop("x must be numeric") } if (is.vector(x)) { ns <- 1 lx <- length(x) x <- matrix(x, ncol = 1) vec <- TRUE } else if (is.matrix(x)) { ns <- ncol(x) lx <- nrow(x) vec <- FALSE } else { stop("x must be a numeric vector or matrix") } if (!(isPosscal(p) && isWhole(p)) || !(isPosscal(q) && isWhole(q))) { stop("p and q must be positive integers") } # simplify decimation and interpolation factors great_common_divisor <- pracma::gcd(p, q) if (great_common_divisor > 1) { p <- as.double(p) / as.double(great_common_divisor) q <- as.double(q) / as.double(great_common_divisor) } else { p <- as.double(p) q <- as.double(q) } # filter design if required if (missing(h)) { # properties of the antialiasing filter log10_rejection <- -3.0 stopband_cutoff_f <- 1 / (2 * max(p, q)) roll_off_width <- stopband_cutoff_f / 10.0 # determine filter length # use empirical formula from ref [2], Chap 7, Eq. (7.63) p 476 rejection_dB <- -20.0 * log10_rejection L <- ceiling((rejection_dB - 8.0) / (28.714 * roll_off_width)) ## ideal sinc filter t <- -L:L ideal_filter <- 2 * p * stopband_cutoff_f * sinc(2 * stopband_cutoff_f * t) # determine parameter of Kaiser window # use empirical formula from [2] Chap 7, Eq. (7.62) p 474 if ((rejection_dB >= 21) && (rejection_dB <= 50)) { beta <- 0.5842 * (rejection_dB - 21.0)^0.4 + 0.07886 * (rejection_dB - 21.0) } else if (rejection_dB > 50) { beta <- 0.1102 * (rejection_dB - 8.7) } else { beta <- 0.0 } # apodize ideal filter response h <- kaiser(2 * L + 1, beta) * ideal_filter } if (is.vector(h)) { lh <- length(h) h <- matrix(rep(h, ns), ncol = ns, byrow = FALSE) } else if (!is.matrix(h)) { stop("h must be a numeric matrix") } lh <- nrow(h) L <- (lh - 1) / 2.0 ly <- ceiling(lx * p / q) # pre and postpad filter response nz_pre <- floor(q - L %% q) hpad <- prepad(h, lh + nz_pre) offset <- floor((L + nz_pre) / q) nz_post <- 0 while (ceiling(((lx - 1) * p + nz_pre + lh + nz_post) / q) - offset < ly) { nz_post <- nz_post + 1 } hpad <- postpad(hpad, lh + nz_pre + nz_post) ##filtering xfilt <- upfirdn(x, hpad, p, q) y <- xfilt[(offset + 1):(offset + ly), ] if (vec) { y <- as.vector(y) } dimnames(y) <- dimnames(x) y } gsignal/R/polyreduce.R0000644000176200001440000000322414420222025014367 0ustar liggesusers# polyreduce.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 1994-2017 John W. Eaton # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200606 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Reduce polynomial #' #' Reduce a polynomial coefficient vector to a minimum number of terms by #' stripping off any leading zeros. #' #' @param pc vector of polynomial coefficients #' #' @return Vector of reduced polynomial coefficients. #' #' @examples #' p <- polyreduce(c(0, 0, 1, 2, 3)) #' #' @author Tony Richardson, \email{arichard@@stark.cc.oh.us},\cr #' adapted by John W. Eaton.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com} # #' @export polyreduce <- function(pc) { lpc <- length(pc) if (is.null(pc) || !is.vector(pc) || lpc == 0) { stop("'pc must be a non-empty vector") } idx <- which(pc != 0)[1] if (is.na(idx) || length(idx) == 0) { p <- 0 } else { p <- pc[idx:lpc] } p } gsignal/R/kaiserord.R0000644000176200001440000001542614420222025014206 0ustar liggesusers# kaiserord.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2000 Paul Kienzle # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200708 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Kaiser filter order and cutoff frequency #' #' Return the parameters needed to produce a FIR filter of the desired #' specification from a Kaiser window. #' #' Given a set of specifications in the frequency domain, \code{kaiserord} #' estimates the minimum FIR filter order that will approximately meet the #' specifications. \code{kaiserord} converts the given filter specifications #' into passband and stopband ripples and converts cutoff frequencies into the #' form needed for windowed FIR filter design. #' #' \code{kaiserord} uses empirically derived formulas for estimating the orders #' of lowpass filters, as well as differentiators and Hilbert transformers. #' Estimates for multiband filters (such as band-pass filters) are derived from #' the low-pass design formulas. #' #' The design formulas that underlie the Kaiser window and its application to #' FIR filter design are #' \deqn{\beta =} #' \deqn{0.1102(\alpha - 8.7), \alpha > 50} #' \deqn{0.5842(\alpha -21)^{0.4} + 0.07886(\alpha - 21), 21 \le \alpha \le 50} #' \deqn{0, \alpha < 21} #' #' where \eqn{\alpha = -20log_{10}(\delta)} is the stopband attenuation #' expressed in decibels, \eqn{n=(\alpha - 8) / 2.285(\Delta\omega)}, where #' \eqn{n} is the filter order and \eqn{\Delta\omega} is the width of the #' smallest transition region. #' #' @param f frequency bands, given as pairs, with the first half of the first #' pair assumed to start at 0 and the last half of the last pair assumed to #' end at 1. It is important to separate the band edges, since narrow #' transition regions require large order filters. #' @param m magnitude within each band. Should be non-zero for pass band and #' zero for stop band. All passbands must have the same magnitude, or you will #' get the error that pass and stop bands must be strictly alternating. #' @param dev deviation within each band. Since all bands in the resulting #' filter have the same deviation, only the minimum deviation is used. In this #' version, a single scalar will work just as well. #' @param fs sampling rate. Used to convert the frequency specification into the #' c(0, 1) range, where 1 corresponds to the Nyquist frequency, \code{fs / 2}. #' #' @return A list of class \code{\link{FilterSpecs}} with the following list #' elements: #' \describe{ #' \item{n}{filter order} #' \item{Wc}{cutoff frequency} #' \item{type}{filter type, one of "low", "high", "stop", "pass", "DC-0", or #' "DC-1".} #' \item{beta}{shape parameter} #' } #' #' @examples #' fs <- 11025 #' op <- par(mfrow = c(2, 2), mar = c(3, 3, 1, 1)) #' for (i in 1:4) { #' if (i == 1) { #' bands <- c(1200, 1500) #' mag <- c(1, 0) #' dev <- c(0.1, 0.1) #' } #' if (i == 2) { #' bands <- c(1000, 1500) #' mag <- c(0, 1) #' dev <- c(0.1, 0.1) #' } #' if (i == 3) { #' bands <- c(1000, 1200, 3000, 3500) #' mag <- c(0, 1, 0) #' dev <- 0.1 #' } #' if (i == 4) { #' bands <- 100 * c(10, 13, 15, 20, 30, 33, 35, 40) #' mag <- c(1, 0, 1, 0, 1) #' dev <- 0.05 #' } #' kaisprm <- kaiserord(bands, mag, dev, fs) #' d <- max(1, trunc(kaisprm$n / 10)) #' if (mag[length(mag)] == 1 && (d %% 2) == 1) { #' d <- d + 1 #' } #' f1 <- freqz(fir1(kaisprm$n, kaisprm$Wc, kaisprm$type, #' kaiser(kaisprm$n + 1, kaisprm$beta), #' scale = FALSE), #' fs = fs) #' f2 <- freqz(fir1(kaisprm$n - d, kaisprm$Wc, kaisprm$type, #' kaiser(kaisprm$n - d + 1, kaisprm$beta), #' scale = FALSE), #' fs = fs) #' plot(f1$w, abs(f1$h), col = "blue", type = "l", xlab = "", ylab = "") #' lines(f2$w, abs(f2$h), col = "red") #' legend("right", paste("order", c(kaisprm$n-d, kaisprm$n)), #' col = c("red", "blue"), lty = 1, bty = "n") #' b <- c(0, bands, fs/2) #' for (i in seq(2, length(b), by=2)) { #' hi <- mag[i/2] + dev[1] #' lo <- max(mag[i/2] - dev[1], 0) #' lines(c(b[i-1], b[i], b[i], b[i-1], b[i-1]), c(hi, hi, lo, lo, hi)) #' } #' } #' par(op) #' #' @author Paul Kienzle.\cr #' Conversion to R by Tom Short,\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{hamming}}, \code{\link{kaiser}} #' #' @export kaiserord <- function(f, m, dev, fs = 2) { ## parameter checking if (length(f) != 2 * length(m) - 2) { stop("One magnitude for each frequency band is required") } if (length(m) > 2 && any(m[1:(length(m) - 2)] != m[3:length(m)])) { stop("Ppass and stop bands must be strictly alternating") } if (length(dev) != length(m) && length(dev) != 1) { stop("One deviation for each frequency band is required") } dev <- min(dev) if (dev <= 0) { stop("dev must be 0") } if (!isPosscal(fs) || fs == 0) { stop("Sampling frequency fs must be a positive scalar") } ## use midpoints of the transition region for band edges w <- (f[seq(1, length(f), by = 2)] + f[seq(2, length(f), by = 2)]) / fs ## determine ftype if (length(w) == 1) { if (m[1] > m[2]) { ftype <- "low" } else { ftype <- "high" } } else if (length(w) == 2) { if (m[1] > m[2]) { ftype <- "stop" } else { ftype <- "pass" } } else { if (m[1] > m[2]) { ftype <- "DC-1" } else { ftype <- "DC-0" } } ## compute beta from dev A <- -20 * log10(dev) if (A > 50) { beta <- 0.1102 * (A - 8.7) } else if (A >= 21) { beta <- 0.5842 * (A - 21)^0.4 + 0.07886 * (A - 21) } else { beta <- 0.0 } ## compute n from beta and dev dw <- 2 * pi * min(f[seq(2, length(f), by = 2)] - f[seq(1, length(f), by = 2)]) / fs n <- max(1, ceiling((A - 8) / (2.285 * dw))) ## if last band is high, make sure the order of the filter is even. if ((m[1] > m[2]) == (length(w) %% 2 == 0) && n %% 2 == 1) { n <- n + 1 } FilterSpecs(n = n, Wc = w, type = ftype, beta = beta) } gsignal/R/cheb2ap.R0000644000176200001440000000365614420222025013531 0ustar liggesusers# buttap.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2013 Carne Draug # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200519 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Chebyshev Type II filter prototype #' #' Return the poles and gain of an analog Chebyshev Type II lowpass filter #' prototype. #' #' This function exists for compatibility with 'Matlab' and 'Octave' only, and #' is equivalent to \code{cheby2(n, Rp, 1, "low", "s")}. #' #' @param n Order of the filter. #' @param Rs dB of stop-band ripple. #' #' @return list of class \code{\link{Zpg}} containing poles and gain of the #' filter #' #' @examples #' ## 9th order Chebyshev type II low-pass analog filter #' zp <- cheb2ap(9, 30) #' w <- seq(0, 4, length.out = 128) #' freqs(zp, w) #' #' @author Carne Draug, \email{carandraug+dev@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export cheb2ap <- function(n, Rs) { if (!isPosscal(n) || ! isWhole(n)) stop("n must be an integer strictly positive") if (!isPosscal(Rs) || !is.numeric(Rs)) { stop("passband ripple Rp must a non-negative scalar") } cheby2(n, Rs, 1, "low", "s", "Zpg") } gsignal/R/Ma.R0000644000176200001440000000246114420222025012553 0ustar liggesusers# Ma.R # Copyright (C) 2006 EPRI Solutions, Inc. # by Tom Short, tshort@eprisolutions.com # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200127 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Moving average (MA) model #' #' Create an MA model representing a filter or system model #' #' @param b moving average (MA) polynomial coefficients. #' #' @return A list of class \code{Ma} with the polynomial coefficients #' #' @seealso See also \code{\link{Arma}} #' #' @examples #' f <- Ma(b = c(1, 2, 1) / 3) #' freqz(f) #' zplane(f) #' #' @author Tom Short, \email{tshort@@eprisolutions.com} #' @export Ma <- function(b) { class(b) <- "Ma" b } gsignal/R/clustersegment.R0000644000176200001440000000727014420222025015265 0ustar liggesusers# clustersegment.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2010 Juan Pablo Carbajal # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201122 GvB setup for gsignal v0.1.0 # 20201127 GvB also accept numeric values other than 0 and 1 #------------------------------------------------------------------------------ #' Cluster Segments #' #' Calculate boundary indexes of clusters of 1’s. #' #' The function calculates the initial index and end index of sequences of 1s #' rising and falling phases of the signal in \code{x}. The clusters are sought #' in the rows of the array \code{x}. The function works by finding the indexes #' of jumps between consecutive values in the rows of \code{x}. #' #' @param x input data, specified as a numeric vector or matrix, coerced to #' contain only 0's and 1's, i.e., every nonzero element in \code{x} will #' be replaced by 1. #' #' @return A list of size \code{nr}, where \code{nr} is the number #' of rows in \code{x}. Each element of the list contains a matrix with two #' rows. The first row is the initial index of a sequence of 1’s and the #' second row is the end index of that sequence. #' #' @examples #' (x <- c(0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, 1, 1)) #' (ranges <- clustersegment(x)) #' # The first sequence of 1's in x lies in the interval #' (r <- ranges[1,1]:ranges[2,1]) #' #' x <- matrix(as.numeric(runif(30) > 0.4), 3, 10) #' ranges <- clustersegment(x) #' #' x <- c(0, 1.2, 3, -8, 0) #' ranges <- clustersegment(x) #' #' @author Juan Pablo Carbajal, \email{carbajal@@ifi.uzh.ch}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export clustersegment <- function(x) { if (!(is.numeric(x) || is.logical(x) || is.complex(x))) { stop("x must be numeric, logical or complex") } if (is.vector(x)) { x <- matrix(x, nrow = 1) } else if (!is.matrix(x)) { stop("x must be a vector or matrix") } nc <- ncol(x) nr <- nrow(x) # coerce to 0's and 1's x <- apply(x, c(1, 2), function(x) as.integer(as.logical(x))) y <- list() for (i in seq_len(nr)) { bool_discon <- diff(x[i, ]) idxUp <- which(bool_discon > 0) + 1L idxDwn <- which(bool_discon < 0) tLen <- length(idxUp) + length(idxDwn) if (tLen <= 0) { y[[i]] <- matrix(NA, 1, 1) } else { contRange <- rep(0, tLen) if (x[i, 1] == 1) { ## first event was down contRange <- c(contRange, 0) contRange[1] <- 1 if (tLen >= 1) contRange[seq(2, tLen + 1, 2)] <- idxDwn if (tLen >= 2) contRange[seq(3, tLen + 1, 2)] <- idxUp } else { ## first event was up contRange[seq(1, tLen, 2)] <- idxUp if (tLen >= 2) contRange[seq(2, tLen, 2)] <- idxDwn } if (x[i, nc] == 1) { ## last event was up contRange <- c(contRange, nc) } tLen <- length(contRange) if (tLen != 0) { dim(contRange) <- c(2, tLen / 2) y[[i]] <- contRange } } } if (nr == 1 && length(y) > 0) { y <- as.matrix(y[[1]]) } y } gsignal/R/nuttallwin.R0000644000176200001440000000567714420222025014433 0ustar liggesusers# nuttallwin.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2007 Sylvain Pelissier # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191215 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Nuttall-defined minimum 4-term Blackman-Harris window #' #' Return the filter coefficients of a Blackman-Harris window defined by Nuttall #' of length \code{n}. #' #' The window is minimum in the sense that its maximum sidelobes are minimized. #' The coefficients for this window differ from the Blackman-Harris window #' coefficients computed with \code{blackmanharris} and produce slightly lower #' sidelobes. #' #' @param n Window length, specified as a positive integer. #' @param method Character string. Window sampling method, specified as: #' \describe{ #' \item{"symmetric"}{(Default). Use this option when using windows for filter #' design.} #' \item{"periodic"}{This option is useful for spectral analysis because it #' enables a windowed signal to have the perfect periodic extension implicit #' in the discrete Fourier transform. When \code{periodic} is specified, the #' function computes a window of length \code{n + 1} and returns the first #' \code{n} points.} #' } #' #' @return Nuttall-defined Blackman-Harris window, returned as a vector. #' #' @examples #' #' n <- nuttallwin(64) #' plot (n, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' @seealso \code{\link{blackman}}, \code{\link{blackmanharris}} #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export nuttallwin <- function(n, method = c("symmetric", "periodic")) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) stop("n must be an integer strictly positive") method <- match.arg(method) if (method == "periodic") { N <- n } else if (method == "symmetric") { N <- n - 1 } else { stop("method must be either 'periodic' or 'symmetric'") } if (n == 1) { w <- 1 } else { a0 <- 0.355768 a1 <- 0.487396 a2 <- 0.144232 a3 <- 0.012604 k <- (-N / 2):((n - 1) / 2) w <- a0 + a1 * cos(2 * pi * k / N) + a2 * cos(4 * pi * k / N) + a3 * cos(6 * pi * k / N) } w } gsignal/R/butter.R0000644000176200001440000001446214420222025013527 0ustar liggesusers# butter.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1999 Paul Kienzle # Copyright (C) 2003 Doug Stewart # Copyright (C) 2011 Alexander Klein # Copyright (C) 2018 John W. Eaton # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200513 Geert van Boxtel First version for v0.1.0 # 20200519 Geert van Boxtel Added plane parameter to butter.IIRfspec # 20200708 GvB renamed IIRfspec to FilterSpecs # 20210308 GvB bug in passing w to sftrans; # added output parameter #------------------------------------------------------------------------------ #' Butterworth filter design #' #' Compute the transfer function coefficients of a Butterworth filter. #' #' Butterworth filters have a magnitude response that is maximally flat in the #' passband and monotonic overall. This smoothness comes at the price of #' decreased rolloff steepness. Elliptic and Chebyshev filters generally provide #' steeper rolloff for a given filter order. #' #' Because butter is generic, it can be extended to accept other inputs, using #' \code{buttord} to generate filter criteria for example. #' #' @param n filter order. #' @param w critical frequencies of the filter. \code{w} must be a scalar for #' low-pass and high-pass filters, and \code{w} must be a two-element vector #' c(low, high) specifying the lower and upper bands in radians/second. For #' digital filters, w must be between 0 and 1 where 1 is the Nyquist #' frequency. #' @param type filter type, one of \code{"low"}, (default) \code{"high"}, #' \code{"stop"}, or \code{"pass"}. #' @param plane "z" for a digital filter or "s" for an analog filter. #' @param output Type of output, one of: #' \describe{ #' \item{"Arma"}{Autoregressive-Moving average (aka numerator/denominator, aka #' b/a)} #' \item{"Zpg"}{Zero-pole-gain format} #' \item{"Sos"}{Second-order sections} #' } #' Default is \code{"Arma"} for compatibility with the 'signal' package and the #' 'Matlab' and 'Octave' equivalents, but \code{"Sos"} should be preferred for #' general-purpose filtering because of numeric stability. #' @param ... additional arguments passed to butter, overriding those given by #' \code{n} of class \code{\link{FilterSpecs}}. #' #' @return Depending on the value of the \code{output} parameter, a list of #' class \code{\link{Arma}}, \code{\link{Zpg}}, or \code{\link{Sos}} #' containing the filter coefficients #' #' @examples #' ## 50 Hz notch filter #' fs <- 256 #' bf <- butter(4, c(48, 52) / (fs / 2), "stop") #' freqz(bf, fs = fs) #' #' ## EEG alpha rhythm (8 - 12 Hz) bandpass filter #' fs <- 128 #' fpass <- c(8, 12) #' wpass <- fpass / (fs / 2) #' but <- butter(5, wpass, "pass") #' freqz(but, fs = fs) #' #' ## filter to remove vocals from songs, 25 dB attenuation in stop band #' ## (not optimal with a Butterworth filter) #' fs <- 44100 #' specs <- buttord(230/(fs/2), 450/(fs/2), 1, 25) #' bf <- butter(specs) #' freqz(bf, fs = fs) #' zplane(bf) #' #' @references \url{https://en.wikipedia.org/wiki/Butterworth_filter} #' #' @seealso \code{\link{Arma}}, \code{\link{Zpg}}, \code{\link{Sos}}, #' \code{\link{filter}}, \code{\link{cheby1}}, \code{\link{ellip}}, #' \code{\link{buttord}}. #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Doug Stewart, \email{dastew@@sympatico.ca},\cr #' Alexander Klein, \email{alexander.klein@@math.uni-giessen.de},\cr #' John W. Eaton.\cr #' Conversion to R by Tom Short,\cr #' adapted by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @rdname butter #' @export butter <- function(n, ...) UseMethod("butter") #' @rdname butter #' @export butter.FilterSpecs <- function(n, ...) butter(n$n, n$Wc, n$type, n$plane, ...) #' @rdname butter #' @export butter.default <- function(n, w, type = c("low", "high", "stop", "pass"), plane = c("z", "s"), output = c("Arma", "Zpg", "Sos"), ...) { # check input arguments type <- match.arg(type) plane <- match.arg(plane) output <- match.arg(output) if (!isPosscal(n) || !isWhole(n)) { stop("filter order n must be a positive integer") } stop <- type == "stop" || type == "high" digital <- plane == "z" if (!is.vector(w) || (length(w) != 1 && length(w) != 2)) { stop(paste("frequency w must be specified as a vector of length 1 or 2", "(either w0 or c(w0, w1))")) } if ((type == "stop" || type == "pass") && length(w) != 2) { stop("w must be two elements for stop and bandpass filters") } if (digital && !all(w >= 0 & w <= 1)) { stop("critical frequencies w must be in the range [0 1]") } else if (!digital && !all(w >= 0)) { stop("critical frequencies w must be in the range [0 Inf]") } ## Prewarp to the band edges to s plane if (digital) { T <- 2 # sampling frequency of 2 Hz w <- 2 / T * tan(pi * w / T) } ## Generate splane poles for the prototype Butterworth filter ## source: Kuc C <- 1 # default cutoff frequency pole <- C * exp(1i * pi * (2 * 1:n + n - 1) / (2 * n)) if (n %% 2 == 1) { pole[(n + 1) / 2] <- -1 # pure real value at exp(i*pi) } zero <- numeric(0) gain <- C^n zpg <- Zpg(z = zero, p = pole, g = gain) ## splane frequency transform zpg <- sftrans(zpg, w = w, stop = stop) ## Use bilinear transform to convert poles to the z plane if (digital) { zpg <- bilinear(zpg, T = T) } if (output == "Arma") { retval <- as.Arma(zpg) } else if (output == "Sos") { retval <- as.Sos(zpg) } else { retval <- zpg } retval } gsignal/R/remez.R0000644000176200001440000001111714420222025013336 0ustar liggesusers# remez.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 1995, 1998 Jake Janovetz # Copyright (C) 1999 Paul Kienzle # Copyright (C) 2000 Kai Habel # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200803 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Parks-McClellan optimal FIR filter design #' #' Parks-McClellan optimal FIR filter design using the Remez exchange algorithm. #' #' @param n filter order (1 less than the length of the filter). #' @param f normalized frequency points, strictly increasing vector in the range #' [0, 1], where 1 is the Nyquist frequency. The number of elements in the #' vector is always a multiple of 2. #' @param a vector of desired amplitudes at the points specified in \code{f}. #' \code{f} and \code{a} must be the same length. The length must be an even #' number. #' @param w vector of weights used to adjust the fit in each frequency band. The #' length of \code{w} is half the length of \code{f} and \code{a}, so there is #' exactly one weight per band. Default: 1. #' @param ftype filter type, matched to one of \code{"bandpass"} (default), #' \code{"differentiatior"}, or \code{"hilbert"}. #' @param density determines how accurately the filter will be constructed. The #' minimum value is 16 (default), but higher numbers are slower to compute. #' #' @return The FIR filter coefficients, a vector of length \code{n + 1}, of #' class \code{Ma} #' #' @references \url{https://en.wikipedia.org/wiki/Fir_filter} #' #' @examples #' ## low pass filter #' f1 <- remez(15, c(0, 0.3, 0.4, 1), c(1, 1, 0, 0)) #' freqz(f1) #' #' ## band pass #' f <- c(0, 0.3, 0.4, 0.6, 0.7, 1) #' a <- c(0, 0, 1, 1, 0, 0) #' b <- remez(17, f, a) #' hw <- freqz(b, 512) #' plot(f, a, type = "l", xlab = "Radian Frequency (w / pi)", #' ylab = "Magnitude") #' lines(hw$w/pi, abs(hw$h), col = "red") #' legend("topright", legend = c("Ideal", "Remez"), lty = 1, #' col = c("black", "red")) #' #' @seealso \code{\link{Ma}}, \code{\link{filter}}, \code{\link{fftfilt}}, #' \code{\link{fir1}} #' #' @author Jake Janovetz, \email{janovetz@@uiuc.edu},\cr #' Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Kai Habel, \email{kahacjde@@linux.zrz.tu-berlin.de}.\cr #' Conversion to R Tom Short\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references Rabiner, L.R., McClellan, J.H., and Parks, T.W. (1975). FIR #' Digital Filter Design Techniques Using Weighted Chebyshev Approximations, #' IEEE Proceedings, vol. 63, pp. 595 - 610.\cr #' \url{https://en.wikipedia.org/wiki/Parks-McClellan_filter_design_algorithm} #' #' @export remez <- function(n, f, a, w = rep(1.0, length(f) / 2), ftype = c("bandpass", "differentiator", "hilbert"), density = 16) { ftype <- as.integer(factor(match.arg(ftype), c("bandpass", "differentiator", "hilbert"))) if (!isPosscal(n) || !isWhole(n) || n < 4) { stop("Filter length n must be an integer greater than 3") } if (!is.vector(f) || length(f) %% 2 == 1) { stop("f must be a vector of even length") } if (any(diff(f) < 0)) { stop("f must be a vector of increasing numbers") } if (any(f < 0) || any(f > 1)) { stop("f must be in the range [0,1]") } if (length(a) != length(f)) { stop("length(a) must equal length(f)") } if (2 * length(w) != length(f)) { stop("length(w) must be half of length(f)") } if (density < 16) { stop("density is too low, must be greater than or equal to 16") } z <- .Call("_gsignal_remez", h = as.double(rep(0, n + 1)), as.integer(n + 1), as.integer(length(f) / 2), as.double(f / 2), as.double(a), as.double(w), as.integer(ftype), as.integer(density), PACKAGE = "gsignal") Ma(z) } gsignal/R/sinewave.R0000644000176200001440000000324714420222025014042 0ustar liggesusers# sinewave.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 1995-2019 Friedrich Leisch # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20201201 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Sine wave #' #' Generate a discrete sine wave. #' #' @param m desired length of the generated series, specified as a positive #' integer. #' @param n rate, of the generated series, specified as a positive integer. #' Default: \code{m}. #' @param d delay, specified as a positive integer. Default: 0. #' #' @return Sine wave, returned as a vector of length \code{m}. #' #' @examples #' plot(sinewave(100, 10), type = "l") #' #' @author Friedrich Leisch.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export sinewave <- function(m, n = m, d = 0) { if (!isPosscal(m) || !isPosscal(n) || !isPosscal(d)) { stop("m, n, and d must be positive scalars") } y <- sin((seq(1, m) + d - 1) * 2 * pi / n) y } gsignal/R/sampled2continuous.R0000644000176200001440000000557014420222025016060 0ustar liggesusers# sampled2continuous.R # Copyright (C) 2020 Geert van Bxtel # Original Octave code: # Copyright (C) 2009 Muthiah Annamalai # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201124 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Signal reconstruction #' #' Analog signal reconstruction from discrete samples. #' #' Given a discrete signal x[n] sampled with a frequency of \code{fs} Hz, this #' function reconstruct the original analog signal x(t) at time points \code{t}. #' The function can be used, for instance, to calculate sampling rate effects on #' aliasing. #' #' @param xn the sampled input signal, specified as a vector #' @param fs sampling frequency in Hz used in collecting \code{x}, specified as #' a positive scalar value. Default: 1 #' @param t time points at which data is to be reconstructed, specified as a #' vector relative to \code{x[0]} (not real time). #' #' @return Reconstructed signal x(t), returned as a vector. #' #' @examples #' # 'analog' signal: 3 Hz cosine #' t <- seq(0, 1, length.out = 100) #' xt <- cos(3 * 2 * pi * t) #' plot(t, xt, type = "l", xlab = "", ylab = "", ylim = c(-1, 1.2)) #' #' # 'sample' it at 4 Hz to simulate aliasing #' fs <- 4 #' n <- ceiling(length(t) / fs) #' xn <- xt[seq(ceiling(n / 2), length(t), n)] #' s4 <- sampled2continuous(xn, fs, t) #' lines(t, s4, col = "red") #' #' # 'sample' it > 6 Hz to avoid aliasing #' fs <- 7 #' n <- ceiling(length(t) / fs) #' xn <- xt[seq(ceiling(n / 2), length(t), n)] #' s7 <- sampled2continuous(xn, fs, t) #' lines(t, s7, col = "green") #' legend("topright", legend = c("original", "aliased", "non-aliased"), #' lty = 1, col = c("black", "red", "green")) #' #' #' @author Muthiah Annamalai, \email{muthiah.annamalai@@uta.edu}. #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export sampled2continuous <- function(xn, fs, t) { if (!is.vector(xn)) { stop("xn must be a vector") } if (!isPosscal(fs) || fs <= 0) { stop("fs must be a positive scalar") } if (!is.vector(t)) { stop("t must be a vector") } T <- 1 / fs N <- length(xn) mg <- pracma::meshgrid(T * seq(0, N - 1), t) S <- sinc((mg$Y - mg$X) / T) xt <- S %*% xn xt } gsignal/R/fht.R0000644000176200001440000001003714420222025012775 0ustar liggesusers# fht.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2008 Muthiah Annamalai # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201020 GvB setup for gsignal v0.1.0 # 20201023 GvB corrected padding # 20210506 GvB use matrix() instead of as.matrix() # 20220328 GvB copy dimnames of x to output object #------------------------------------------------------------------------------ #' Fast Hartley Transform #' #' Compute the (inverse) Hartley transform of a signal using FFT #' #' The Hartley transform is an integral transform closely related to the Fourier #' transform, but which transforms real-valued functions to real-valued #' functions. Compared to the Fourier transform, the Hartley transform has #' the advantages of transforming real functions to real functions (as opposed #' to requiring complex numbers) and of being its own inverse [1]. #' #' This function implements the Hartley transform by calculating the difference #' between the real- and imaginary-valued parts of the Fourier-transformed #' signal [1]. The forward and inverse Hartley transforms are the same (except #' for a scale factor of 1/N for the inverse Hartley transform), but implemented #' using different functions. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param n transform length, specified as a positive integer scalar. Default: #' \code{NROW(x)}. #' #' @return (inverse) Hartley transform, returned as a vector or matrix. #' #' @examples #' # FHT of a 2.5 Hz signal with offset #' fs <- 100 #' secs <- 10 #' freq <- 2.5 #' t <- seq(0, secs - 1 / fs, 1 / fs) #' x <- 5 * t + 50 * cos(freq * 2 * pi * t) #' X <- fht(x) #' op <- par(mfrow = c(2, 1)) #' plot(t, x, type = "l", xlab = "", ylab = "", main = "Signal") #' f <- seq(0, fs - (1 / fs), length.out = length(t)) #' to <- which(f >= 5)[1] #' plot(f[1:to], X[1:to], type = "l", xlab = "", ylab = "", #' main = "Hartley Transform") #' par(op) #' #' @author Muthiah Annamalai, \email{muthiah.annamalai@@uta.edu}.\ #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references [1] \url{https://en.wikipedia.org/wiki/Hartley_transform} #' #' @seealso \code{\link{fft}} #' #' @rdname fht #' @export fht <- function(x, n = NROW(x)) { # check parameters if (!(is.vector(x) || is.matrix(x)) || !is.numeric(x)) { stop("x must be a numeric or vector or matrix") } if (is.vector(x)) { vec <- TRUE x <- matrix(x, ncol = 1) } else { vec <- FALSE } nr <- nrow(x) if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer") } if (n != nr) { x <- postpad(x, n) } Y <- stats::mvfft(x) y <- Re(Y) - Im(Y) if (vec) { y <- as.vector(y) } dimnames(y) <- dimnames(x) y } #' @rdname fht #' @export ifht <- function(x, n = NROW(x)) { # check parameters if (!(is.vector(x) || is.matrix(x)) || !is.numeric(x)) { stop("x must be a numeric or vector or matrix") } if (is.vector(x)) { vec <- TRUE x <- matrix(x, ncol = 1) } else { vec <- FALSE } nr <- nrow(x) if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer") } if (n != nr) { x <- postpad(x, n) } Y <- imvfft(x) y <- Re(Y) + Im(Y) if (vec) { y <- as.vector(y) } dimnames(y) <- dimnames(x) y } gsignal/R/besselap.R0000644000176200001440000000623014661617015014030 0ustar liggesusers# besselap.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2009 Thomas Sailer # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200426 Geert van Boxtel First version for v0.1.0 # 20205001 Geert van Boxtel return Zpg$z = complex(0) instead of NULL #------------------------------------------------------------------------------ #' Bessel analog low-pass filter prototype #' #' Return the poles and gain of a Bessel analog low-pass filter prototype. #' #' The transfer function is #' \if{latex}{ #' \deqn{H(s) = \frac{k}{(s-p(1))(s-p(2))...(s-p(n))}} #' } #' \if{html}{\preformatted{ #' k #' H(s) = ----------------------------- #' (s-p(1))(s-p(2))...(s-p(n)) #' #' }} #' \code{besselap} normalizes the poles and gain so that at low frequency and #' high frequency the Bessel prototype is asymptotically equivalent to the #' Butterworth prototype of the same order. The magnitude of the filter is less #' than \eqn{1/\sqrt{2}} at the unity cutoff frequency \eqn{\Omega_c = 1}. #' #' Analog Bessel filters are characterized by a group delay that is maximally #' flat at zero frequency and almost constant throughout the passband. The group #' delay at zero frequency is #' \if{latex}{ #' \deqn{\left( \frac{(2n)!}{2^{n}n!} \right) ^{1/n}} #' } #' \if{html}{\preformatted{ #' / (2n!) \ 2 #' | ------ | #' \ 2^n n! / #' }} #' #' @param n order of the filter; must be < 25. #' #' @return List of class \code{\link{Zpg}} containing poles and gain of the #' filter #' #' @examples #' ## 6th order Bessel low-pass analog filter #' zp <- besselap(6) #' w <- seq(0, 4, length.out = 128) #' freqs(zp, w) #' #' @references \url{https://en.wikipedia.org/wiki/Bessel_polynomials} #' #' @author Thomas Sailer, \email{t.sailer@@alumni.ethz.ch}.\cr Conversion to R by #' Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export besselap <- function(n) { if (!isPosscal(n) || ! isWhole(n)) { stop("n must be an integer strictly positive") } if (n == 1) { p <- -1 } else { p0 <- 1 p1 <- rep(1L, 2) for (nn in 2:n) { px <- (2 * nn - 1) * p1 py <- c(p0, 0, 0) px <- prepad(px, max(length(px), length(py)), 0) py <- prepad(py, length(px)) p0 <- p1 p1 <- px + py } ## p1 now contains the reverse bessel polynomial for n ## scale it by replacing s->s/w0 so that the gain becomes 1 p1 <- p1 * p1[length(p1)] ^ (seq(length(p1) - 1, 0, -1) / (length(p1) - 1)) p <- pracma::roots(p1) } Zpg(complex(0), p, 1) } gsignal/R/mscohere.R0000644000176200001440000001235414420222025014025 0ustar liggesusers# mscohere.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2006 Peter V. Lanspeary # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201104 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Magnitude-squared coherence #' #' Compute the magnitude-squared coherence estimates of input signals. #' #' \code{mscohere} estimates the magnitude-squared coherence function using #' Welch’s overlapped averaged periodogram method [1] #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param window If \code{window} is a vector, each segment has the same length #' as \code{window} and is multiplied by \code{window} before (optional) #' zero-padding and calculation of its periodogram. If \code{window} is a #' scalar, each segment has a length of \code{window} and a Hamming window is #' used. Default: \code{nextpow2(sqrt(length(x)))} (the square root of the #' length of \code{x} rounded up to the next power of two). The window length #' must be larger than 3. #' @param overlap segment overlap, specified as a numeric value expressed as a #' multiple of window or segment length. 0 <= overlap < 1. Default: 0.5. #' @param nfft Length of FFT, specified as an integer scalar. The default is the #' length of the \code{window} vector or has the same value as the scalar #' \code{window} argument. If \code{nfft} is larger than the segment length, #' (seg_len), the data segment is padded \code{nfft - seg_len} zeros. The #' default is no padding. Nfft values smaller than the length of the data #' segment (or window) are ignored. Note that the use of padding to increase #' the frequency resolution of the spectral estimate is controversial. #' @param fs sampling frequency (Hertz), specified as a positive scalar. #' Default: 1. #' @param detrend character string specifying detrending option; one of: #' \describe{ #' \item{\code{long-mean}}{remove the mean from the data before #' splitting into segments (default)} #' \item{\code{short-mean}}{remove the mean value of each segment} #' \item{\code{long-linear}}{remove linear trend from the data before #' splitting into segments} #' \item{\code{short-linear}}{remove linear trend from each segment} #' \item{\code{none}}{no detrending} #' } #' #' @return A list containing the following elements: #' \describe{ #' \item{\code{freq}}{vector of frequencies at which the spectral variables #' are estimated. If \code{x} is numeric, power from negative frequencies is #' added to the positive side of the spectrum, but not at zero or Nyquist #' (fs/2) frequencies. This keeps power equal in time and spectral domains. #' If \code{x} is complex, then the whole frequency range is returned.} #' \item{\code{coh}}{NULL for univariate series. For multivariate series, a #' matrix containing the squared coherence between different series. Column #' \eqn{i + (j - 1) * (j - 2)/2 } of \code{coh} contains the cross-spectral #' estimates between columns \eqn{i} and \eqn{j} of \eqn{x}, where \eqn{i < #' j}.} #' } #' #' @examples #' fs <- 1000 #' f <- 250 #' t <- seq(0, 1 - 1/fs, 1/fs) #' s1 <- sin(2 * pi * f * t) + runif(length(t)) #' s2 <- sin(2 * pi * f * t - pi / 3) + runif(length(t)) #' rv <- mscohere(cbind(s1, s2), fs = fs) #' plot(rv$freq, rv$coh, type="l", xlab = "Frequency", ylab = "Coherence") #' #' @note The function \code{mscohere} (and its deprecated alias \code{cohere}) #' is a wrapper for the function \code{pwelch}, which is more complete and #' more flexible. #' #' @author Peter V. Lanspeary, \email{pvl@@mecheng.adelaide.edu.au}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references [1] Welch, P.D. (1967). The use of Fast Fourier Transform for #' the estimation of power spectra: A method based on time averaging over #' short, modified periodograms. IEEE Transactions on Audio and #' Electroacoustics, AU-15 (2): 70–73.\cr #' #' @rdname mscohere #' @export mscohere <- function(x, window = nextpow2(sqrt(NROW(x))), overlap = 0.5, nfft = ifelse(isScalar(window), window, length(window)), fs = 1, detrend = c("long-mean", "short-mean", "long-linear", "short-linear", "none")) { pw <- pwelch(x, window, overlap, nfft, fs, detrend) rv <- list(freq = pw$freq, coh = pw$coh) rv } #' @rdname mscohere #' @export cohere <- mscohere gsignal/R/tfestimate.R0000644000176200001440000001247014420222025014364 0ustar liggesusers# tfestimate.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2006 Peter V. Lanspeary # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201107 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Transfer Function Estimate #' #' Finds a transfer function estimate for signals. #' #' \code{tfestimate} uses Welch's averaged periodogram method. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param window If \code{window} is a vector, each segment has the same length #' as \code{window} and is multiplied by \code{window} before (optional) #' zero-padding and calculation of its periodogram. If \code{window} is a #' scalar, each segment has a length of \code{window} and a Hamming window is #' used. Default: \code{nextpow2(sqrt(length(x)))} (the square root of the #' length of \code{x} rounded up to the next power of two). The window length #' must be larger than 3. #' @param overlap segment overlap, specified as a numeric value expressed as a #' multiple of window or segment length. 0 <= overlap < 1. Default: 0.5. #' @param nfft Length of FFT, specified as an integer scalar. The default is the #' length of the \code{window} vector or has the same value as the scalar #' \code{window} argument. If \code{nfft} is larger than the segment length, #' (seg_len), the data segment is padded \code{nfft - seg_len} zeros. The #' default is no padding. Nfft values smaller than the length of the data #' segment (or window) are ignored. Note that the use of padding to increase #' the frequency resolution of the spectral estimate is controversial. #' @param fs sampling frequency (Hertz), specified as a positive scalar. #' Default: 1. #' @param detrend character string specifying detrending option; one of: #' \describe{ #' \item{\code{"long-mean"}}{remove the mean from the data before #' splitting into segments (default)} #' \item{\code{"short-mean"}}{remove the mean value of each segment} #' \item{\code{"long-linear"}}{remove linear trend from the data before #' splitting into segments} #' \item{\code{"short-linear"}}{remove linear trend from each segment} #' \item{\code{"none"}}{no detrending} #' } #' #' @return A list containing the following elements: #' \describe{ #' \item{\code{freq}}{vector of frequencies at which the spectral variables #' are estimated. If \code{x} is numeric, power from negative frequencies is #' added to the positive side of the spectrum, but not at zero or Nyquist #' (fs/2) frequencies. This keeps power equal in time and spectral domains. #' If \code{x} is complex, then the whole frequency range is returned.} #' \item{\code{trans}}{NULL for univariate series. For multivariate series, #' a matrix containing the transfer function estimates between different #' series. Column \eqn{i + (j - 1) * (j - 2)/2 } of \code{coh} contains the #' cross-spectral estimates between columns \eqn{i} and \eqn{j} of \eqn{x}, #' where \eqn{i < j}.} #' } #' #' @examples #' fs <- 1000 #' f <- 250 #' t <- seq(0, 1 - 1/fs, 1/fs) #' s1 <- sin(2 * pi * f * t) + runif(length(t)) #' s2 <- sin(2 * pi * f * t - pi / 3) + runif(length(t)) #' rv <- tfestimate(cbind(s1, s2), fs = fs) #' plot(rv$freq, 10*log10(abs(rv$trans)), type="l", xlab = "Frequency", #' ylab = "Tranfer Function Estimate (dB)", main = colnames((rv$trans))) #' #' h <- fir1(30, 0.2, window = rectwin(31)) #' x <- rnorm(16384) #' y <- filter(h, x) #' tfe <- tfestimate(cbind(x, y), 1024, fs = 500) #' plot(tfe$freq, 10*log10(abs(tfe$trans)), type="l", xlab = "Frequency", #' ylab = "Tranfer Function Estimate (dB)", main = colnames((tfe$trans))) #' #' @note The function \code{tfestimate} (and its deprecated alias \code{tfe}) #' is a wrapper for the function \code{pwelch}, which is more complete and #' more flexible. #' #' @author Peter V. Lanspeary, \email{pvl@@mecheng.adelaide.edu.au}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{pwelch}} #' #' @rdname tfestimate #' @export tfestimate <- function(x, window = nextpow2(sqrt(NROW(x))), overlap = 0.5, nfft = ifelse(isScalar(window), window, length(window)), fs = 1, detrend = c("long-mean", "short-mean", "long-linear", "short-linear", "none")) { pw <- pwelch(x, window, overlap, nfft, fs, detrend) rv <- list(freq = pw$freq, trans = pw$trans) rv } #' @rdname tfestimate #' @export tfe <- tfestimate gsignal/R/hamming.R0000644000176200001440000000545514525420011013645 0ustar liggesusers# hamming.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1995-2017 Andreas Weingessel # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191209 Geert van Boxtel First version for v0.1.0 # 20231116 Geert van Boxtel use coefficients 0.54 - 0.46 as in # Matlab/Octave #------------------------------------------------------------------------------ #' Hamming window #' #' Return the filter coefficients of a Hamming window of length \code{n}. #' #' The Hamming window is a member of the family of cosine sum windows. #' #' @param n Window length, specified as a positive integer. #' @param method Character string. Window sampling method, specified as: #' \describe{ #' \item{"symmetric"}{(Default). Use this option when using windows for filter #' design.} #' \item{"periodic"}{This option is useful for spectral analysis because it #' enables a windowed signal to have the perfect periodic extension implicit #' in the discrete Fourier transform. When \code{"periodic"} is specified, the #' function computes a window of length \code{n + 1} and returns the first #' \code{n} points.} #' } #' #' @return Hamming window, returned as a vector. If you specify a one-point #' window \code{(n = 1)}, the value 1 is returned. #' #' @examples #' #' h <- hamming(64) #' plot (h, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' hs = hamming(64,'symmetric') #' hp = hamming(63,'periodic') #' plot (hs, type = "l", xlab = "Samples", ylab =" Amplitude") #' lines(hp, col="red") #' #' @author Andreas Weingessel, \email{Andreas.Weingessel@@ci.tuwien.ac.at}.\cr #' Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export hamming <- function(n, method = c("symmetric", "periodic")) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) stop("n must be an integer strictly positive") method <- match.arg(method) if (method == "periodic") { N <- n } else if (method == "symmetric") { N <- n - 1 } else { stop("method must be either 'periodic' or 'symmetric'") } if (n == 1) { w <- 1 } else { n <- n - 1 w <- 0.54 - 0.46 * cos(2 * pi * (0:n) / N) } w } gsignal/R/cheb1ap.R0000644000176200001440000000366114420222025013524 0ustar liggesusers# cheb1ap.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2013 Carne Draug # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200519 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Chebyshev Type I filter prototype #' #' Return the poles and gain of an analog Chebyshev Type I lowpass filter #' prototype. #' #' This function exists for compatibility with 'Matlab' and 'OCtave' only, and #' is equivalent to \code{cheby1(n, Rp, 1, "low", "s")}. #' #' @param n Order of the filter. #' @param Rp dB of pass-band ripple. #' #' @return List of class \code{\link{Zpg}} containing the poles and gain of the #' filter. #' #' @examples #' ## 9th order Chebyshev type I low-pass analog filter #' zp <- cheb1ap(9, .1) #' w <- seq(0, 4, length.out = 128) #' freqs(zp, w) #' #' @author Carne Draug, \email{carandraug+dev@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export cheb1ap <- function(n, Rp) { if (!isPosscal(n) || ! isWhole(n)) stop("n must be an integer strictly positive") if (!isPosscal(Rp) || !is.numeric(Rp)) { stop("passband ripple Rp must a non-negative scalar") } cheby1(n, Rp, 1, "low", "s", "Zpg") } gsignal/R/mexihat.R0000644000176200001440000000522414420222025013655 0ustar liggesusers# mexihat.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2007 Sylvain Pelissier # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # 20191126 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Mexicat Hat #' #' Generate a Mexican Hat (Ricker) wavelet sampled on a regular grid. #' #' The Mexican Hat or Ricker wavelet is the negative normalized second #' derivative of a Gaussian function, i.e., up to scale and normalization, the #' second Hermite function. It is a special case of the family of continuous #' wavelets (wavelets used in a continuous wavelet transform) known as Hermitian #' wavelets. The Ricker wavelet is frequently employed to model seismic data, #' and as a broad spectrum source term in computational electrodynamics. It is #' usually only referred to as the Mexican hat wavelet in the Americas, due to #' taking the shape of a sombrero when used as a 2D image processing kernel. It #' is also known as the Marr wavelet (source: Wikipedia) #' #' @param lb,ub Lower and upper bounds of the interval to evaluate the wavelet #' on. Default: -5 to 5. #' @param n Number of points on the grid between \code{lb} and \code{ub} (length #' of the wavelet). Default: 1000. #' #' @return A list containing 2 variables; \code{x}, the grid on which the #' complex Mexican Hat wavelet was evaluated, and \code{psi} (\eqn{\Psi}), the #' evaluated wavelet on the grid \code{x}. #' #' @examples #' #' mh <- mexihat(-5, 5, 1000) #' plot(mh$x, mh$psi, type="l", main = "Mexican Hat Wavelet", #' xlab = "", ylab = "") #' #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export mexihat <- function(lb = -5, ub = 5, n = 1000) { if (!isPosscal(n) || !isWhole(n) || n <= 0) stop("n must be an integer strictly positive") x <- seq(lb, ub, length.out = n) psi <- (1 - x^2) * (2 / (sqrt(3) * pi^0.25)) * exp(-x^2 / 2) list(x = x, psi = psi) } gsignal/R/uencode.R0000644000176200001440000001122314420222025013634 0ustar liggesusers# uencode.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2014 Georgios Ouzounis # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191207 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Uniform encoder #' #' Quantize and encode floating-point inputs to integer outputs. #' #' \code{y <- uencode(u, n)} quantizes the entries in a multidimensional array #' of floating-point numbers \code{u} and encodes them as integers using #' \eqn{2^{n}}-level quantization. \code{n} must be an integer between 2 and 32 #' (inclusive). Inputs can be real or complex, double- or single-precision. The #' output \code{y} and the input \code{u} are arrays of the same size. The #' elements of the output \code{y} are unsigned integers with magnitudes in the #' range 0 to \eqn{2^{n} - 1}. Elements of the input \code{u} outside of the #' range -1 to 1 are treated as overflows and are saturated. #' \itemize{ #' \item For entries in the input u that are less than -1, the value of the #' output of uencode is 0. #' \item For entries in the input u that are greater than 1, the value of the #' output of uencode is \eqn{2^{n}-1}. #' } #' #' \code{y <- uencode(u, n, v)} allows the input \code{u} to have entries with #' floating-point values in the range \code{-v} to \code{v} before saturating #' them (the default value for \code{v} is 1). Elements of the input \code{u} #' outside of the range \code{-v} to \code{v} are treated as overflows and are #' saturated: #' \itemize{ #' \item For input entries less than \code{-v}, the value of the output of #' uencode is 0. #' \item For input entries greater than \code{v}, the value of the output of #' uencode is \eqn{2^{n} - 1}. #' } #' #' \code{y <- uencode(u, n, v, signed)} maps entries in a multidimensional array #' of floating-point numbers \code{u} whose entries have values in the range #' \code{-v} to \code{v} to an integer output \code{y}. Input entries outside #' this range are saturated. The integer type of the output depends on the #' number of quantization levels \eqn{2^{n}} and the value of \code{signed}, #' which can be one of the following: #' \itemize{ #' \item TRUE: Outputs are signed integers with magnitudes in the range #' \eqn{-2^{n} / 2} to \eqn{(2^{n} / 2) - 1}. #' \item FALSE (default): Outputs are unsigned integers with magnitudes in the #' range 0 to \eqn{2^{n} - 1}. #' } #' #' @param u Input, a multidimensional array of numbers, real or complex, single #' or double precision. #' @param n Number of levels used in \eqn{2^{n}}-level quantization. \code{n} #' must be between 2 and 32 #' @param v Limit on the range of \code{u} to the range from \code{-v} to #' \code{v} before saturating them. Default 1. #' @param signed Logical indicating signed or unsigned output. See Details. #' Default: FALSE. #' #' @return Multidimensional array of the same size as \code{u} containing signed #' or unsigned integers. #' #' @examples #' #' u <- seq(-1, 1, 0.01) #' y <- uencode(u, 3) #' plot(u, y) #' #' @author Georgios Ouzounis, \email{ouzounis_georgios@@hotmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export uencode <- function(u, n, v = 1, signed = FALSE) { if (!isScalar(n) || n < 2 || n > 32 || !isWhole(n)) stop("n must be an integer in the range 2 to 32") if (!isPosscal(v) || !isWhole(v) || v <= 0) stop("v must be a positive integer") if (!is.logical(signed)) stop("signed must be a logical") # R does not do comparisons with complex numbers (that makes some sense). # In Matlab, only the real parts of complex numbers are used for comparison. # This is done here as well. It would perhaps also make sense # to use the magnitide of the numbers to be compared... if (is.complex(u)) u <- Re(u) y <- u y[] <- 0 width <- 2 * v / 2 ^ n y[u >= v] <- (2^n) - 1 idx <- (u > -v) & (u < v) y[idx] <- floor((u[idx] + v) / width) if (signed) y <- y - 2 ^ (n - 1) y } gsignal/R/idct2.R0000644000176200001440000000526014420222025013223 0ustar liggesusers# idct2.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2001 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201015 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Inverse 2-D Discrete Cosine Transform #' #' Compute the inverse two-dimensional discrete cosine transform of a matrix. #' #' The discrete cosine transform (DCT) is closely related to the discrete #' Fourier transform. It is a separable linear transformation; that is, the #' two-dimensional transform is equivalent to a one-dimensional DCT performed #' along a single dimension followed by a one-dimensional DCT in the other #' dimension. #' #' @param x 2-D numeric matrix #' @param m Number of rows, specified as a positive integer. \code{dct2} pads or #' truncates \code{x} so that it has \code{m} rows. Default: \code{NROW(x)}. #' @param n Number of columns, specified as a positive integer. \code{dct2} pads #' or truncates \code{x} so that it has \code{n} columns. Default: #' \code{NCOL(x)}. #' #' @return \code{m}-by-\code{n} numeric discrete cosine transformed matrix. #' #' @examples #' A <- matrix(50 * runif(100), 10, 10) #' B <- dct2(A) #' B[which(B < 1)] <- 0 #' AA <- idct2(B) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{dct2}} #' #' @export idct2 <- function(x, m = NROW(x), n = NCOL(x)) { # check parameters if (!is.matrix(x) || !is.numeric(x)) { stop("x must be a numeric matrix") } nr <- nrow(x) nc <- ncol(x) if (!isPosscal(m) || !isWhole(m)) { stop("m must be a positive integer") } if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer") } if (m != nr) { x <- postpad(x, n, MARGIN = 2) } if (n != nc) { x <- postpad(x, n, MARGIN = 1) } if (m == 1) { y <- t(idct(t(x), n)) } else if (n == 1) { y <- idct(x, m) } else { y <- t(idct(t(idct(x, m)), n)) } y } gsignal/R/cheby1.R0000644000176200001440000001450014420222025013366 0ustar liggesusers# cheby1.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1999 Paul Kienzle # Copyright (C) 2003 Doug Stewart # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200519 Geert van Boxtel First version for v0.1.0 # 20200708 GvB renamed IIRfspec to FilterSpecs # 20210308 GvB added output parameter #------------------------------------------------------------------------------ #' Chebyshev Type I filter design #' #' Compute the transfer function coefficients of a Chebyshev Type I filter. #' #' Chebyshev filters are analog or digital filters having a steeper roll-off #' than Butterworth filters, and have passband ripple (type I) or stopband #' ripple (type II). #' #' Because \code{cheby1} is generic, it can be extended to accept other inputs, #' using \code{cheb1ord} to generate filter criteria for example. #' #' @param n filter order. #' @param Rp dB of passband ripple. #' @param w critical frequencies of the filter. \code{w} must be a scalar for #' low-pass and high-pass filters, and \code{w} must be a two-element vector #' c(low, high) specifying the lower and upper bands in radians/second. For #' digital filters, W must be between 0 and 1 where 1 is the Nyquist #' frequency. #' @param type filter type, one of \code{"low"}, \code{"high"}, \code{"stop"}, #' or \code{"pass"}. #' @param plane "z" for a digital filter or "s" for an analog filter. #' @param output Type of output, one of: #' \describe{ #' \item{"Arma"}{Autoregressive-Moving average (aka numerator/denominator, aka #' b/a)} #' \item{"Zpg"}{Zero-pole-gain format} #' \item{"Sos"}{Second-order sections} #' } #' Default is \code{"Arma"} for compatibility with the 'signal' package and the #' 'Matlab' and 'Octave' equivalents, but \code{"Sos"} should be preferred for #' general-purpose filtering because of numeric stability. #' @param ... additional arguments passed to \code{cheby1}, overriding those #' given by \code{n} of class \code{\link{FilterSpecs}}. #' #' @return Depending on the value of the \code{output} parameter, a list of #' class \code{\link{Arma}}, \code{\link{Zpg}}, or \code{\link{Sos}} #' containing the filter coefficients #' #' @examples #' ## compare the frequency responses of 5th-order #' ## Butterworth and Chebyshev filters. #' bf <- butter(5, 0.1) #' cf <- cheby1(5, 3, 0.1) #' bfr <- freqz(bf) #' cfr <- freqz(cf) #' plot(bfr$w / pi, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-40, 0), #' xlim = c(0, .5), xlab = "Frequency", ylab = c("dB")) #' lines(cfr$w / pi, 20 * log10(abs(cfr$h)), col = "red") #' #' # compare type I and type II Chebyshev filters. #' c1fr <- freqz(cheby1(5, .5, 0.5)) #' c2fr <- freqz(cheby2(5, 20, 0.5)) #' plot(c1fr$w / pi, abs(c1fr$h), type = "l", ylim = c(0, 1), #' xlab = "Frequency", ylab = c("Magnitude")) #' lines(c2fr$w / pi, abs(c2fr$h), col = "red") #' #' @references \url{https://en.wikipedia.org/wiki/Chebyshev_filter} #' #' @seealso \code{\link{Arma}}, \code{\link{filter}}, \code{\link{butter}}, #' \code{\link{ellip}}, \code{\link{cheb1ord}}, \code{\link{FilterSpecs}} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Doug Stewart, \email{dastew@@sympatico.ca}.\cr #' Conversion to R Tom Short,\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @rdname cheby1 #' @export cheby1 <- function(n, ...) UseMethod("cheby1") #' @rdname cheby1 #' @export cheby1.FilterSpecs <- function(n, ...) cheby1(n$n, n$Rp, n$Wc, n$type, n$plane, ...) #' @rdname cheby1 #' @export cheby1.default <- function(n, Rp, w, type = c("low", "high", "stop", "pass"), plane = c("z", "s"), output = c("Arma", "Zpg", "Sos"), ...) { # check input arguments type <- match.arg(type) plane <- match.arg(plane) output <- match.arg(output) if (!isPosscal(n) || !isWhole(n)) { stop("filter order n must be a positive integer") } if (!isPosscal(Rp) || !is.numeric(Rp)) { stop("passband ripple Rp must a non-negative scalar") } stop <- type == "stop" || type == "high" digital <- plane == "z" if (!is.vector(w) || (length(w) != 1 && length(w) != 2)) { stop(paste("frequency w must be specified as a vector of length 1 or 2", "(either w0 or c(w0, w1))")) } if ((type == "stop" || type == "pass") && length(w) != 2) { stop("w must be two elements for stop and bandpass filters") } if (digital && !all(w >= 0 & w <= 1)) { stop("critical frequencies w must be in the range [0 1]") } else if (!digital && !all(w >= 0)) { stop("critical frequencies w must be in the range [0 Inf]") } ## Prewarp to the band edges to s plane if (digital) { T <- 2 # sampling frequency of 2 Hz w <- 2 / T * tan(pi * w / T) } ## Generate splane poles and zeros for the chebyshev type 1 filter epsilon <- sqrt(10 ^ (Rp / 10) - 1) v0 <- asinh(1 / epsilon) / n pole <- exp(1i * pi * seq(- (n - 1), (n - 1), by = 2) / (2 * n)) pole <- -sinh(v0) * Re(pole) + 1i * cosh(v0) * Im(pole) zero <- numeric(0) ## compensate for amplitude at s=0 gain <- prod(-pole) ## if n is even, the ripple starts low, but if n is odd the ripple ## starts high. We must adjust the s=0 amplitude to compensate. if (n %% 2 == 0) { gain <- gain / 10 ^ (Rp / 20) } zpg <- Zpg(z = zero, p = pole, g = gain) ## splane frequency transform zpg <- sftrans(zpg, w = w, stop = stop) ## Use bilinear transform to convert poles to the z plane if (digital) { zpg <- bilinear(zpg, T = T) } if (output == "Arma") { retval <- as.Arma(zpg) } else if (output == "Sos") { retval <- as.Sos(zpg) } else { retval <- zpg } retval } gsignal/R/sinetone.R0000644000176200001440000000607314420222025014045 0ustar liggesusers# sinetone.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 1995-2019 Friedrich Leisch # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20201201 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Sine tone #' #' Generate discrete sine tone. #' #' @param freq frequency of the tone, specified as a vector of positive numeric #' values. The length of \code{freq} should equal the length of the #' \code{ampl} vector; the shorter of the two is recycled to the longer #' vector. #' @param rate sampling frequency, specified as a positive scalar. Default: #' 8000. #' @param sec length of the generated tone in seconds. Default: 1 #' @param ampl amplitude of the tone, specified as a vector of positive numeric #' values. The length of \code{ampl} should equal the length of the #' \code{freq} vector; the shorter of the two is recycled to the longer #' vector. Default: 64. #' #' @return Sine tone, returned as a vector of length \code{rate * sec}, or as a #' matrix with \code{rate * sec} columns and \code{max(length(freq), #' length(ampl))} columns. #' #' @examples #' fs <- 1000 #' sec <- 2 #' y <- sinetone(10, fs, sec, 1) #' plot(seq(0, sec, length.out = sec * fs), y, type = "l", xlab = "", ylab = "") #' #' y <- sinetone(c(10, 15), fs, sec, c(1, 2)) #' matplot(seq(0, sec, length.out = sec * fs), y, type = "l", #' xlab = "", ylab = "") #' #' @author Friedrich Leisch.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export sinetone <- function(freq, rate = 8000, sec = 1, ampl = 64) { if (!is.vector(freq) || !is.numeric(freq) || !all(freq >= 0)) { stop("freq must be a numeric vector > 0") } if (!is.numeric(rate) || !isScalar(rate) || rate <= 0) { stop("rate must be a numeric value > 0") } if (!is.numeric(sec) || !isScalar(sec) || sec <= 0) { stop("sec must be a numeric value > 0") } if (!is.vector(ampl) || !is.numeric(ampl)) { stop("freq must be a numeric vector") } lf <- length(freq) la <- length(ampl) maxl <- max(lf, la) if (lf < maxl) { freq <- rep(freq, length.out = maxl) } if (la < maxl) { ampl <- rep(ampl, length.out = maxl) } ns <- round(rate * sec) y <- matrix(0, ns, maxl) for (k in seq_len(maxl)) { y[, k] <- ampl[k] * sin(2 * pi * seq(1, ns) / rate * freq[k]) } if (maxl == 1) { y <- as.vector(y) } y } gsignal/R/morlet.R0000644000176200001440000000424014420222025013515 0ustar liggesusers# morlet.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2007 Sylvain Pelissier # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191126 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Morlet Wavelet #' #' Compute the Morlet wavelet on a regular grid. #' #' The code \code{m <- morlet(lb, ub, n)} returns values of the Morlet wavelet #' on an \code{n}-point regular grid in the interval \code{c(lb, ub)}. #' #' The Morlet waveform is defined as #' \deqn{\psi(x) = e^{-x^{2}/2} cos (5x)} #' #' @param lb,ub Lower and upper bounds of the interval to evaluate the wavelet #' on. Default: -4 to 4. #' @param n Number of points on the grid between \code{lb} and \code{ub} (length #' of the wavelet). Default: 1000. #' #' @return A list containing 2 variables; \code{x}, the grid on which the Morlet #' wavelet was evaluated, and \code{psi} (\eqn{\Psi}), the evaluated wavelet #' on the grid \code{x}. ##' #' @examples #' #' m <- morlet(-4, 4, 1000) #' plot(m$x, m$psi, type="l", main = "Morlet Wavelet", xlab = "", ylab = "") #' #' @author Sylvain Pelissier, \email{sylvain.pelissier@@gmail.com}.\cr #' Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export morlet <- function(lb = -4, ub = 4, n = 1000) { if (!isPosscal(n) || !isWhole(n) || n <= 0) stop("n must be an integer strictly positive") x <- seq(lb, ub, length.out = n) psi <- cos(5 * x) * exp(-x^2 / 2) list(x = x, psi = psi) } gsignal/R/cplxpair.R0000644000176200001440000001135714420222025014044 0ustar liggesusers# cplxpair.R # Copyright (C) 2020 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200327 GvB setup for gsignal v0.1.0 # 20210405 GvB changed 'dim' argument to MARGIN # 20210506 GvB bugfix in Check if real parts occur in pairs. #------------------------------------------------------------------------------ #' Complex conjugate pairs #' #' Sort complex numbers into complex conjugate pairs ordered by increasing real #' part. #' #' The negative imaginary complex numbers are placed first within each pair. All #' real numbers (those with \code{abs(Im (z) / z) < tol)} are placed after the #' complex pairs. #' #' An error is signaled if some complex numbers could not be paired and if all #' complex numbers are not exact conjugates (to within \code{tol}). #' #' @note There is no defined order for pairs with identical real parts but #' differing imaginary parts. #' #' @param z Vector, matrix, or array of complex numbers. #' @param tol Weighting factor \code{0 < tol < 1}, which determines the #' tolerance of matching. Default: \code{100 * .Machine$double.eps}. (This #' definition differs from the 'Octave' usage). #' @param MARGIN Vector giving the subscripts which the function will be applied #' over. E.g., for a matrix 1 indicates rows, 2 indicates columns, c(1, 2) #' indicates rows and columns. Where X has named dimnames, it can be a #' character vector selecting dimension names. Default: 2 (columns). #' #' @return Vector, matrix or array containing ordered complex conjugate pairs by #' increasing real parts. #' #' @examples #' r <- rbind(t(cplxpair(exp(2i * pi * 0:4 / 5))), #' t(exp(2i * pi *c(3, 2, 4, 1, 0) / 5))) #' #' @author Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{cplxreal}} #' #' @export cplxpair <- function(z, tol = 100 * .Machine$double.eps, MARGIN = 2) { vec <- FALSE if (is.vector(z)) { vec <- TRUE z <- as.matrix(z) } if (!isPosscal(tol) || tol > 1) { stop("tol must be a positive scalar between 0 and 1") } d <- dim(z) if (any(d <= 0)) { y <- array(0L, d) if (vec) y <- as.vector(y) return(y) } sort_vec <- function(v) { v <- as.vector(v) l <- length(v) y <- rep(0L, l) # Find real values and put them (sorted) at the end of y idx <- which(abs(Im(v)) <= tol * abs(v)) n <- length(idx) if (n > 0) { y[(l - n + 1):l] <- sort(Re(v[idx])) v <- v[-idx] } # remaining values are all complex, if any nv <- length(v) if (nv > 0) { if (nv %% 2 == 1) { stop("Could not pair all complex numbers") } # Sort v based on real part s <- sort(Re(v), index.return = TRUE) v <- v[s$ix] # Check if real parts occur in pairs. If not: error a <- matrix(s$x, ncol = 2, byrow = TRUE) if (any(abs(a[, 1] - a[, 2]) > tol * abs(a[, 1]))) { stop("Could not pair all complex numbers") } # Check if imag part of real part pairs are conjugates yix <- 1 while (length(v) > 0) { # Find all real parts equal to to real(v[1]) idx <- which(abs(Re(v) - Re(v[1])) <= tol * abs(Re(v))) nn <- length(idx) if (nn <= 1) { stop("Could not pair all complex numbers") } # Sort the imag parts of those values si <- sort(Im(v[idx]), index.return = TRUE) q <- v[si$ix] # Get values with identical real parts, lq <- length(q) # now sorted by imaginary parts # Verify conjugate-pairing of imag parts if (any(abs(si$x + rev(si$x)) > tol * abs(q))) { stop("Could not pair all complex numbers") } # Keep value with positive imag part, and compute conjugate # Value with smallest neg imag part first, then its conj y[yix:(yix + nn - 1)] <- as.vector(t(cbind(Conj(q[seq(lq, (nn / 2 + 1), -1)]), q[seq(lq, (nn / 2 + 1), -1)]))) yix <- yix + nn # update y index v <- v[-idx] # Remove entries from v } } y } if (vec) { y <- as.vector(sort_vec(z)) } else { y <- apply(z, MARGIN, sort_vec) } y } gsignal/R/pei_tseng_notch.R0000644000176200001440000000670714420222025015375 0ustar liggesusers# pei_tseng_notch.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2011 Alexander Klein # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200622 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Pei-Tseng notch filter #' #' Compute the transfer function coefficients of an IIR narrow-band notch #' filter. #' #' The filter construction is based on an all-pass which performs a reversal of #' phase at the filter frequencies. Thus, the mean of the phase-distorted and #' the original signal has the respective frequencies removed. #' #' @param w vector of critical frequencies of the filter. Must be between 0 #' and 1 where 1 is the Nyquist frequency. #' @param bw vector of bandwidths. Bw should be of the same length as \code{w}. #' #' @return List of class \code{\link{Arma}} with list elements: #' \describe{ #' \item{b}{moving average (MA) polynomial coefficients} #' \item{a}{autoregressive (AR) polynomial coefficients} #' } #' #' @examples #' ## 50 Hz notch filter #' fs <- 256 #' nyq <- fs / 2 #' notch <- pei_tseng_notch(50 / nyq, 2 / nyq) #' freqz(notch, fs = fs) #' #' @references Pei, Soo-Chang, and Tseng, Chien-Cheng "IIR Multiple Notch Filter #' Design Based on Allpass Filter"; 1996 IEEE Tencon, doi: #' \doi{10.1109/TENCON.1996.608814} #' #' @seealso \code{\link{Arma}}, \code{\link{filter}} #' #' @author Alexander Klein, \email{alexander.klein@@math.uni-giessen.de}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export pei_tseng_notch <- function(w, bw) { # check input arguments if (!is.vector(w) || !is.vector(bw)) { stop("All arguments must be vectors") } if (length(w) != length(bw)) { stop("All arguments must be of equal length") } if (!all(w > 0 && bw < 1)) { stop("All frequencies must be in the range (0, 1)") } if (!all(bw > 0 && bw < 1)) { stop("All bandwidths must be in the range (0, 1)") } ## Normalize appropriately w <- w * pi bw <- bw * pi M2 <- 2 * length(w) ## Splice center and offset frequencies (Equation 11) omega <- as.vector(rbind(w - bw / 2, w)) ## Splice center and offset phases (Equations 12) factors <- seq(1, M2, 2) phi <- as.vector(rbind(-pi * factors + pi / 2, -pi * factors)) ## Create linear equation t_beta <- tan((phi + M2 * omega) / 2) Q <- matrix(0L, nrow = M2, ncol = M2) for (k in seq_len(M2)) { Q [, k] <- sin(k * omega) - t_beta * cos(k * omega) } ## Compute coefficients of system function (Equations 19, 20) ... h_a <- as.vector(pracma::mldivide(Q, t_beta)) denom <- c(1, h_a) num <- c(rev(h_a), 1) ## ... and transform them to coefficients for difference equations a <- denom b <- (num + denom) / 2 Arma(b, a) } gsignal/R/cpsd.R0000644000176200001440000001242714420222025013152 0ustar liggesusers# cpsd.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2006 Peter V. Lanspeary # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201104 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Cross power spectral density #' #' Estimates the cross power spectral density (CPSD) of discrete-time signals. #' #' \code{cpsd} estimates the cross power spectral density function using #' Welch’s overlapped averaged periodogram method [1]. #' #' @param x input data, specified as a numeric vector or matrix. In case of a #' vector it represents a single signal; in case of a matrix each column is a #' signal. #' @param window If \code{window} is a vector, each segment has the same length #' as \code{window} and is multiplied by \code{window} before (optional) #' zero-padding and calculation of its periodogram. If \code{window} is a #' scalar, each segment has a length of \code{window} and a Hamming window is #' used. Default: \code{nextpow2(sqrt(length(x)))} (the square root of the #' length of \code{x} rounded up to the next power of two). The window length #' must be larger than 3. #' @param overlap segment overlap, specified as a numeric value expressed as a #' multiple of window or segment length. 0 <= overlap < 1. Default: 0.5. #' @param nfft Length of FFT, specified as an integer scalar. The default is the #' length of the \code{window} vector or has the same value as the scalar #' \code{window} argument. If \code{nfft} is larger than the segment length, #' (seg_len), the data segment is padded \code{nfft - seg_len} zeros. The #' default is no padding. Nfft values smaller than the length of the data #' segment (or window) are ignored. Note that the use of padding to increase #' the frequency resolution of the spectral estimate is controversial. #' @param fs sampling frequency (Hertz), specified as a positive scalar. #' Default: 1. #' @param detrend character string specifying detrending option; one of: #' \describe{ #' \item{\code{"long-mean"}}{remove the mean from the data before #' splitting into segments (default)} #' \item{\code{"short-mean"}}{remove the mean value of each segment} #' \item{\code{"long-linear"}}{remove linear trend from the data before #' splitting into segments} #' \item{\code{"short-linear"}}{remove linear trend from each segment} #' \item{\code{"none"}}{no detrending} #' } #' #' @return A list containing the following elements: #' \describe{ #' \item{\code{freq}}{vector of frequencies at which the spectral variables #' are estimated. If \code{x} is numeric, power from negative frequencies is #' added to the positive side of the spectrum, but not at zero or Nyquist #' (fs/2) frequencies. This keeps power equal in time and spectral domains. #' If \code{x} is complex, then the whole frequency range is returned.} #' \item{\code{cross}}{NULL for univariate series. For multivariate series, #' a matrix containing the squared coherence between different series. #' Column \eqn{i + (j - 1) * (j - 2)/2 } of \code{coh} contains the #' cross-spectral estimates between columns \eqn{i} and \eqn{j} of \eqn{x}, #' where \eqn{i < j}.} #' } #' #' @examples #' fs <- 1000 #' f <- 250 #' t <- seq(0, 1 - 1/fs, 1/fs) #' s1 <- sin(2 * pi * f * t) + runif(length(t)) #' s2 <- sin(2 * pi * f * t - pi / 3) + runif(length(t)) #' rv <- cpsd(cbind(s1, s2), fs = fs) #' plot(rv$freq, 10 * log10(rv$cross), type="l", xlab = "Frequency", #' ylab = "Cross Spectral Density (dB)") #' #' @note The function \code{cpsd} (and its deprecated alias \code{csd}) #' is a wrapper for the function \code{pwelch}, which is more complete and #' more flexible. #' #' @author Peter V. Lanspeary, \email{pvl@@mecheng.adelaide.edu.au}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references [1] Welch, P.D. (1967). The use of Fast Fourier Transform for #' the estimation of power spectra: A method based on time averaging over #' short, modified periodograms. IEEE Transactions on Audio and #' Electroacoustics, AU-15 (2): 70–73.\cr #' #' @rdname cpsd #' @export cpsd <- function(x, window = nextpow2(sqrt(NROW(x))), overlap = 0.5, nfft = ifelse(isScalar(window), window, length(window)), fs = 1, detrend = c("long-mean", "short-mean", "long-linear", "short-linear", "none")) { pw <- pwelch(x, window, overlap, nfft, fs, detrend) rv <- list(freq = pw$freq, cross = pw$cross) rv } #' @rdname cpsd #' @export csd <- cpsd gsignal/R/shiftdata.R0000644000176200001440000000713714420222025014172 0ustar liggesusers# shiftdata.R # Copyright (C) 2019 Geert van Boxtel # Matlab/Octave signal package: # Copyright (C) 2014 Georgios Ouzounis # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191202 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Shift data to operate on specified dimension #' #' Shift data in to permute the dimension \code{dimx} to the first column. #' #' \code{shiftdata(x, dimx)} shifts data \code{x} to permute dimension #' \code{dimx} to the first column using the same permutation as the built-in #' \code{filter} function. The vector \code{perm} in the output list returns the #' permutation vector that is used. #' #' If \code{dimx} is missing or empty, then the first nonsingleton dimension is #' shifted to the first column, and the number of shifts is returned in #' \code{nshifts}. #' #' \code{shiftdata} is meant to be used in tandem with \code{unshiftdata}, which #' shifts the data back to its original shape. These functions are useful for #' creating functions that work along a certain dimension, like #' \code{\link{filter}}, \code{\link{sgolayfilt}}, and \code{\link{sosfilt}}. #' #' @param x The data to be shifted. Can be of any type. #' @param dimx Dimension of \code{x} to be shifted to the first column. Named #' "dimx" instead of "dim" to avoid confusion with R's dim() function. #' Default: NULL (shift the first nonsingleton dimension) #' #' @return A list containing 3 variables; \code{x}, the shifted data, #' \code{perm}, the permutation vector, and \code{nshifts}, the number of #' shifts #' #' @examples #' #' ## create a 3x3 magic square #' x <- pracma::magic(3) #' ## Shift the matrix x to work along the second dimension. #' ## The permutation vector, perm, and the number of shifts, nshifts, #' ## are returned along with the shifted matrix. #' sd <- shiftdata(x, 2) #' #' ## Shift the matrix back to its original shape. #' y <- unshiftdata(sd) #' #' ## Rearrange Array to Operate on First nonsingleton Dimension #' x <- 1:5 #' sd <- shiftdata(x) #' y <- unshiftdata(sd) #' #' @author Georgios Ouzounis, \email{ouzounis_georgios@@hotmail.com}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{unshiftdata}} #' #' @export shiftdata <- function(x, dimx) { x <- as.array(x) # needed for aperm if (missing(dimx) || is.null(dimx)) { dimx <- which((dim(x) - 1) > 0)[1] shift <- TRUE } else { shift <- FALSE } if (!isScalar(dimx) || !isWhole(dimx)) stop("dimx must be an integer") if (dimx > length(dim(x))) stop(paste("dimx should be between 1 and", length(dim(x)))) perm <- dimx if (dimx - 1 >= 1) { perm <- c(dimx, 1:(dimx - 1)) } d1 <- dimx + 1 d2 <- length(dim(x)) if (d1 <= d2) perm <- c(perm, d1:d2) out <- aperm(x, perm) if (shift) { perm <- NA nshifts <- dimx - 1 } else { nshifts <- NA } list(x = out, perm = perm, nshifts = nshifts) } gsignal/R/cheby2.R0000644000176200001440000001532714420222025013377 0ustar liggesusers# cheby2.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 1999 Paul Kienzle # Copyright (C) 2003 Doug Stewart # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200519 Geert van Boxtel First version for v0.1.0 # 20200708 GvB renamed IIRfspec to FilterSpecs # 20210308 GvB added output parameter #------------------------------------------------------------------------------ #' Chebyshev Type II filter design #' #' Compute the transfer function coefficients of a Chebyshev Type II filter. #' #' Chebyshev filters are analog or digital filters having a steeper roll-off #' than Butterworth filters, and have passband ripple (type I) or stopband #' ripple (type II). #' #' Because \code{cheby2} is generic, it can be extended to accept other inputs, #' using \code{cheb2ord} to generate filter criteria for example. #' #' @param n filter order. #' @param Rs dB of stopband ripple. #' @param w critical frequencies of the filter. \code{w} must be a scalar for #' low-pass and high-pass filters, and \code{w} must be a two-element vector #' c(low, high) specifying the lower and upper bands in radians/second. For #' digital filters, W must be between 0 and 1 where 1 is the Nyquist #' frequency. #' @param type filter type, one of \code{"low"}, \code{"high"}, \code{"stop"}, #' or \code{"pass"}. #' @param plane "z" for a digital filter or "s" for an analog filter. #' @param output Type of output, one of: #' \describe{ #' \item{"Arma"}{Autoregressive-Moving average (aka numerator/denominator, aka #' b/a)} #' \item{"Zpg"}{Zero-pole-gain format} #' \item{"Sos"}{Second-order sections} #' } #' Default is \code{"Arma"} compatibility with the 'signal' package and the #' 'Matlab' and 'Octave' equivalents, but \code{"Sos"} should be preferred for #' general-purpose filtering because of numeric stability. #' @param ... additional arguments passed to cheby1, overriding those given by #' \code{n} of class \code{FilterSpecs}. #' #' @return Depending on the value of the \code{output} parameter, a list of #' class \code{\link{Arma}}, \code{\link{Zpg}}, or \code{\link{Sos}} #' containing the filter coefficients #' #' @examples #' ## compare the frequency responses of 5th-order #' ## Butterworth and Chebyshev filters. #' bf <- butter(5, 0.1) #' cf <- cheby2(5, 20, 0.1) #' bfr <- freqz(bf) #' cfr <- freqz(cf) #' plot(bfr$w / pi, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-40, 0), #' xlim = c(0, .5), xlab = "Frequency", ylab = c("dB")) #' lines(cfr$w / pi, 20 * log10(abs(cfr$h)), col = "red") #' #' # compare type I and type II Chebyshev filters. #' c1fr <- freqz(cheby1(5, .5, 0.5)) #' c2fr <- freqz(cheby2(5, 20, 0.5)) #' plot(c1fr$w / pi, abs(c1fr$h), type = "l", ylim = c(0, 1.1), #' xlab = "Frequency", ylab = c("Magnitude")) #' lines(c2fr$w / pi, abs(c2fr$h), col = "red") #' #' @references \url{https://en.wikipedia.org/wiki/Chebyshev_filter} #' #' @seealso \code{\link{Arma}}, \code{\link{filter}}, \code{\link{butter}}, #' \code{\link{ellip}}, \code{\link{cheb2ord}} #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net},\cr #' Doug Stewart, \email{dastew@@sympatico.ca}.\cr #' Conversion to R Tom Short,\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @rdname cheby2 #' @export cheby2 <- function(n, ...) UseMethod("cheby2") #' @rdname cheby2 #' @export cheby2.FilterSpecs <- function(n, ...) cheby2(n$n, n$Rs, n$Wc, n$type, n$plane, ...) #' @rdname cheby2 #' @export cheby2.default <- function(n, Rs, w, type = c("low", "high", "stop", "pass"), plane = c("z", "s"), output = c("Arma", "Zpg", "Sos"), ...) { # check input arguments type <- match.arg(type) plane <- match.arg(plane) output <- match.arg(output) if (!isPosscal(n) || !isWhole(n)) { stop("filter order n must be a positive integer") } if (!isPosscal(Rs) || !is.numeric(Rs)) { stop("passband ripple Rs must a non-negative scalar") } stop <- type == "stop" || type == "high" digital <- plane == "z" if (!is.vector(w) || (length(w) != 1 && length(w) != 2)) { stop(paste("frequency w must be specified as a vector of length 1 or 2", "(either w0 or c(w0, w1))")) } if ((type == "stop" || type == "pass") && length(w) != 2) { stop("w must be two elements for stop and bandpass filters") } if (digital && !all(w >= 0 & w <= 1)) { stop("critical frequencies w must be in the range [0 1]") } else if (!digital && !all(w >= 0)) { stop("critical frequencies w must be in the range [0 Inf]") } ## Prewarp to the band edges to s plane if (digital) { T <- 2 # sampling frequency of 2 Hz w <- 2 / T * tan(pi * w / T) } ## Generate splane poles and zeros for the chebyshev type 2 filter ## From: Stearns, SD; David, RA; (1988). Signal Processing Algorithms. ## New Jersey: Prentice-Hall. C <- 1 # default cutoff frequency lambda <- 10 ^ (Rs / 20) phi <- log(lambda + sqrt(lambda^2 - 1)) / n theta <- pi * ((1:n) - 0.5) / n alpha <- -sinh(phi) * sin(theta) beta <- cosh(phi) * cos(theta) if (n %% 2) { ## drop theta==pi/2 since it results in a zero at infinity zero <- 1i * C / cos(theta[c(1:((n - 1) / 2), ((n + 3) / 2):n)]) }else { zero <- 1i * C / cos(theta) } pole <- C / (alpha^2 + beta^2) * (alpha - 1i * beta) ## Compensate for amplitude at s=0 ## Because of the vagaries of floating point computations, the ## prod(pole)/prod(zero) sometimes comes out as negative and ## with a small imaginary component even though analytically ## the gain will always be positive, hence the abs(Re(...)) gain <- abs(Re(prod(pole) / prod(zero))) zpg <- Zpg(z = zero, p = pole, g = gain) ## splane frequency transform zpg <- sftrans(zpg, w = w, stop = stop) ## Use bilinear transform to convert poles to the z plane if (digital) { zpg <- bilinear(zpg, T = T) } if (output == "Arma") { retval <- as.Arma(zpg) } else if (output == "Sos") { retval <- as.Sos(zpg) } else { retval <- zpg } retval } gsignal/R/freqs.R0000644000176200001440000001235214661636707013365 0ustar liggesusers# freqs.R # Copyright (C) 2020 Geert van Boxtel # Original Octave function: # Copyright (C) 2003 Julius O. Smith III # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200413 GvB setup for gsignal v0.1.0 # 20200427 GvB added S3 methods # 20240822 GvB changed setup to match freqz using S3 methods #------------------------------------------------------------------------------ #' Frequency response of analog filters #' #' Compute the s-plane frequency response of an IIR filter. #' #' The s-plane frequency response of the IIR filter \code{B(s) / A(s)} is #' computed as \code{H = polyval(B, 1i * W) / polyval(A, 1i * W)}. If called #' with no output argument, a plot of magnitude and phase are displayed. #' #' @param filt for the default case, moving average (MA) polynomial #' coefficients, specified as a numeric vector or matrix. In case of a matrix, #' then each row corresponds to an output of the system. The number of columns #' of \code{b} must be less than or equal to the length of \code{a}. #' @param a autoregressive (AR) polynomial coefficients, specified as a vector. #' @param w angular frequencies, specified as a positive real vector expressed #' in rad/second. #' @param x object to be printed or plotted. #' @param object object of class \code{"freqs"} for \code{summary} #' @param ... for methods of \code{freqs}, arguments are passed to the default #' method. For \code{freqs_plot}, additional arguments are passed through to #' plot. #' #' @return For \code{freqs}, a list of class \code{'freqs'} with items: #' \describe{ #' \item{h}{complex array of frequency responses at frequencies \code{f}.} #' \item{w}{array of frequencies.} #' } #' #' @examples #' b <- c(1, 2); a <- c(1, 1) #' w <- seq(0, 4, length.out = 128) #' freqs (b, a, w) #' #' @author Julius O. Smith III, \email{jos@@ccrma.stanford.edu}.\cr #' Conversion to R by Geert van Boxtel \email{gjmvanboxtel@@gmail.com} #' #' @rdname freqs #' @export freqs <- function(filt, ...) UseMethod("freqs") #' @rdname freqs #' @export freqs.default <- function(filt, a, w, ...) { h <- pracma::polyval(filt, 1i * w) / pracma::polyval(a, 1i * w) res <- list(h = h, w = w) class(res) <- "freqs" res } #' @rdname freqs #' @export freqs.Arma <- function(filt, w, ...) # IIR freqs.default(filt$b, filt$a, w, ...) #' @rdname freqs #' @export freqs.Ma <- function(filt, w, ...) # FIR freqs.default(filt, 1, w, ...) #' @rdname freqs #' @export freqs.Sos <- function(filt, w, ...) # second-order sections freqs.Arma(as.Arma(filt), w, ...) #' @rdname freqs #' @export freqs.Zpg <- function(filt, w, ...) # zero-pole-gain freqs.Arma(as.Arma(filt), w, ...) #' @rdname freqs #' @export print.freqs <- plot.freqs <- function(x, ...) freqs_plot(x, ...) #' @rdname freqs #' @export summary.freqs <- function(object, ...) { nm <- deparse(substitute(object)) h <- object$h w <- object$w rw <- range(w) mag <- 20 * log10(abs(h)) mmag <- max(mag) wmag <- w[which.max(mag)] cutoff <- w[diff(ifelse((!is.finite(mag) | is.na(mag) | mag < -3), 0, 1)) != 0] phase <- unwrap(Arg(h)) rp <- range(phase) structure(list(nm = nm, rw = rw, mmag = mmag, wmag = wmag, cutoff = cutoff, rp = rp), class = c("summary.freqs", "list")) } #' @rdname freqs #' @export print.summary.freqs <- function(x, ...) { cat(paste0("\nSummary of freqs object '", x$nm, "':\n")) rw <- round(x$rw, 3) cat(paste("\nFrequencies ranging from", rw[1], "to", rw[2])) mmag <- round(x$mmag, 3) wmag <- round(x$wmag, 3) cat(paste0("\nMaximum magnitude ", mmag, " dB at frequency ", wmag)) cutoff <- round(x$cutoff, 3) lc <- length(cutoff) fr <- ifelse(lc > 1, "frequencies", "frequency") cat(paste0("\n-3 dB cutoff at ", fr, " ", cutoff[1])) if (lc > 1) { for (i in 2:lc) { cat(paste(",", cutoff[i])) } } rp <- round(x$rp, 3) rpd <- round(rp * 360 / (2 * pi), 3) cat(paste0("\nPhase ranging from ", rp[1], " to ", rp[2], " rad (", rpd[1], " to ", rpd[2], " degrees)")) cat("\n") } #' @rdname freqs #' @export freqs_plot <- function(x, ...) { mag <- 20 * log10(abs(x$h)) phase <- unwrap(Arg(x$h)) op <- graphics::par(mfrow = c(2, 1)) on.exit(graphics::par(op)) graphics::plot(x$w, mag, type = "l", xlab = "", ylab = "dB", ...) graphics::legend("topright", "Magnitude (dB)", lty = 1) graphics::title("Frequency response plot by freqs") graphics::plot(x$w, phase / (2 * pi), type = "l", xlab = "Frequency (rad/s)", ylab = "Phase", ...) graphics::legend("topright", "Phase (radians / 2 pi)", lty = 1) graphics::title("") } gsignal/R/qp_kaiser.R0000644000176200001440000000651614420222025014201 0ustar liggesusers# qp_kaiser.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2002 André Carezia # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200710 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Kaiser FIR filter design #' #' Compute FIR filter for use with a quasi-perfect reconstruction #' polyphase-network filter bank. #' #' @param nb number of frequency bands, specified as a scalar #' @param at attenuation (in dB) in the stop band. #' @param linear logical, indicating linear scaling. If FALSE (default), the #' Kaiser window is multiplied by the ideal impulse response \eqn{h(n) = a #' sinc(an)} and converted to its minimum-phase version by means of a Hilbert #' transform. #' #' @return The FIR filter coefficients, of class \code{Ma}. #' #' @examples #'\donttest{ #' freqz(qp_kaiser(1, 20)) #' freqz(qp_kaiser(1, 40)) #'} #' #' @seealso \code{\link{Ma}}, \code{\link{filter}}, \code{\link{fftfilt}}, #' \code{\link{fir2}} #' #' @author André Carezia, \email{andre@@carezia.eng.br}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @export qp_kaiser <- function(nb, at, linear = FALSE) { if (!(isPosscal(nb) && isWhole(nb) && nb > 0)) { stop("nb must be a positive integer") } if (!(isPosscal(at) && at > 0)) { stop("at must be a positive scalar") } if (!is.logical(linear)) { stop("linear must be logical") } ## Bandwidth bandwidth <- pi / nb ## Attenuation correction (empirically ## determined by M. Gerken ## ) corr <- (1.4 + 0.6 * (at - 20) / 80) ^ (20 / at) at <- corr * at ## size of window (rounded to next odd integer) N <- (at - 8) / (2.285 * bandwidth) M <- trunc(N / 2) N <- 2 * M + 1 ## Kaiser window if (at > 50) { beta <- 0.1102 * (at - 8.7) } else if (at > 21) { beta <- 0.5842 * (at - 21)^0.4 + 0.07886 * (at - 21) } else { beta <- 0 } w <- kaiser(N, beta) ## squared in freq. domain wsquared <- conv(w, w) ## multiplied by ideal lowpass filter n <- - (N - 1):(N - 1) hideal <- 1 / nb * sinc(n / nb) hcomp <- wsquared %o% hideal ## extract square-root of response and ## compute minimum-phase version Ndft <- 2^15 Hsqr <- sqrt(abs(stats::mvfft(postpad(hcomp, Ndft)))) if (linear) { h <- Re(ifft(Hsqr)) h <- h[2:N] h <- c(rev(h), h[1], h) } else { # prevent log of 0 or negative number Hsqr[which(Hsqr <= 0)] <- min(Hsqr[which(Hsqr > 0)]) Hmin <- Hsqr * exp(-1i * Im(hilbert(log(Hsqr)))) h <- Re(imvfft(Hmin)) h <- h[1:N] } ## truncate and fix amplitude scale (H(0)=1) h <- h / sum(h) Ma(h) } gsignal/R/filter_zi.R0000644000176200001440000001151714663324243014225 0ustar liggesusers# filter_zi.R # Copyright (C) 2021 Geert van Boxtel # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20210319 GvB setup for gsignal v0.3.0 #------------------------------------------------------------------------------ #' Filter initial conditions #' #' Construct initial conditions for a filter #' #' This function computes an initial state for the filter function that #' corresponds to the steady state of the step response. In other words, it #' finds the initial condition for which the response to an input of all ones is #' a constant. Therefore, the results returned by this function can also be #' obtained using the function \code{\link{filtic}} by setting \code{x} and #' \code{y} to all 1s (see the examples). #' #' A typical use of this function is to set the initial state so that the output #' of the filter starts at the same value as the first element of the signal to #' be filtered. #' #' @param filt For the default case, the moving-average coefficients of an ARMA #' filter (normally called \code{b}), specified as a vector. #' @param a the autoregressive (recursive) coefficients of an ARMA filter, #' specified as a vector. #' @param ... additional arguments (ignored). #' #' @return The initial state for the filter, returned as a vector. #' #' @examples #' ## taken from Python scipy.signal.lfilter_zi documentation #' #' h <- butter(5, 0.25) #' zi <- filter_zi(h) #' y <- filter(h, rep(1, 10), zi) #' ## output is all 1, as expected. #' y2 <- filter(h, rep(1, 10)) #' ## if the zi argument is not given, the output #' ## does not return the final conditions #' #' x <- c(0.5, 0.5, 0.5, 0.0, 0.0, 0.0, 0.0) #' y <- filter(h, x, zi = zi*x[1]) #' ## Note that the zi argument to filter was computed using #' ## filter_zi and scaled by x[1]. Then the output y has no #' ## transient until the input drops from 0.5 to 0.0. #' #' ## obtain the same results with filtic #' lab <- max(length(h$b), length(h$a)) - 1 #' ic <- filtic(h, rep(1, lab), rep(1, lab)) #' all.equal(zi, ic) #' #' @author Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}, #' converted to R from Python scipy.signal.lfilter_zi. #' #' @seealso \code{\link{filtic}} #' #' @references Gustafsson, F. (1996). Determining the initial states in #' forward-backward filtering. IEEE Transactions on Signal Processing, 44(4), #' 988 - 992. #' #' @rdname filter_zi #' @export filter_zi <- function(filt, ...) UseMethod("filter_zi") #' @rdname filter_zi #' @method filter_zi default #' @export filter_zi.default <- function(filt, a, ...) { if (!is.vector(filt) || ! is.vector(a) || !is.numeric(filt) || !is.numeric(a)) { stop("b and a must be numeric vectors") } while (length(a) > 1 && a[1] == 0) { a <- a[2:length(a)] } if (length(a) < 1) { stop("There must be at least one nonzero element in the vector a") } if (a[1] != 1) { # Normalize the coefficients so a[1] == 1. filt <- filt / a[1] a <- a / a[1] } n <- max(length(a), length(filt)) # Pad a or b with zeros so they are the same length. filt <- postpad(filt, n) a <- postpad(a, n) B <- filt[2:length(filt)] - a[2:length(a)] * filt[1] IminusA <- diag(rep(1, n - 1)) - t(pracma::compan(a)) # Solve zi = A*zi + B zi <- solve(IminusA, B) zi } #' @rdname filter_zi #' @method filter_zi Arma #' @export filter_zi.Arma <- function(filt, ...) # IIR filter_zi(filt$b, filt$a, ...) #' @rdname filter_zi #' @method filter_zi Ma #' @export filter_zi.Ma <- function(filt, ...) # FIR filter_zi(unclass(filt), 1, ...) #' @rdname filter_zi #' @method filter_zi Sos #' @export filter_zi.Sos <- function(filt, ...) { # Second-order sections if (filt$g != 1) { filt$sos[1, 1:3] <- filt$sos[1, 1:3] * filt$g } L <- NROW(filt$sos) zi <- matrix(0, L, 2) scale <- 1.0 for (l in seq_len(L)) { b <- filt$sos[l, 1:3] a <- filt$sos[l, 4:6] zi[l, ] <- scale * filter_zi.default(b, a) # If H(z) = B(z)/A(z) is this section's transfer function, then # b.sum()/a.sum() is H(1), the gain at omega=0. That's the steady # state value of this section's step response. scale <- scale * sum(b) / sum(a) } zi } #' @rdname filter_zi #' @method filter_zi Zpg #' @export filter_zi.Zpg <- function(filt, ...) # zero-pole-gain form filter_zi(as.Arma(filt), ...) gsignal/R/dctmtx.R0000644000176200001440000000544214666070160013540 0ustar liggesusers# dctmtx.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2001 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201016 GvB setup for gsignal v0.1.0 # 20210420 GvB corrected error in example #------------------------------------------------------------------------------ #' Discrete Cosine Transform Matrix #' #' Compute the discrete cosine transform matrix. #' #' A DCT transformation matrix is useful for doing things like JPEG image #' compression, in which an 8x8 DCT matrix is applied to non-overlapping blocks #' throughout an image and only a sub-block on the top left of each block is #' kept. During restoration, the remainder of the block is filled with zeros #' and the inverse transform is applied to the block. #' #' The two-dimensional DCT of A can be computed as \code{D \%*\% A \%*\% t(D)}. #' This computation is sometimes faster than using \code{dct2}, especially if #' you are computing a large number of small DCTs, because D needs to be #' determined only once. For example, in JPEG compression, the DCT of each #' 8-by-8 block is computed. To perform this computation, use \code{dctmtx} to #' determine D of input image A, and then calculate each DCT using \code{D \%*\% #' A \%*\% t(D)} (where A is each 8-by-8 block). This is faster than calling #' \code{dct2} for each individual block. #' #' @param n Size of DCT matrix, specified as a positive integer. #' #' @return Discrete cosine transform, returned as a vector or matrix. #' #' @examples #' D <- dctmtx(8) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{dct}}, \code{\link{dct2}}, \code{\link{idct}}, #' \code{\link{idct2}} #' #' @export dctmtx <- function(n) { # check parameters if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer") } if (n > 1) { T <- rbind(sqrt(1 / n) * rep(1, n), sqrt(2 / n) * cos((pi / 2 / n) * seq(1, (n - 1)) %o% seq(1, 2 * n, 2))) } else if (n == 1) { T <- 1 } else { stop("n must be >= 1") } T } gsignal/R/fftfilt.R0000644000176200001440000001654114420222025013660 0ustar liggesusers# fftfilt.R # Copyright (C) 2020 Geert van Boxtel # Octave function: # Copyright (C) 1994-2017 John W. Eaton # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20200417 GvB setup for gsignal v0.1.0 # 20200420 GvB adapted slightly (rounding in case of whole numbers) # 20201121 GvB done away with FFTfilt, only method for Ma() # 20210630 GvB fixed Github bug #3: Problems with fftfilt when FFT # length is provided by user # 20210712 GvB copy attributes of input x to output y #------------------------------------------------------------------------------ #' FFT-based FIR filtering #' #' FFT-based FIR filtering using the overlap-add method. #' #' This function combines two important techniques to speed up filtering of long #' signals, the overlap-add method, and FFT convolution. The overlap-add method #' is used to break long signals into smaller segments for easier processing or #' preventing memory problems. FFT convolution uses the overlap-add method #' together with the Fast Fourier Transform, allowing signals to be convolved by #' multiplying their frequency spectra. For filter kernels longer than about 64 #' points, FFT convolution is faster than standard convolution, while producing #' exactly the same result. #' #' The overlap-add technique works as follows. When an \code{N} length signal is #' convolved with a filter kernel of length \code{M}, the output signal is #' \code{N + M - 1} samples long, i.e., the signal is expanded 'to the right'. #' The signal is then broken into \code{k} smaller segments, and the convolution #' of each segment with the f kernel will have a result of length \code{N / k + #' M -1}. The individual segments are then added together. The rightmost \code{M #' - 1} samples overlap with the leftmost \code{M - 1} samples of the next #' segment. The overlap-add method produces exactly the same output signal as #' direct convolution. #' #' FFT convolution uses the principle that multiplication in the frequency #' domain corresponds to convolution in the time domain. The input signal is #' transformed into the frequency domain using the FFT, multiplied by the #' frequency response of the filter, and then transformed back into the time #' domain using the inverse FFT. With FFT convolution, the filter kernel can be #' made very long, with very little penalty in execution time. #' #' @param b moving average (Ma) coefficients of a FIR filter, specified as a #' vector. #' @param x the input signal to be filtered. If x is a matrix, its columns are #' filtered. #' @param n FFT length, specified as a positive integer. The FFT size must be an #' even power of 2 and must be greater than or equal to the length of #' \code{filt}. If the specified \code{n} does not meet these criteria, it is #' automatically adjusted to the nearest value that does. If \code{n = NULL} #' (default), then the overlap-add method is not used. #' #' @return The filtered signal, returned as a vector or matrix with the same #' dimensions as \code{x}. #' #' @examples #' t <- seq(0, 1, len = 10000) # 1 second sample #' x <- sin(2* pi * t * 2.3) + 0.25 * rnorm(length(t)) # 2.3 Hz sinusoid+noise #' filt <- rep(0.1, 10) # filter kernel #' y1 <- filter(filt, 1, x) # use normal convolution #' y2 <- fftfilt(filt, x) # FFT convolution #' plot(t, x, type = "l") #' lines(t, y1, col = "red") #' lines(t, y2, col = "blue") #' #' ## use 'filter' with different classes #' t <- seq(0, 1, len = 10000) # 1 second sample #' x <- sin(2* pi * t * 2.3) + 0.25 * rnorm(length(t)) # 2.3 Hz sinusoid+noise #' ma <- Ma(rep(0.1, 10)) # filter kernel #' y1 <- filter(ma, x) # convulution filter #' y2 <- fftfilt(ma, x) # FFT filter #' all.equal(y1, y2) # same result #' #' @seealso \code{\link{filter}} #' #' @references \url{https://en.wikipedia.org/wiki/Overlap-add_method}. #' #' @author Kurt Hornik, \email{Kurt.Hornik@@wu-wien.ac.at},\cr #' adapted by John W. Eaton.\cr #' Conversion to R by Tom Short,\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @rdname fftfilt #' @export fftfilt <- function(b, x, n = NULL) UseMethod("fftfilt") #' @rdname fftfilt #' @method fftfilt default #' @export fftfilt.default <- function(b, x, n = NULL) { if (!is.vector(b)) { stop("'b' must be a vector") } else { lb <- length(b) } #save attributes of x atx <- attributes(x) if (is.vector(x)) { lx <- length(x) } else if (is.matrix(x)) { nrx <- nrow(x) ncx <- ncol(x) } else { stop("'x' must be a vector, a matrix, or a 2-D array") } if (is.null(n)) { ## Use FFT with the smallest power of 2 which is >= length (x) + ## length (b) - 1 as number of points ... if (is.vector(x)) { n <- nextpow2(lx + lb - 1) B <- stats::fft(postpad(b, n)) y <- ifft(stats::fft(postpad(x, n)) * B) } else { n <- nextpow2(nrx + lb - 1) B <- stats::fft(postpad(b, n)) y <- imvfft(stats::mvfft(postpad(x, n)) * replicate(ncx, B)) } } else { ## Use overlap-add method ... if (!isPosscal(n) || !isWhole(n)) { stop("'n' must be a positive integer") } n <- nextpow2(max(n, lb)) L <- n - lb + 1 if (is.vector(x)) { R <- ceiling(lx / L) y <- rep(0L, lx) B <- stats::fft(postpad(b, n)) for (r in seq_len(R)) { lo <- (r - 1) * L + 1 hi <- min(r * L, lx) tmp <- rep(0L, n) tmp[1:(hi - lo + 1)] <- x[lo:hi] tmp <- ifft(stats::fft(postpad(tmp, n)) * B) hi <- min(lo + n - 1, lx) y[lo:hi] <- y[lo:hi] + tmp[1:(hi - lo + 1)] } } else { R <- ceiling(nrx / L) y <- matrix(0L, nrx, ncx) B <- stats::fft(postpad(b, n)) for (r in seq_len(R)) { lo <- (r - 1) * L + 1 hi <- min(r * L, nrx) tmp <- matrix(0L, n, ncx) tmp[1:(hi - lo + 1), ] <- x[lo:hi, ] tmp <- imvfft(stats::mvfft(postpad(tmp, n)) * replicate(ncx, B)) hi <- min(lo + n - 1, nrx) y[lo:hi, ] <- y[lo:hi, ] + tmp[1:(hi - lo + 1), ] } } } if (is.vector(x)) { y <- y[1:lx] } else { y <- y[1:nrx, ] } ## Final cleanups: if both x and b are real respectively integer, y ## should also be if (is.numeric(b) && is.numeric(x)) y <- Re(y) if (!any(as.logical(b - round(b)))) { idx <- !any(as.logical(x - round(x))) y[idx] <- round(y[idx]) } # set attributes of y nd return attributes(y) <- atx y } #' @rdname fftfilt #' @method fftfilt Ma #' @export fftfilt.Ma <- function(b, x, n = NULL) { fftfilt.default(unclass(b), x, n) } gsignal/R/chebwin.R0000644000176200001440000000631714420222025013641 0ustar liggesusers# chebwin.R # Copyright (C) 2019 Geert van Boxtel # Octave signal package: # Copyright (C) 2002 André Carezia # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20191211 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Chebyshev window #' #' Return the filter coefficients of a Dolph-Chebyshev window. #' #' The window is described in frequency domain by the expression: #' \if{latex}{ #' \deqn{W(k) = \frac{Cheb(m - 1, \beta \cdot cos(\pi \cdot k / m))}{Cheb(m - #' 1, \beta)}} #' } #' \if{html}{\preformatted{ #' Cheb(m - 1, Beta * cos(\pi * k / m)) #' W(k) = ------------------------------------ #' Cheb(m - 1, Beta) #' }} #' with #' \if{latex}{ #' \deqn{\beta = cosh(1 / (m - 1) \cdot acosh(10^{(at / 20)})} #' } #' \if{html}{\preformatted{ #' Beta = cosh(1 / (m - 1) * acosh(10^(at / 20)) #' }} #' and and \eqn{Cheb(m, x)} denoting the \eqn{m}-th order Chebyshev polynomial #' calculated at the point \eqn{x}. #' #' Note that the denominator in W(k) above is not computed, and after the #' inverse Fourier transform the window is scaled by making its maximum value #' unitary. #' #' @param n Window length, specified as a positive integer. #' @param at Stop-band attenuation in dB. Default: 100. #' #' @return Chebyshev window, returned as a vector. If you specify a one-point #' window \code{(n = 1)}, the value 1 is returned. #' #' @examples #' #' cw <- chebwin(64) #' plot (cw, type = "l", xlab = "Samples", ylab =" Amplitude") #' #' #' @author André Carezia, \email{acarezia@@uol.com.br}.\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. # #' @export chebwin <- function(n, at = 100) { if (!isPosscal(n) || ! isWhole(n) || n <= 0) stop("n must be an integer strictly positive") if (!isScalar(at) || ! is.double(at) || n <= 0) stop("at must be a real scalar") if (n == 1) { w <- 1 } else { ## beta calculation gamma <- 10 ^ (-at / 20) beta <- cosh(1 / (n - 1) * acosh(1 / gamma)) ## freq. scale k <- 0:(n - 1) x <- beta * cos(pi * k / n) ## Chebyshev window (freq. domain) p <- cheb(n - 1, x) ## inverse Fourier transform if (n %% 2) { w <- Re(stats::fft(p)) M <- (n + 1) / 2 w <- w[1:M] / w[1] w <- c(w[M:2], w) } else { ## half-sample delay (even order) p <- p * exp(1i * pi / n * (0:(n - 1))) w <- Re(stats::fft(p)) M <- n / 2 + 1 w <- w / w[2] w <- c(w[M:2], w[2:M]) } } w <- w / max(w) w } gsignal/R/ellip.R0000644000176200001440000001461414420222025013326 0ustar liggesusers# ellip.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 2001 Paulo Neis # Copyright (C) 2003 Doug Stewart # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20200527 Geert van Boxtel First version for v0.1.0 # 20200708 GvB renamed IIRfspec to FilterSpecs # 20210308 GvB added output parameter #------------------------------------------------------------------------------ #' Elliptic filter design #' #' Compute the transfer function coefficients of an elliptic filter. #' #' An elliptic filter is a filter with equalized ripple (equiripple) behavior in #' both the passband and the stopband. The amount of ripple in each band is #' independently adjustable, and no other filter of equal order can have a #' faster transition in gain between the passband and the stopband, for the #' given values of ripple. #' #' As the ripple in the stopband approaches zero, the filter becomes a type I #' Chebyshev filter. As the ripple in the passband approaches zero, the filter #' becomes a type II Chebyshev filter and finally, as both ripple values #' approach zero, the filter becomes a Butterworth filter. #' #' Because \code{ellip} is generic, it can be extended to accept other inputs, #' using \code{ellipord} to generate filter criteria for example. #' #' @param n filter order. #' @param Rp dB of passband ripple. #' @param Rs dB of stopband ripple. #' @param w critical frequencies of the filter. \code{w} must be a scalar for #' low-pass and high-pass filters, and \code{w} must be a two-element vector #' \code{c(low, high)} specifying the lower and upper bands in radians/second. #' For digital filters, w must be between 0 and 1 where 1 is the Nyquist #' frequency. #' @param type filter type, one of \code{"low"}, \code{"high"}, \code{"stop"}, #' or \code{"pass"}. #' @param plane "z" for a digital filter or "s" for an analog filter. #' @param output Type of output, one of: #' \describe{ #' \item{"Arma"}{Autoregressive-Moving average (aka numerator/denominator, aka #' b/a)} #' \item{"Zpg"}{Zero-pole-gain format} #' \item{"Sos"}{Second-order sections} #' } #' Default is \code{"Arma"} for compatibility with the 'signal' package and the #' 'Matlab' and 'Octave' equivalents, but \code{"Sos"} should be preferred for #' general-purpose filtering because of numeric stability. #' @param ... additional arguments passed to ellip, overriding those given by #' \code{n} of class \code{FilterSpecs}. #' #' @return Depending on the value of the \code{output} parameter, a list of #' class \code{\link{Arma}}, \code{\link{Zpg}}, or \code{\link{Sos}} #' containing the filter coefficients #' #' @examples #' ## compare the frequency responses of 5th-order Butterworth #' ## and elliptic filters. #' bf <- butter(5, 0.1) #' ef <- ellip(5, 3, 40, 0.1) #' bfr <- freqz(bf) #' efr <- freqz(ef) #' plot(bfr$w, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-80, 0), #' xlab = "Frequency (Rad)", ylab = c("dB"), lwd = 2, #' main = paste("Elliptic versus Butterworth filter", #' "low-pass -3 dB cutoff at 0.1 rad", sep = "\n")) #' lines(efr$w, 20 * log10(abs(efr$h)), col = "red", lwd = 2) #' legend ("topright", legend = c("Butterworh", "Elliptic"), #' lty = 1, lwd = 2, col = 1:2) #' #' @references \url{https://en.wikipedia.org/wiki/Elliptic_filter} #' #' @seealso \code{\link{Arma}}, \code{\link{filter}}, \code{\link{butter}}, #' \code{\link{cheby1}}, \code{\link{ellipord}} #' #' @author Paulo Neis, \email{p_neis@@yahoo.com.br},\cr #' adapted by Doug Stewart, \email{dastew@@sympatico.ca}.\cr #' Conversion to R Tom Short,\cr #' adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @rdname ellip #' @export ellip <- function(n, ...) UseMethod("ellip") #' @rdname ellip #' @export ellip.FilterSpecs <- function(n, Rp = n$Rp, Rs = n$Rs, w = n$Wc, type = n$type, plane = n$plane, ...) ellip(n$n, Rp, Rs, w, type, plane, ...) #' @rdname ellip #' @export ellip.default <- function(n, Rp, Rs, w, type = c("low", "high", "stop", "pass"), plane = c("z", "s"), output = c("Arma", "Zpg", "Sos"), ...) { # check input arguments type <- match.arg(type) plane <- match.arg(plane) output <- match.arg(output) if (!isPosscal(n) || !isWhole(n)) { stop("filter order n must be a positive integer") } if (!isPosscal(Rp) || !is.numeric(Rp)) { stop("passband ripple Rp must a non-negative scalar") } if (!isPosscal(Rs) || !is.numeric(Rs)) { stop("stopband ripple Rp must a non-negative scalar") } stop <- type == "stop" || type == "high" digital <- plane == "z" if (!is.vector(w) || (length(w) != 1 && length(w) != 2)) { stop(paste("frequency w must be specified as a vector of length 1 or 2", "(either w0 or c(w0, w1))")) } if ((type == "stop" || type == "pass") && length(w) != 2) { stop("w must be two elements for stop and bandpass filters") } if (digital && !all(w >= 0 & w <= 1)) { stop("critical frequencies w must be in the range [0 1]") } else if (!digital && !all(w >= 0)) { stop("critical frequencies w must be in the range [0 Inf]") } ## Prewarp to the band edges to s plane if (digital) { T <- 2 # sampling frequency of 2 Hz w <- 2 / T * tan(pi * w / T) } ## Generate splane poles, zeros and gain zpg <- ncauer(Rp, Rs, n) ## s-plane frequency transform zpg <- sftrans(zpg, w = w, stop = stop) ## Use bilinear transform to convert poles to the z plane if (digital) { zpg <- bilinear(zpg, T = T) } if (output == "Arma") { retval <- as.Arma(zpg) } else if (output == "Sos") { retval <- as.Sos(zpg) } else { retval <- zpg } retval } gsignal/R/dct2.R0000644000176200001440000000515614420222025013056 0ustar liggesusers# dct2.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2001 Paul Kienzle # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201015 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' 2-D Discrete Cosine Transform #' #' Compute the two-dimensional discrete cosine transform of a matrix. #' #' The discrete cosine transform (DCT) is closely related to the discrete #' Fourier transform. It is a separable linear transformation; that is, the #' two-dimensional transform is equivalent to a one-dimensional DCT performed #' along a single dimension followed by a one-dimensional DCT in the other #' dimension. #' #' @param x 2-D numeric matrix #' @param m Number of rows, specified as a positive integer. \code{dct2} pads or #' truncates \code{x} so that is has \code{m} rows. Default: \code{NROW(x)}. #' @param n Number of columns, specified as a positive integer. \code{dct2} pads #' or truncates \code{x} so that is has \code{n} columns. Default: #' \code{NCOL(x)}. #' #' @return \code{m}-by-\code{n} numeric discrete cosine transformed matrix. #' #' @examples #' A <- matrix(runif(100), 10, 10) #' B <- dct2(A) #' #' @author Paul Kienzle, \email{pkienzle@@users.sf.net}.\cr Conversion to R by #' Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @seealso \code{\link{idct2}} #' #' @export dct2 <- function(x, m = NROW(x), n = NCOL(x)) { # check parameters if (!is.matrix(x) || !is.numeric(x)) { stop("x must be a numeric matrix") } nr <- nrow(x) nc <- ncol(x) if (!isPosscal(m) || !isWhole(m)) { stop("m must be a positive integer") } if (!isPosscal(n) || !isWhole(n)) { stop("n must be a positive integer") } if (m != nr) { x <- postpad(x, n, MARGIN = 2) } if (n != nc) { x <- postpad(x, n, MARGIN = 1) } if (m == 1) { y <- t(dct(t(x), n)) } else if (n == 1) { y <- dct(x, m) } else { y <- t(dct(t(dct(x, m)), n)) } y } gsignal/R/invfreq.R0000644000176200001440000001700514420222025013670 0ustar liggesusers# invfreq.R # Copyright (C) 2020 Geert van Boxtel # Octave signal package: # Copyright (C) 1986, 2000, 2003 Julius O. Smith III # Copyright (C) 2007 Rolf Schirmacher # Copyright (C) 2003 Andrew Fitting # Copyright (C) 2010 Pascal Dupuis # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; see the file COPYING. If not, see # . # # 20201118 Geert van Boxtel First version for v0.1.0 #------------------------------------------------------------------------------ #' Inverse Frequency Response #' #' Identify filter parameters from frequency response data. #' #' Given a desired (one-sided, complex) spectrum \code{h(w)} at equally spaced #' angular frequencies \eqn{w = (2 \pi k) / N}, k = 0, ... N-1, this function #' finds the filter \code{B(z)/A(z)} or \code{B(s)/A(s)} with \code{nb} zeroes #' and \code{na} poles. Optionally, the fit-errors can be weighted with respect #' to frequency according to the weights \code{wt}. #' #' @param h Frequency response, specified as a vector #' @param w Angular frequencies at which \code{h} is computed, specified as a #' vector #' @param nb,na Desired order of the numerator and denominator polynomials, #' specified as positive integers. #' @param wt Weighting factors, specified as a vector of the same length as #' \code{w}. Default: \code{rep(1, length(w))} #' @param plane \code{"z"} (default) for discrete-time spectra; \code{"s"} for #' continuous-time spectra #' @param method minimization method used to solve the normal equations, one of: #' \describe{ #' \item{"ols"}{ordinary least squares (default)} #' \item{"tls"}{total least squares} #' \item{"qr"}{QR decomposition} #' } #' @param norm logical indicating whether frequencies must be normalized to #' avoid matrices with rank deficiency. Default: TRUE #' #' @return A list of class \code{'Arma'} with the following list elements: #' \describe{ #' \item{b}{moving average (MA) polynomial coefficients} #' \item{a}{autoregressive (AR) polynomial coefficients} #' } #' #' @examples #' order <- 6 # order of test filter #' fc <- 1/2 # sampling rate / 4 #' n <- 128 # frequency grid size #' ba <- butter(order, fc) #' hw <- freqz(ba, n) #' BA = invfreq(hw$h, hw$w, order, order) #' HW = freqz(BA, n) #' plot(hw$w, abs(hw$h), type = "l", xlab = "Frequency (rad/sample)", #' ylab = "Magnitude") #' lines(HW$w, abs(HW$h), col = "red") #' legend("topright", legend = c("Original", "Measured"), lty = 1, col = 1:2) #' err <- norm(hw$h - HW$h, type = "2") #' title(paste('L2 norm of frequency response error =', err)) #' #' @author Julius O. Smith III, Rolf Schirmacher, Andrew Fitting, Pascal #' Dupuis.\cr Conversion to R by Geert van Boxtel, #' \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @references #' \url{https://ccrma.stanford.edu/~jos/filters/FFT_Based_Equation_Error_Method.html} #' #' @rdname invfreq #' @export invfreq <- function(h, w, nb, na, wt = rep(1, length(w)), plane = c("z", "s"), method = c("ols", "tls", "qr"), norm = TRUE) { # Parameter checking if (!is.vector(h)) { stop("h must be a vector") } if (!is.vector(w)) { stop("h must be a vector") } nw <- length(w) if (length(h) != nw) { stop("h and f must be of equal length") } if (!isPosscal(nb) || !isWhole(nb) || nb <= 0 || !isPosscal(na) || !isWhole(na) || na <= 0) { stop("na and nb must be positive integers > 0") } if (length(nb) > 1) { zb <- nb[2] nb <- nb[1] } else { zb <- 0 } n <- max(na, nb) ma <- na + 1; mb <- nb + 1 if (!is.vector(wt) || length(wt) != nw) { stop("wt must be a vector of the same length as w") } plane <- match.arg(plane) method <- match.arg(method) norm <- is.logical(norm) # End of parameter checking Ruu <- matrix(0, mb, mb) Ryy <- matrix(0, na, na) Ryu <- matrix(0, na, mb) Pu <- rep(0, mb) Py <- rep(0, na) s <- 1i * w if (plane == "z") { if (max(w) > pi || min(w) < 0) { # frequency is outside the range 0 to pi w <- seq(0, pi, length.out = length(h)) s <- 1i * w } s <- exp(-s) } else if (plane == "s") { wmax <- max(w) if (wmax > 1e6 && n > 5 && !norm) { warning("Be careful, there are risks of generating singular matrices") warning("Use norm = TRUE to avoid it") } if (norm) { s <- 1i * w / wmax } } for (k in seq_len(nw)) { Zk <- s[k]^seq(0, n) Hk <- h[k] aHks <- Hk * Conj(Hk) Rk <- (wt[k] * Zk) %*% t(Zk) rRk <- Re(Rk) Ruu <- Ruu + rRk[1:mb, 1:mb] Ryy <- Ryy + aHks * rRk[2:ma, 2:ma] Ryu <- Ryu + Re(Hk * Rk[2:ma, 1:mb]) Pu <- Pu + wt[k] * Re(Conj(Hk) * Zk[1:mb]) Py <- Py + (wt[k] * aHks) * Re(Zk[2:ma]) } Rr <- matrix(1, length(s), mb + na) Zk <- s for (k in seq_len(min(na, na))) { Rr[, (1 + k)] <- Zk Rr[, (mb + k)] <- -Zk * h Zk <- Zk * s } from <- 1 + min(na, nb) to <- max(na, nb) - 1 if (to >= from) { for (k in seq(from, to)) { if (k <= nb) { Rr[, (1 + k)] <- Zk } if (k <= na) { Rr[, (mb + k)] <- -Zk * h } Zk <- Zk * s } } k <- k + 1 if (k <= nb) { Rr[, (1 + k)] <- Zk } if (k <= na) { Rr[, (mb + k)] <- -Zk * h } ## complex to real equation system -- this ensures real solution Rr <- Rr[, (1 + zb):ncol(Rr)] Rr <- rbind(Re(Rr), Im(Rr)) Pr <- c(Re(h), Im(h)) if (method == "ols") { R <- qr.R(qr(cbind(Rr, Pr))) Theta <- pracma::mldivide(R[1:(nrow(R) - 1), 1:(ncol(R) - 1)], R[1:(nrow(R) - 1), ncol(R)]) } else if (method == "tls") { SVD <- svd(cbind(Rr, Pr)) V <- SVD$v Theta <- -V[1:(nrow(V) - 1), ncol(V)] / V[nrow(V), ncol(V)] } else if (method == "qr") { R <- qr.R(qr(cbind(Rr, Pr))) eb <- mb - zb sa <- eb + 1 SVD <- svd(R[sa:nrow(R), sa:ncol(R)]) V <- SVD$v Theta <- -V[1:(nrow(V) - 1), ncol(V)] / V[nrow(V), ncol(V)] Theta <- c( pracma::mldivide(R[1:eb, 1:eb], (R[1:eb, ncol(R)] - R[1:eb, sa:(ncol(R) - 1)] %*% Theta)), Theta) } else { stop("unknown method") #can never happen } B <- c(rep(0, zb), Theta[1:(mb - zb)]) A <- c(1, Theta[mb - zb + (1:na)]) if (plane == "s") { B <- rev(B) A <- rev(A) if (norm) { Zk <- wmax ^ seq(n, 0, -1) for (k in seq(nb, 1 + zb, -1)) { B[k] <- B[k] / Zk[k] } for (k in seq(na, 1, -1)) { A[k] <- A[k] / Zk[k] } } } Arma(B, A) } #' @rdname invfreq #' @export invfreqs <- function(h, w, nb, na, wt = rep(1, length(w)), method = c("ols", "tls", "qr"), norm = TRUE) { invfreq(h, w, nb, na, wt, plane = "s", method, norm) } #' @rdname invfreq #' @export invfreqz <- function(h, w, nb, na, wt = rep(1, length(w)), method = c("ols", "tls", "qr"), norm = TRUE) { invfreq(h, w, nb, na, wt, plane = "z", method, norm) } gsignal/R/pow2db.R0000644000176200001440000000330114420222025013405 0ustar liggesusers# pow2db.R # Copyright (C) 2020 Geert van Boxtel # Original Octave code: # Copyright (C) 2018 P Sudeepam # # This program is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License # as published by the Free Software Foundation; either version 3 # of the License, or (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Version history # 20201105 GvB setup for gsignal v0.1.0 #------------------------------------------------------------------------------ #' Power - decibel conversion #' #' Convert power to decibel and decibel to power. #' #' @param x input data, specified as a numeric vector, matrix, or #' multidimensional array. Must be non-negative for numeric \code{x}. #' #' @return Converted data, same type and dimensions as \code{x}. #' #' @examples #' db <- pow2db(c(0, 10, 100)) #' pow <- db2pow(c(-10, 0, 10)) #' #' @author P. Sudeepam\cr #' Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@@gmail.com}. #' #' @rdname pow2db #' @export pow2db <- function(x) { if (!(is.numeric(x) || is.complex(x))) { stop("x must be a numeric or complex vector, matrix, or array") } if (is.numeric(x) && any(x < 0)) { stop("x must be non-negative") } 10 * log10(x) } #' @rdname pow2db #' @export db2pow <- function(x) { 10 ^ (x / 10) } gsignal/COPYING0000644000176200001440000010451614420222025012731 0ustar liggesusers GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . gsignal/vignettes/0000755000176200001440000000000014670306232013711 5ustar liggesusersgsignal/vignettes/gsignal.Rmd0000644000176200001440000007325114525424466016022 0ustar liggesusers--- title: "Signal Processing in R" author: Geert van Boxtel date: April 30, 2021 output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Signal Processing in R} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` # 1. Introduction Most engineers use Matlab (or its open source alternative Octave) to solve their signal processing problems. Languages such as R or Python are not immediately thought of for signal processing, although this has changed a bit in the last few years with the development of the R [signal](https://r-forge.r-project.org/projects/signal/) package and Python [scipy.signal](https://docs.scipy.org/doc/scipy/reference/signal.html). The package `gsignal` aims to further stimulate the use of R for signal processing tasks. It is ported from the Octave [signal](https://octave.sourceforge.io/signal/) package, version 1.4.1 (2019-02-08). The package contains a variety of signal processing tools, such as signal generation and measurement, correlation and convolution, filtering, FIR and IIR filter design, filter analysis and conversion, power spectrum analysis, system identification, decimation and sample rate change, and windowing. This vignette provides a brief and general overview of some of `gsignal`'s functions. ```{r setup} library(gsignal) ``` # 2. Signal generation and measurement The function `pulstran` can be used to generate trains of pulses based on samples of a continuous function (which can be user-defined). The following figures show a periodic rectangular pulse, an asymmetric sawtooth pulse, a periodic Gaussian waveform, and a custom pulse train. ```{r pulstran, fig.height=7, fig.width=7} op <- par(mfrow = c(2, 2)) ## periodic rectangular pulse t <- seq(0, 60, 1/1e3) d <- cbind(seq(0, 60, 2), sin(2 * pi * 0.05 * seq(0, 60, 2))) y <- pulstran(t, d, 'rectpuls') plot(t, y, type = "l", xlab = "", ylab = "", main = "Periodic rectangular pulse") ## assymetric sawtooth waveform fs <- 1e3 t <- seq(0, 1, 1/fs) d <- seq(0, 1, 1/3) x <- tripuls(t, 0.2, -1) y <- pulstran(t, d, x, fs) plot(t, y, type = "l", xlab = "", ylab = "", main = "Asymmetric sawtooth ") ## Periodic Gaussian waveform fs <- 1e7 tc <- 0.00025 t <- seq(-tc, tc, 1/fs) x <- gauspuls(t, 10e3, 0.5) ts <- seq(0, 0.025, 1/50e3) d <- cbind(seq(0, 0.025, 1/1e3), sin(2 * pi * 0.1 * (0:25))) y <- pulstran(ts, d, x, fs) plot(ts, y, type = "l", xlab = "", ylab = "", main = "Gaussian pulse") ## Custom pulse trains fnx <- function(x, fn) sin(2 * pi * fn * x) * exp(-fn * abs(x)) ffs <- 1000 tp <- seq(0, 1, 1 / ffs) pp <- fnx(tp, 30) fs <- 2e3 t <- seq(0, 1.2, 1 / fs) d <- seq(0, 1, 1/3) dd <- cbind(d, 4^-d) z <- pulstran(t, dd, pp, ffs) plot(t, z, type = "l", xlab = "", ylab = "", main = "Custom pulse") par(op) ``` A number of waveform generating functions are available, such as `chirp`, `cmorwavf`, `diric`, `gauspuls`, `gmonopuls`, `mexihat`, `meyeraux`, `morlet`, `rectpuls`, `sawtooth`, `square`, and `tripuls`. The function `findpeaks` can be used to determine (local) minima and maxima in a signal, as the following figures show. ```{r findpeaks, fig.height=4, fig.width=7} t <- 2 * pi * seq(0, 1,length = 1024) y <- sin(3.14 * t) + 0.5 * cos(6.09 * t) + 0.1 * sin(10.11 * t + 1 / 6) + 0.1 * sin(15.3 * t + 1 / 3) data1 <- abs(y) # Positive values peaks1 <- findpeaks(data1) data2 <- y # Double-sided peaks2 <- findpeaks(data2, DoubleSided = TRUE) peaks3 <- findpeaks (data2, DoubleSided = TRUE, MinPeakHeight = 0.5) op <- par(mfrow=c(1,2)) plot(t, data1, type="l", xlab="", ylab="") points(t[peaks1$loc], peaks1$pks, col = "red", pch = 1) plot(t, data2, type = "l", xlab = "", ylab = "") points(t[peaks2$loc], peaks2$pks, col = "red", pch = 1) points(t[peaks3$loc], peaks3$pks, col = "red", pch = 4) par (op) title("Finding the peaks of smooth data is not a big deal") t <- 2 * pi * seq(0, 1, length = 1024) y <- sin(3.14 * t) + 0.5 * cos(6.09 * t) + 0.1 * sin(10.11 * t + 1 / 6) + 0.1 * sin(15.3 * t + 1 / 3) data <- abs(y + 0.1*rnorm(length(y),1)) # Positive values + noise peaks1 <- findpeaks(data, MinPeakHeight=1) dt <- t[2]-t[1] peaks2 <- findpeaks(data, MinPeakHeight=1, MinPeakDistance=round(0.5/dt)) op <- par(mfrow=c(1,2)) plot(t, data, type="l", xlab="", ylab="") points (t[peaks1$loc],peaks1$pks,col="red", pch=1) plot(t, data, type="l", xlab="", ylab="") points (t[peaks2$loc],peaks2$pks,col="red", pch=1) par (op) title(paste("Noisy data may need tuning of the parameters.\n", "In the 2nd example, MinPeakDistance is used\n", "as a smoother of the peaks")) ``` # 3. Filter Design The `gsignal` package contains functions for designing lowpass, highpass, bandpass, and bandstop filters. Both Finite Impulse Response (FIR) and Infinite Impulse Response (IIR) filters can be designed. The `freqz` function displays the frequency response's magnitude and phase of the filter. ## FIR filters A FIR filter is a filter whose impulse response settles to zero in finite time. This is in contrast to IIR filters, which have internal feedback causing them to have an infinitely long impulse response (although usually decaying). For causal discrete-time FIR filters the output is a weighted sum of the most recent input values. Compared to IIR filters, advantages of FIR filters are they are inherently stable (because there is no feedback that propagates indefinitely), and that they have linear phase (constant across frequencies). The main disadvantage is that they require more computation time to obtain sharp transition bands. The package `gsignal` contains various methods to design digital FIR filters. The functions `fir1`, `fir2`, and `kaiserord` use the [windowing method](https://en.wikipedia.org/wiki/Finite_impulse_response#Window_design_method), in which a window is applied to the truncated inverse Fourier transform of the filter's frequency response. The function `firls` is an extension of the `fir1` and `fir2` functions that uses a least-squares approach to minimize errors between the specified and the actual frequency response over sub-bands of the frequency range. The [Parks-McClellan](https://en.wikipedia.org/wiki/Parks-McClellan_method) method using the [Remez exchange algorithm](https://en.wikipedia.org/wiki/Remez_algorithm) for finding an optimal equiripple set of filter coefficients is used by the `remez` function. The `cl2bp` function allows designing FIR filters without explicitly defining the transition bands for the magnitude response. Below are some examples of FIR filter design. The magnitude and the phase of the filter's frequency response are plotted by the function `freqz`. ```{r fir, fig.height=4, fig.width=7} ## FIR filter design by windowing # low-pass filter 10 Hz fs = 256 h <- fir1(40, 10/ (fs / 2), "low") freqz(h, fs = fs) # observe the effect of filter length h <- fir1(80, 10/ (fs / 2), "low") freqz(h, fs = fs) # fir2 allows specifying arbitrary frequency responses f <- c(0, 0.3, 0.3, 0.6, 0.6, 1) m <- c(0, 0, 1, 1/2, 0, 0) fh <- freqz(fir2(100, f, m)) op <- par(mfrow = c(1, 2)) plot(f, m, type = "b", ylab = "magnitude", xlab = "Frequency") lines(fh$w / pi, abs(fh$h), col = "blue") legend("topright", legend = c("specified", "actual"), lty = 1, pch = c(1, NA), col = c("black", "blue")) # plot in dB: plot(f, 20*log10(m+1e-5), type = "b", ylab = "dB", xlab = "Frequency") lines(fh$w / pi, 20*log10(abs(fh$h)), col = "blue") par(op) title("specify arbitrary frequency responses with fir2") ## 50 Hz notch filter with remez fs <- 200 nyquist <- fs / 2 f <- c(0, 48.5 / nyquist, 49.5 / nyquist, 50.5 / nyquist, 51.5 / nyquist, 1) a <- c(1, 1, 0, 0, 1, 1) h <- remez(200, f, a) freqz(h, fs = fs) ``` ### Compensating for filter delay in FIR filters Filtering causes a delay because weighted samples in the past are used. FIR filters have a linear phase, so in the time domain this delay is constant, namely $N / 2$, where $N$ is the filter length (or 'number of taps'). The function `grpdelay` can be used to calculate the [group delay](https://ccrma.stanford.edu/~jos/filters/Group_Delay.html); see Figure (a) below. Because phase is linear, it is easy to to compensate for the filter delay as shown in Figure (b) below. ```{r FIR_delay, fig.height=7, fig.width=7} op <- par(mfrow = c(2, 1)) # design the filter fs = 256 h <- fir1(40, 30/ (fs / 2), "low") # group delay is constant at N/2 gd <- grpdelay(h) plot(gd, ylim = c(0, 40), main = paste("(a) Group delay for FIR filters is constant\n", "(here 40 / 2 = 20)")) # filter electrocardiogram data with added noise data(signals, package = "gsignal") npts <- nrow(signals) ecg <- signals$ecg + 1000 * runif(npts) time <- seq(0, 10, length.out = npts) plot(time, ecg, type = "l", main = "(b) Example ECG signal", xlab = "Time", ylab = "", xlim = c(0,2)) title(ylab = expression(paste("Amplitude (", mu, "V)")), line = 2) f1 <- gsignal::filter(h, ecg) lines(time, f1, col = "red", lwd = 2) delay <- mean(gd$gd) f2 <- c(f1[(delay + 1):npts], rep(NA, delay)) lines(time, f2, col = "blue", lwd = 2) legend("topright", legend = c("Original", "Filtered", "Corrected"), lty = 1, lwd = c(1, 2, 2), col = c("black", "red", "blue")) par(op) ``` ## IIR filters Infinite Impulse Response, or recursive, filters are an efficient way of achieving a long impulse response by not only using past input samples, but also past output samples. Hence, an element of feedback (recursion) is used. IIR filters are specified by a set of *feedback* coefficients (usually termed $a$), in addition to *feedforward* coefficients ($b$) as used in FIR filters. Advantages of IIR filters compared to FIR filters are related to their efficiency in implementation. IIR filters usually require (much) fewer filter coefficients, implying a correspondingly fewer number of calculations. On the other hand, the impulse response of IIR filters does not always decay to zero, which may result in filter instability (see the example below). In addition, the phase of IIR filters is not linear but frequency dependent. Forward and reverse filtering (`filtfilt`) results in zero phase at the expense of additional computing time (there is no free lunch). Some important types of IIR filters are: 1. Butterworth filters have frequency response that is as flat as possible in the passband (function `butter`); 2. Chebyshev filters are IIR filters having a steeper roll-off than Butterworth filters, and either have a passband ripple (Type I - function `cheby1`), or a stopband ripple (Type II - function `cheby2`); 3. Elliptic filters with equalized ripple (equiripple) behavior in both the passband and the stopband (function `ellip`); 4. (Analog) Bessel filters with a maximally linear phase response. The following figure compare the frequency responses of (a) 5th order Butterworth and Chebyshev filters, (b) 5th order Butterworth and elliptic filters, and (c) type I and type II Chebyshev filters. ```{r iir, fig.height=7, fig.width=7} op <- par(mfrow = c(3,1)) # compare Butterworth and Chebyshev filters. bfr <- freqz(butter(5, 0.1)) cfr <- freqz(cheby1(5, .5, 0.1)) plot(bfr$w, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-80, 0), xlab = "Frequency (rad)", ylab = c("dB"), main = "(a) Butterworth and Chebyshev") lines(cfr$w, 20 * log10(abs(cfr$h)), col = "red") legend("topright", legend = c("5th order Butterworth", "5th order Chebyshev"), lty = 1, col = c("black", "red")) # compare Butterworth and elliptic filters. efr <- freqz(ellip(5, 3, 40, 0.1)) plot(bfr$w, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-80, 0), xlab = "Frequency (rad)", ylab = c("dB"), main = "(b) Butterworth and Elliptic") lines(efr$w, 20 * log10(abs(efr$h)), col = "red") legend ("topright", legend = c("5th order Butterworh", "5th order Elliptic"), lty = 1, col = c("black", "red")) # compare type I and type II Chebyshev filters. c1fr <- freqz(cheby1(5, .5, 0.1)) c2fr <- freqz(cheby2(5, 20, 0.1)) plot(c1fr$w, 20 * log10(abs(c1fr$h)), type = "l", ylim = c(-80, 0), xlab = "Frequency (rad)", ylab = c("dB"), main = "(c) Type I and II Chebyshev") lines(c2fr$w, 20 * log10(abs(c2fr$h)), col = "red") legend ("topright", legend = c("5th order Type I", "5th order Type II"), lty = 1, col = c("black", "red")) par(op) ``` ### Numerical precision and stability Using IIR filter coefficients $b, a$ can cause numerical problems. Therefore, IIR filter design functions in `gsignal` have an `output` parameter, allowing the filter coefficients to be returned in one of three forms: * Arma, a `list` containing the moving average polynomial (feedforward) coefficients $b$, and the autoregressive (recursive, feedback) coefficients $a$; * Zpg, a `list` containing the coefficients in zero-pole-gain form * Sos, a `list` of series second order sections ([biquads](https://en.wikipedia.org/wiki/Digital_biquad_filter)) Although the `Arma` form is default for compatibility reasons, the use of `Sos` and the accompanying filtering function `sosfilt` is generally preferred. A second issue that may occur when using IIR filters, is instability. This may be the result of numerical rounding errors or because too many filter coefficients were used. [Pole-Zero Analysis](https://ccrma.stanford.edu/~jos/filters/Pole_Zero_Analysis.html) can be useful here. A filter is stable if its impulse response $h(n)$ decays to 0 when $n$ increases. In terms of poles and zeros, this is true if all of the filter's poles are inside the unit circle in the $z$-plane ([Smith, J.O. (2012)](https://ccrma.stanford.edu/~jos/filters/Stability_Revisited.html)). The package `gsignal` offers the function `zplane` that displays a filter's poles and zeros in the complex $z$-plane, as the following figure illustrates. In the figure the '0's represent the zeros, and the 'X's the poles. ```{r zplane, fig.height=7, fig.width=7} op <- par(no.readonly = TRUE) n <- layout(matrix(c(1, 2, 3, 3), nrow = 2, byrow = TRUE)) stable <- butter(3, 0.2, "low", output = "Zpg") # artificially adapt pole instable <- stable instable$p[2] <- instable$p[2] - 2 zplane(stable, main = "Stable") zplane(instable, main = "Instable") t <- seq(0, 1, len = 100) x <- sin(2* pi * t * 2.3) + 0.5 * rnorm(length(t)) z1 <- filter(stable, x) z2 <- filter(instable, x) plot(t, x, type = "l", xlab = "", ylab = "") lines(t, z1, col = "green", lwd = 2) lines(t, z2, col = "red") legend("bottomleft", legend = c("Original", "Stable", "Instable"), lty = 1, col = c("black", "green", "red"), ncol = 3) par(op) ``` ### Compensating for filter delay in IIR filters Because the phase of the frequency response of IIR filters is not linear, the filter delay cannot be easily compensated for as in the FIR case. Recall that the 40-tap 30 Hz low-pass FIR filter used above for filtering the ECG signal had a linear phase and a constant delay of 20 samples. If a 5th order elliptic low-pass filter at 30 Hz is used, it can easily be seen that its phase is not linear (Figure (a) below), and hence the filter delay is dependent of frequency (Figure (b) below). Note that the group delay is defined to be the negative first derivative of the filter's phase response. ```{r IIR_delay, fig.height=7, fig.width=7} op <- par(mfrow = c(2, 1)) ell <- ellip(5, 0.1, 60, 30/(fs/2), "low") ellf <- freqz(ell, fs = fs) argh <- Arg(ellf$h) argh[which(is.na(argh))] <- 0 phase <- unwrap(argh) plot(ellf$w, phase, type = "l", xlab = "Frequency (Hz)", ylab = "Phase", main = paste("30 Hz 5th order elliptical low-pass IIR filter\n", "phase response is not linear")) gd <- grpdelay(ell, fs = fs) plot(gd, main = paste("group delay depends on frequency\n", "mean:", round(mean(gd$gd), 1), "samples")) par(op) ``` This means that the filter delay cannot be compensated for in the same way as for the FIR filter. An alternative is to use the function `filtfilt`, which applies forward and backward filtering and thus compensates for the delay, as shown in the figure below. ```{r IIR_filtfilt, fig.height=4, fig.width=7} f <- filter(ell, ecg) ff <- filtfilt(ell, ecg) plot(time, ecg, type = "l", xlab = "Time", ylab = "", xlim = c(0,2)) title(ylab = expression(paste("Amplitude (", mu, "V)")), line = 2) lines(time, f, col = "red", lwd = 2) lines(time, ff, col = "blue", lwd = 2) legend("topright", legend = c("Original", "filter()", "filtfilt()"), lty = 1, lwd = c(1, 2, 2), col = c("black", "red", "blue")) ``` # 4. Filtering and Convolution The most straightforward way to implement a digital filter is by [convolving](https://en.wikipedia.org/wiki/Convolution) the input signal with the filter's impulse response. The package `gsignal` contains several functions for convolution. The function `conv` returns the 1-D convolution of two vectors `a` and `b` in 3 'shapes'; "full", for which the output vector has a length equal to `length(a) + length(b) - 1`; "valid", which only returns the central part of the convolution with an output length of `length(a)`; or "valid", which returns only those parts of the convolution that are computed without the zero-padded edges (output length `max(length(a) - length(b) + 1, 0)`). For example: ```{r conv1} u <- rep(1, 3) v <- c(1, 1, 0, 0, 0, 1, 1) conv(u, v, "full") conv(u, v, "same") conv(u, v, "valid") conv(v, u, "valid") ``` Two-dimensional convolution of two matrices can be computed by the `conv2` function. In this case, the size of the output matrix is `nrow(A) + nrow(B) - 1` by `ncol(A) + ncol(B) - 1` for "full" convolution, `nrow(A)` by `ncol(A)` for "same", and `max(nrow(A) - nrow(B) + 1, 0)` by `max(ncol(A) - ncol(B) + 1, 0)` for "valid". The function `conv2` is implemented in C++ for speed. For long series convolution may be sped up by making use of the fact that convolution in the time domain is equivalent to multiplication in the frequency domain. Thus, the two series may be padded to the same length, converted to the frequency domain by FFT, multiplied point-wise, and transformed back to the time domain. The function `cconv` uses this approach. However, if one series is much longer than the other (as in typical filtering operations), zero-padding the shorter series to the length of the longer series may not be the most efficient method. In such cases, even faster methods like the overlap-add method used by the function `fftconv` may be useful. That's the theory at least... ```{r conv2, fig.height=7, fig.width=7} short <- runif(20L) long <- runif(1000L) # convolve two long series ll <- microbenchmark::microbenchmark(conv(long, long), cconv(long, long), fftconv(long, long)) plot1 <- ggplot2::autoplot(ll) # convolve a short and a long series sl <- microbenchmark::microbenchmark(conv(short, long), cconv(short, long), fftconv(short, long)) plot2 <- ggplot2::autoplot(sl) gridExtra::grid.arrange(plot1, plot2, nrow = 2, ncol = 1) ``` One-dimensional Filtering in `gsignal` is performed by the function `filter`. It is a direct form II transposed implementation in C++ of the standard linear time-invariant difference equation $$\sum_{k=0}^{N} a(k+1) y(n-k) + \sum_{k=0}^{M} b(k+1) x(n-k) = 0; 1 \le n \le length(x)$$ If a matrix is passed to `filter`, its columns are filtered. Two-dimensional filtering can be done using `filter2`. The function `fftfilt` uses the overlap-add method and FFT convolution for speed (but your mileage may vary), and `filtfilt` uses forward and backward filtering to avoid filter delay, as used above. If numerical stability of filter coefficients is an issue, filter design using series second order sections and filtering with the function `sosfilt` may be used. ## Filtering long series in chunks The functions `filter` and `sosfilt` can retain the filter state in order to process long data series in chunks. The following piece of code shows how this is done. A long series is split into two parts, which are processed sequentially. In the first call to filter, the final conditions `zf` are asked to be returned after filtering the first part, which are then passed to the second call to filter as the initial conditions `zi` for the second part of the series. The two filtered parts can then be concatenated for form the entire filtered series without discontinuities. ```{r chunks} N <- 10000L long <- runif(N) part1 <- long[1:(N / 2)] part2 <- long[((N / 2) + 1):N] b <- c(2, 3) a <- c(1, 0.2) y <- filter(b, a, long) y1 <- filter(b, a, part1, 'zf') y2 <- filter(b, a, part2, y1$zf) yy <- c(y1$y, y2$y) all.equal(y, yy) ``` ## Using initial conditions to avoid filter startup effects Initial conditions can also be used to set the initial state of the filter so that the output starts at the same value as the first element of the signal to be filtered. The initial conditions for the filter can be computed using the functions `filter_zi`, or `filtic`, as shown in the following example. ```{r zi, fig.height=5, fig.width=7 } t <- seq(-1, 1, length.out = 201) x <- (sin(2 * pi * 0.75 * t * (1 - t) + 2.1) + 0.1 * sin(2 * pi * 1.25 * t + 1) + 0.18 * cos(2 * pi * 3.85 * t)) h <- butter(3, 0.05) zi <- filter_zi(h) ## alternatively, use: ## lab <- max(length(h$b), length(h$a)) - 1 ## zi <- filtic(h, rep(1, lab), rep(1, lab)) z1 <- filter(h, x) z2 <- filter(h, x, zi * x[1]) plot(t, x, type = "l", xlab ="", ylab = "") lines(t, z1, col = "red") lines(t, z2$y, col = "green") legend("bottomright", legend = c("Original signal", "Filtered without initial conditions", "Filtered with initial conditions"), lty = 1, col = c("black", "red", "green")) ``` # 5. Power spectrum analysis The [power spectral density](https://en.wikipedia.org/wiki/Spectral_density) (PSD) of a time series describes the distribution of power (variance) into frequency components composing that signal. The [Fourier Transform](https://en.wikipedia.org/wiki/Fourier_transform) is a nonparametric method of decomposing a signal into its frequency spectrum. The functions `fft` and `ifft` compute the Discrete Fourier Transform with a fast algorithm, the FFT. A parametric alternative for autoregressive (AR) models is available through the functions `ar_psd`, `pburg`, or `pyulear`. The following figure shows how both FFT- and AR-based methods can discover the periodicities of 5 and 12 Hz in a noisy signal. ```{r fft_ar, fig.height=7, fig.width=7} op <- par(mfrow = c(3, 1)) fs <- 200 nsecs <- 10 lx <- fs * nsecs t <- seq(0, nsecs, length.out = lx) # signal of 5 Hz + 12 Hz + noise x <- (sin(2 * pi * 5 * t) + sin(2 * pi * 12 * t) + runif(lx)) plot(t, x, type = "l", xlab = "Time (s)", ylab = "", main = "Original signal") pw <- pwelch(x, window = lx, fs = fs, detrend = "none") plot(pw, xlim = c(0, 20), main = "PSD estimate using FFT") py <- pyulear(x, 30, fs = fs) plot(py, xlim = c(0, 20), main = "PSD estimate using Yule-Walker") par(op) ``` ## Welch's method [Welch (1967)](https://en.wikipedia.org/wiki/Welch%27s_method) proposed a method to estimate the power spectrum that reduces the variance of the spectrum (at the expense of decreasing frequency resolution - remember, there is no free lunch) by splitting the signal into (usually) overlapping segments and windowing each segment, for instance by a Hamming window. The periodogram is then computed for each segment, and the squared magnitude is computed, which is then averaged for all segments. The spectral density is the mean of the modified periodograms, scaled so that area under the spectrum is the same as the mean square of the data. In case of multivariate signals, cross-spectral density, phase, and coherence are also returned. The input data can be demeaned or detrended, overall or for each segment separately. The following figure shows two signals, a sine and a cosine of 5 Hz with noise added. Sines and cosines are the same waveforms, the only difference being that a cosine leads the sine wave by an amount of 90$^{\circ}$ ($\pi / 2$ radians). Hence, a plot of the PSD should show identical shapes for both signals, but a phase difference at $\pi / 2$ radians should be visible at 5 Hz, which should also produce a high magnitude squared coherence (near 1) at that frequency (coherence reflects constant phase differences). ```{r welch, fig.height=7, fig.width=7} op <- par(mfrow = c(3, 1)) fs <- 200 nsecs <- 100 lx <- fs * nsecs t <- seq(0, nsecs, length.out = lx) # sine and cosine of signal of 5 Hz noise x1 <- cos(2 * pi * 5 * t) + runif(lx) x2 <- sin(2 * pi * 5 * t) + runif(lx) x <- cbind(x1, x2) pw <- pwelch(x, fs = fs) plot(pw, plot.type = "spectrum", yscale = "dB", xlim = c(0, 50), main = "A sine and a cosine of 5 Hz have the same PSD") legend("topright", legend = c("Cosine", "Sine"), lty = 1:2, col = 1:2) rect(3, -35, 7, -4, border = "red", lwd = 3) plot(pw, plot.type = "phase", xlim = c(0, 50), main = expression(bold(paste("but differ ", pi/2, " radians in phase at 5 Hz")))) rect(3, -pi, 7, pi, border = "red", lwd = 3) plot(pw, plot.type = "coherence", xlim = c(0, 50), main = "leading to coherence ~ 1 at 5 Hz") rect(3, 0, 7, 1, border = "red", lwd = 3) par(op) ``` ## Time-frequency analysis If your signal's frequency content changes over time, the power spectrum is of limited use. You might then want to use some form of time-frequency analysis. Specialized R packages exist for wavelet analysis capable of doing time-frequency analysis, such as [wavelets](https://CRAN.R-project.org/package=wavelets), [Rwave](https://CRAN.R-project.org/package=Rwave), and [waveslim](https://CRAN.R-project.org/package=waveslim). `gsignal` does contain a basic function for computing the discrete wavelet transform (`dwt`), but is not otherwise specialized for wavelet analysis. Another way of decomposing a signal both in time and frequency is the [Short-Term Fourier Transform](https://en.wikipedia.org/wiki/Short-time_Fourier_transform), which can be calculated by the function `stft`. Here, the data to be transformed is broken up into (overlapping) chunks. Each chunk is then Fourier transformed, and added to a record of magnitude and phase for each point in time and frequency. Alternatively, the spectrogram (`specgram`) in essence does the same - the spectogram is the squared magnitude of the STFT of the signal. The following figure represents the spectrogram of a `chirp` signal, which is a signal in which the frequency changes with time. By default, the `specgram` and `stft` function produce grayscale plots, but here it is shown how other color palettes can be used. ```{r specgram, fig.height=7, fig.width=7} op <- par(mfrow = c(2, 1)) jet <- grDevices::colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) sp <- specgram(chirp(seq(0, 5, by = 1/8000), 200, 2, 500, "logarithmic"), fs = 8000) plot(sp, col = jet(20)) c2w <- grDevices::colorRampPalette(colors = c("red", "white", "blue")) plot(sp, col = c2w(50)) par(op) ``` # 6. Miscellaneous functions The package also contains many other functions that may be useful in various signal processing applications. * **Windowing functions**. [Window functions](https://en.wikipedia.org/wiki/Window_function) are usually bell-shaped functions (although rectangular and triangular shapes are also used), which are multiplied by the signal in order to taper the ends of the signal to zero to reduce spectral leakage. For instance, the `pwelch` function described above uses a window function (default Hamming) before FFT-ing the segments. The window functions available in `gsignal` are: + Modified Bartlett-Hann (`barthannwin`) + Bartlett (triangular - `bartlett`) + Blackman window (`blackman`) + Blackman-Harris (`blackmanharris`) + Blackman-Nuttall (`blackmannuttall`) + Bohman (`bohmanwin`) + Boxcar (rectangular - `boxcar`) + Chebyshev (`chebwin`) + Flat top (`flattopwin`) + Gaussian (`gausswin`) + Hamming (`hamming`), + Hanning (`hanning` - alias `hann`) + Kaiser (`kaiser`) + Nuttall (`nuttallwin`) + Parzen (`parzenwin`) + Rectangular (`rectwin`) + Triangular (`triang`) + Tukey (`tukeywin`) + Ultraspherical (`ultrwin`) + Welch (`welchwin`) * **Resampling functions**. Up- or downsampling signals by an integer factor can be done with `upsample` and `downsample`. The function `decimate` and `interp` also down- or upsample by an integer factor, but allows specifying an IIR or FIR filter to be applied before resampling to avoid aliasing. The more general function `resample` allows changing the sampling rate by arbitrary factors, and also takes an impulse response of a FIR filter as an optional argument (if not specified `resample` will design an optimal filter for you). The function `upfirdn` performs three operations; it first upsamples the input signal by inserting zeros, then applies a FIR filter, and finally downsamples the signal by throwing away samples. Because this function uses a polyphase implementation for filtering, it is often faster than when `filter` is used (the `resample` function uses `upfirdn` for exactly that reason). * **Other functions**. Various other functions not specifically addressed in this vignette are also included, which can be used for a variety of signal processing operations, such as padding data (`pad`, `prepad`, `postpad`), detrending data (`detrend`), unwrapping frequency response phase (`unwrap`), data transformations (`cceps`, `czt` `dct`, `dct2`, `dctmtx`, `dftmtx`, `dst`, `dwt`, `fftshift`, `fht`, `fwht`, `hilbert`, `idct`, `idct2`, `idst`, `ifht`, `ifwht`, `rceps`), polynomial analysis (`poly`, `polystab`, `residue`, `residued`, `residuez`, `polyreduce`, `mpoles`). Some helper functions (`cplxpair`, `cplxreal`, `db2pow`, `pow2db`, `fftshift`, `ifftshift`, `digitrevorder`), and other utilities are also included (e.g., `buffer`, `shiftdata`, `unshiftdata`, `peak2peak`, `peak2rms`, `rms`, `rssq`, `clustersegment`, `fracshift`, `marcumq`, `primitive`, `sampled2continuous`, `schtrig`, `upsamplefill`, `wkeep`, `zerocrossing`) gsignal/data/0000755000176200001440000000000014420222025012600 5ustar liggesusersgsignal/data/signals.rda0000644000176200001440000004724014420222025014737 0ustar liggesusers7zXZi"6!XNb])ThnRʠ3#MkdUܔH+C?#ܸSsA:랦ّ|2țhݡ32DA8yv`8g} uBv ׍JiwkStVf 9;_#/;QvUwnhZqhi]*.zb!/{]w ӈDʉ FēaE<0+›1QGGpMylw(ؼF=eI'Kx4J XuBķ/[d%.1'e fް\U?I) E)kWJ'&Q@4|`Z9wd%t:@UUξbg'֯$&y{ӯk\Zݑ KuJ;KyĜj@N`rƕ{PIq~&@|.Nh2v{ǀ;QJm'4\KH3bX7;'ȴߴğZkWa9q"IvXqm g)w!ŠiKTjp1I]=`biSTݸؗJ(6riRg8˄i"'.NH۬C޽s].X0Q\.Ulv6%ĈF\jQؔ@{t&I+v1\S(wK{A_iP \:#N 4&v e:f Ѭ5w%]{J~ zAZ+stΊ\NMcR٧}y&7Aw11ѫhfټ҂ef[Ԁ?TS׽tr{YyHF>̈́ h$ k$(hmXpL<\V\Vzm Ҥ *.G:ߧÐˬ'sY=nw1G9B}V,?uFhT* |jRa?gmyQPzɤ>IATBw2j+22K۪=`0'C{WM sxszcq/1iTMSjO֌{34AtQ'co4̕=Z1 τW쯙g8Νպp7}ЛP)5Zى3h΃;.Fչ͓ZM wX0|(}ww-~&tGQl(ie7{%+: ̓%&;'[3+WI_bFɥG$ZI]'jQi}Lt*c9׍>`x {0J{}wgWA3bH ZaH'{%^=W [gD!oՇ,[Zm69ԣu5!x!2^ ?#냄8  & ]4)Rϟw\3DƤ5/@w[Yŭ;dcT uRXZmun.}shT>rN=*ZH@K^V;czZb $7tϿBhkh,p_*$pcϣ΄rO-Z~:nX==Ph3LX+l[MTߍo#!o;iu'#ϋFKlfy;hXW:.o(F$%wVFW[< H4i }Z,XlY?H߳=j5(f=9yZyiS#db9LMaEITxJa'K~iOLSѲɪ+0B,)kM{OE45{pwc-sW$bv/d$}uN]qDW8?:v!z8C77-햏'qlx T(;[7Cbҋ/X_C}):WC!r6x^p퍳 x1s?rk U>y `꺴^]$hPߤW$bzEeUh8@ PǢ'qliN~D_Z723PAl7KSfѸiyfcwn'$᱃8OS rP^SRX%! ăEQZ#d-2TbG*rӫ5굮w6^"XZ, zj*`Aݾew@bVC`Ť]Ny9Y7/N j!ks# wpbؒnZM:h W4om_桰=_Kf"& cYZ 2|kZG4Ļ*I D5t"&12YX~-w4Mh'9qA@ϳgWУ+TL]n@ӭ7SlRW7[P\ZW< XolL_ߋzKsv`Fx)l$kTڧt1dw߽S@*=iƏANj ?$R'}efDayq" mdܯ+(_w\|Da*ʡ@'QVrDͿ*!M).v5_sgEɠSh> nƓRd|=3F y%S^h gϺƫ= ^ѻ!~9qŸ?Ⱥ. L,,'[zjA$s`yЬ1.f2|Obe""g {17wqM{*asEnu/&˲c4":Xj'!Ӱd/&4h~OuP:ؠBV]ЧZ;o *S }b&7ў2;v P07 A@p*͈D)mzL&F+`n9aAzXh$vQQ"8m $B Bm4n\n;|sA6#S*6TG;%@|t: ^@Ex )?Rl]ૼ,,p"}t/V)a;chKJv-$cȒ&x囔!x uY`kuWO pcͺ2&["2;8vFHSf55[2uf7? yʲ H)A|<m{zl\DZ$#D9 PBi溍 x&sdU9kh6oQ WG >9m&._%AmK7_~ĕiԭZVNU$Mۧ^*Lc:!3HmSt"r$**:^Rb%hcdWǽW%$O ;-&s 4p*ѦP V,l tD4u&(Z/?5("McMg 乱4RsUS+;j0U+~HYCԈ>vv>no2|p{FۆF?Λ&MNÈ-z&VM^ͮ5 /x:|ʱ驲sl-;Q$T8 so6MiS'E۳ (>8i%=T}4٨-l's;rxO&!F5":շF^(n0XF_ilBneҟd v]K_֡M>Y˓]qFVs!sUE%)` )bMM䗇cO{LUv2]L~$%̙^J Z*uNI5y!wf+L)5{o͇%r/!xre,,/*W}Jxt(]8έ˦|S検&[FU8z؅&wl_/Twi˶~5+ =%(/@S0=^k(لN Hd U -Ͷ:v2n0Z%s`˻ 8pn,rFtmXMf=69-L&bIaam.K3! Yi(¼hF8!R_2hI.C]+躨@jV|t l a{%S}R6hɡSxJ}f+`r`*v: P8C5˽o4TcwnʠƟG'Y9 bUEL"K٭PY>߹S}a/XM d'^~?@P IC:[]֦C#%M\[:@׻7ҸK?5<8\UibZޜrHiZBJJdx3Q@VgKqVq3ӮNO1܏pH"!/ #//x|}jk梟Z:7uM<~f}Lb"̷xox:V߱tl- РsC:oW$GoOzrljU28[ xe(sx/BC037 ^^3B <+vo: Ҭ9C5m҉1п#m҈8Y=P/tTsX4Iz寻"8fr8H-*IV=k &:/PdS92![ %qLр.gYns/]IleDcۂ* `~ה(0՟qH9i")f?@[P&ct_ \rN|mRN'/gv;@Qi${ʳon&2 a!hT dK7HxZ>) g;wQ2\p.usr>*2pDxM,ȿ[(53(IWbx}L](c2֯!cBys5-UC9J4*8k:ȿҊLeУYo_NԦs iВ~. |&_jL!CwqUkwBգX683Ǵkݿ 3!2]E(8WTY~Ujg_'g\Q@c{,bHbFkNM!ӈs7'D Z|8\b .2z~%x :`Y5:.Rp{o5kН} qdM?8,de~RĊ6n@WfhIp Ñ隵&xKC-oH]Q[Id4\uD0 ĔB,TmJ]lKiHɥ/-,87i^2OPt(7[6m&Pu-`#l>BnjٯVYF{aγqT<͇`_­Jҟ6=Nw.J$r3$ 0 :1CJLh|*{}L~RwH[d\W;Jt_/덦Οr gF 3Q'\6nh$_OɋLT1+KLM$FID2=qW9?@n\Peb>VFV:N ir}WMf|}2bR+o [;M)VY.j NM̰`b Nw{Sy= AkZu[.1왽hهxhK"+c2񧪈$?rn~hK܃~LyXS`B y8Q@ػ;nS; :-#4q0aoDTjS;n5n̋0Zn'yWW ن'80LFuIRh2 BsH7o<4]=Yz#"qZ!K~ksCCy3T<8ИR>1L6x7i.Y1/+uUSKbN[&@m{H 3uR'_v$M':q ľMoDMlj+)M\v;p2%=n,~lp"9 uڀ2ĐP eR!d1\%n7A9)PBFTq&뿆1@*5:P~)"!scX|9dQѿVqog0Zt%CY<HDXc.-c\>m,Ĺ? qSLD?|JzlC' ^qWÛF| nE +1r~0;_bCnۦJȥ6HqIs}6O6)Ym6KkV?#y ɋohJ: {Ir&i`[T٥-r@g|gb[9v^:Z7EX,"'D9o(Kg3? z܇@Y3]PwI0O"鮼5k84ԋ`] DS*-$DJvȈ,֡uP -5PCHi$Z}Jl0=C0!n?ULCdI: #q'8~?ըiϫQ9(֗4~ p3ssUѓ$i.^=qF@x|9& N4,M|9 7w噯*R@_mґb5'2oQPC>M's_z99tM@O,;{4sP`(r Q*'3[$Td@fUWi;fҖw팻CPnVTа'Fqx@+tHYPQ4|:hEc3$OOfCo^9HzvQc55L>e@pk9$}(]O ) t]6xh4lppL{lB zb,f32Dy7{=OCX-ݱߞ{Yo̦J9 m.Xs]b6 PV2$>Yx[E{npQvە;WkMTv%y{.3O%rtK컺}ƈ$-@;x7ge`e<%)5||P]*K#myH6 cl>%.$Q->[pumJ"~U" >TeѮځEOpD. Q@s˄$ਝ7 EES h9a8ćT(T@ tb +_,j`}dFpM]fR !CؽYe'w>:ERj+NzHu(N[0r9 XRqzMYsÖ:jUi#2qq=BB *oR쪨/<[8gqk>o;\󴓭cutEcv mlorO3&s->I(6J_O&j C$}3Xd {}O)²0^)1 Y]H1ki3ʸ֞fLi d57H?.@Ty=`WT-]FZZ!VG!_Aehf{8$J{atֹ{2D̋`g6/:CS &+k߅v DYs,Kwv:fn쌼XkTBTm~,nr֟K.BRcvD6hf82㜜lјT#ԋ9J_pg0\ I"TP: vkdN, ?ٶ ɓCiTHR P,7Nc7ZNU~ ^ܿPMkA,u;;%8ril'K)vԊn!\OFQO#cL MɾƓ 0}Nu<˰BbF)!ـ} )f9GYsE`,۟ݱ\M+nWP,_oKc%bT '+4#E/UhœtC"qD hj8+*[. d,i1u?TMb H,՗ "S^7(xT0G6ư&兂u42Q$q݉Ds3 `0(OEv`jh(гhEt9gX2'*n,!\ lG`;ۛEp+߉y*QC.:Jʛb((oirjjsG>FYS1Ww1db Wx.}a6 j<8bNn073ۉ,Gv_^=,n7'U]H=kwEHKFРQ1ɹϧz y6^:ѓece~^zp;hhe\.WfFH5pnnp:\dȸ%OOU'"/ e~| /WిEwa4#OJǞ<#4;)td&wcth]KMTQ"+\\.jTjxZ-"5/eI*%oO |422C,Ġ31/ԆQc٠5ƌٻNm_,ZX.t#`2ƒy\ <#dZ|22zXcs1 Hf"F4ܝ{ؔLxGv{]H4c`,tZ"2KZҍ < 4vx o2gD\-c׼,c$#E-.BaA4";Hl~`5'/z1w_w;*C 3\GZ=/]@ f\P}3UEэ,̧X_lF<-<^cXfbi;i+TP)c(KZٻJ{sVT;#m&>u1xyUDɍ`h#LNaG1ӏkUAӑ:j[A=qRh-ϧLB F7⎢geb GGW1ihqQT_WSB 4XU[ <! @k*L$,I鉓" t, >rK+o[ab nG [ߣznHr< ݓu\4; qXrqg_̛U)fo/ ~ GzWZū Pz*Ba'&-/!3$(_ M/3MaCƩFI˷{r8ZŠڒrc}k@]R9uhh;P䈪$GPOE !| 1)q> K*WT\hqSZfO1z*+rs*"(EW٨#D|(Prya k|<"RvRݸVto>׷9f2i; Hyy:b5-ҟ{~w5 McFs';FE&=9}) 䆏V\*F~8?!qX@vclT$,Yy,{_eߘgyYzP!߲#^hl=XP0nK$οjv R--bqklB7~h&MӼgh-vǃ%U#,53 !j3x"RB Qq2|Խc V%&]YxRb36.v.'6w(dծJ'3 5!%nIҲKtՄ<8X_w#ZUF^BJ.#GZ:?4`Z.gލ%I +C !/IwK<.@axI0>`.IoGdf%4ip+;lg7E̗z";4UC$ϟ.mz8΢?@ 8W |IjejSljx['q-䔻0[Bs6'lDO>g''M21cFE8AEr:hhzz5\^trR kݣԫQDPn+T 1teNBxcl}<] 9* 6eQ^zMY~䍄:=7dnW4Gcw}J(̺c&YѢdOB~ᑜgJBd,rCN>t8q4AHޔj`KВ[g Kf(,${ǜ$ ^LXB+3zL;կIӵ 54RH23kwucKN{(-J?((1g޿hkMCNVEd+w۩4c]}"r>ng,e{y29к?rȁu*bf+l.y=;Cww =;LDa% wUS$"| {9vWrʦ(i̞ZZ M_ )\Z˛5q>.۱4&l܎j-xIśv@sM^i0*֠6 8HW딧 0TsKYMCpA HK,=H tRQI'^/\FĪbRSUغVqBrуse.b]:PAٽ&9OjZF.t19jzǕuM_\Wca9~ \QCq$p=f%\XhfZaxH& auą[l\EL8s_X"@DT"dmҼ')M%Sn)m\x|ۡ׃L;rU$M~qdr0 mo,=FlFSzEF[ɮ%4/3=r8c u2_vN]<ڸ[N;ea #>o\Y)2<;:w) CҪjrƏ  7UZx2Ǝ#|%cL \ZCbׯ]6$29P"D/k?N:7~V'O2:+ V^<1K壸 8u {q?:آ,]LYkV<#N7'h^k_~ istAR.jw&C9{\"!~OR.3nKӴ}Y3כJ݉*1W"e^1LD6?aRCc*c&^9=Baӯ!I}{~UpzȎ;V!-11z  /ЅR0ɢ6pѝ Gƙ jT B!7]/b.`gRHzM# (vkF9z| Qӝt q̃B`vpLu3Fr=c 5! 6{)~Em=ݬV=jHP!3|ɀժ5i8}66BįsrK%M^GWЫ: kz^"3[uPufewtW{=ܶ]."SfhxJҵ.G<2scsA#2^zd<WDKscuWƤ;zկ͋h!4}0ll8]h=3_z?1B[y8~s`p8~-v$2mCzGJ%Hl>kͽM9婸͘b(cOE:?,V"P(#v ΎyɮHKsQ0|CZ՟A$<@PJ/_yj4!{žyӍ:[1CU'Bp>dhX`yto&d&C]KsE(q@ OH&޸t9<γp7OUWs}K P.1[oplƄڃoPU?*v/9nc? tEo0(Eh$9S΢T3Ո?o)-)*4oߩ{VyX@mΣ,FV2[ ;,X];Dt{uH Yեb+9 ش Ve\ꝋx]M/t>7d^ ߀~\!MԓZߌk~(,9 ϟdݒXhUCfZabE/ AH{['tM\ה-OzFrL25Qv*xx@{ɋ2.)% ~fR$dMiiݜͻ"\m.!&N VAKT%r5D.Kղ,/䋵/h4:|E=ט .rE("p 5RTe>l 9 ߁mkx\g X6`c4['UMC_4I"7AA#kmQSf>y˛dlA%[ud,jHF ^}w W!`} )!'} ,G#j CݜC04ǚB.y 8’:nd1J u,2Xɶ!s؝n障sHK>=jbI~pu]X-z-HqԚ yO :eAo,K[Σk _u 94!m?՚M"<1;eh~NHgy0ՏS%7`qGrWbOĊ1@TB!cFi:BOunA\sSg|@ɍ~Y.+ݍi6+69> ޏά8cL| 1 q;մݪjg3HM5'xTU4Ix# ګBE8lG)}xk=t77`6&5ub%H>ȏܗLonb$[Ȯ#5E_rA.N/"i+l΅6C2+SB|Ⴗ,K$ LDAFXXXm͕xij|` nXwŌi%YWm3@Lt&ɞ+gnZ QmGR|MD4Ai_4IH4à17%bFcʑsfH̀R)+G;j3ǀꕾя܍,҉XZ㑯lф!)-TIF]\zT;K\ $p~5zX76“ тB`?hw/B^0__.B%Wu%[b7#G6jxͅu7k@ ;e`>0 YZgsignal/src/0000755000176200001440000000000014670306232012470 5ustar liggesusersgsignal/src/RcppExports.cpp0000644000176200001440000001264514663046352015503 0ustar liggesusers// Generated by using Rcpp::compileAttributes() -> do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #include using namespace Rcpp; #ifdef RCPP_USE_GLOBAL_ROSTREAM Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif // conv2df NumericMatrix conv2df(NumericMatrix a, NumericMatrix b); RcppExport SEXP _gsignal_conv2df(SEXP aSEXP, SEXP bSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type a(aSEXP); Rcpp::traits::input_parameter< NumericMatrix >::type b(bSEXP); rcpp_result_gen = Rcpp::wrap(conv2df(a, b)); return rcpp_result_gen; END_RCPP } // conv2ds NumericMatrix conv2ds(NumericMatrix a, NumericMatrix b); RcppExport SEXP _gsignal_conv2ds(SEXP aSEXP, SEXP bSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type a(aSEXP); Rcpp::traits::input_parameter< NumericMatrix >::type b(bSEXP); rcpp_result_gen = Rcpp::wrap(conv2ds(a, b)); return rcpp_result_gen; END_RCPP } // conv2dv NumericMatrix conv2dv(NumericMatrix a, NumericMatrix b); RcppExport SEXP _gsignal_conv2dv(SEXP aSEXP, SEXP bSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type a(aSEXP); Rcpp::traits::input_parameter< NumericMatrix >::type b(bSEXP); rcpp_result_gen = Rcpp::wrap(conv2dv(a, b)); return rcpp_result_gen; END_RCPP } // rfilter List rfilter(NumericVector b, NumericVector a, NumericVector x, NumericVector zi); RcppExport SEXP _gsignal_rfilter(SEXP bSEXP, SEXP aSEXP, SEXP xSEXP, SEXP ziSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type b(bSEXP); Rcpp::traits::input_parameter< NumericVector >::type a(aSEXP); Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericVector >::type zi(ziSEXP); rcpp_result_gen = Rcpp::wrap(rfilter(b, a, x, zi)); return rcpp_result_gen; END_RCPP } // fwht NumericMatrix fwht(NumericMatrix x); RcppExport SEXP _gsignal_fwht(SEXP xSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type x(xSEXP); rcpp_result_gen = Rcpp::wrap(fwht(x)); return rcpp_result_gen; END_RCPP } // remez NumericVector remez(NumericVector h, int numtaps, int numband, const NumericVector bands, const NumericVector des, const NumericVector weight, int type, int griddensity); RcppExport SEXP _gsignal_remez(SEXP hSEXP, SEXP numtapsSEXP, SEXP numbandSEXP, SEXP bandsSEXP, SEXP desSEXP, SEXP weightSEXP, SEXP typeSEXP, SEXP griddensitySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type h(hSEXP); Rcpp::traits::input_parameter< int >::type numtaps(numtapsSEXP); Rcpp::traits::input_parameter< int >::type numband(numbandSEXP); Rcpp::traits::input_parameter< const NumericVector >::type bands(bandsSEXP); Rcpp::traits::input_parameter< const NumericVector >::type des(desSEXP); Rcpp::traits::input_parameter< const NumericVector >::type weight(weightSEXP); Rcpp::traits::input_parameter< int >::type type(typeSEXP); Rcpp::traits::input_parameter< int >::type griddensity(griddensitySEXP); rcpp_result_gen = Rcpp::wrap(remez(h, numtaps, numband, bands, des, weight, type, griddensity)); return rcpp_result_gen; END_RCPP } // rsosfilt List rsosfilt(NumericMatrix sos, NumericVector x, NumericMatrix zi); RcppExport SEXP _gsignal_rsosfilt(SEXP sosSEXP, SEXP xSEXP, SEXP ziSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type sos(sosSEXP); Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericMatrix >::type zi(ziSEXP); rcpp_result_gen = Rcpp::wrap(rsosfilt(sos, x, zi)); return rcpp_result_gen; END_RCPP } // upfirdn NumericMatrix upfirdn(NumericMatrix x, NumericMatrix h, int p, int q); RcppExport SEXP _gsignal_upfirdn(SEXP xSEXP, SEXP hSEXP, SEXP pSEXP, SEXP qSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type x(xSEXP); Rcpp::traits::input_parameter< NumericMatrix >::type h(hSEXP); Rcpp::traits::input_parameter< int >::type p(pSEXP); Rcpp::traits::input_parameter< int >::type q(qSEXP); rcpp_result_gen = Rcpp::wrap(upfirdn(x, h, p, q)); return rcpp_result_gen; END_RCPP } static const R_CallMethodDef CallEntries[] = { {"_gsignal_conv2df", (DL_FUNC) &_gsignal_conv2df, 2}, {"_gsignal_conv2ds", (DL_FUNC) &_gsignal_conv2ds, 2}, {"_gsignal_conv2dv", (DL_FUNC) &_gsignal_conv2dv, 2}, {"_gsignal_rfilter", (DL_FUNC) &_gsignal_rfilter, 4}, {"_gsignal_fwht", (DL_FUNC) &_gsignal_fwht, 1}, {"_gsignal_remez", (DL_FUNC) &_gsignal_remez, 8}, {"_gsignal_rsosfilt", (DL_FUNC) &_gsignal_rsosfilt, 3}, {"_gsignal_upfirdn", (DL_FUNC) &_gsignal_upfirdn, 4}, {NULL, NULL, 0} }; RcppExport void R_init_gsignal(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } gsignal/src/upfirdn.cpp0000644000176200001440000000357514420222025014643 0ustar liggesusers// upfirdn.cpp // Copyright (C) 2020 Geert van Boxtel // Original Octave code: // Copyright (C) 2008 Eric Chassande-Mottin, CNRS (France) // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License // as published by the Free Software Foundation; either version 3 // of the License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // You should have received a copy of the GNU General Public License // along with this program. If not, see . // // Version history // 20200929 GvB setup for gsignal v0.1.0 //--------------------------------------------------------------------------------------------------------------------- #include using namespace Rcpp; // [[Rcpp::export]] NumericMatrix upfirdn (NumericMatrix x, NumericMatrix h, int p, int q) { int rx = x.nrow(); int cx = x.ncol(); // assume h has same number of columns as x (check in R code) int Lh = h.nrow(); double r = p/(double(q)); int Ly = ceil (double((rx-1)*p + Lh) / double(q)); NumericMatrix y(Ly, cx); for (int c = 0; c < cx; c++) { int m = 0; while (m < Ly) { int n = floor (m/r); int lm = (m * q) % p; int k = 0; double accum = 0.0; do { int ix = n - k; if (ix >= rx) { k ++; continue; } int ih = k * p + lm; if ((ih >= Lh) | (ix < 0)) break; accum += h(ih, c) * x (ix, c); k++; } while (1); y (m, c) = accum; m ++; } } return y; } gsignal/src/fwht.cpp0000644000176200001440000000307314420222025014135 0ustar liggesusers// fwht.cpp // Copyright (C) 2020 Geert van Boxtel // Original Octave code: // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License // as published by the Free Software Foundation; either version 3 // of the License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // You should have received a copy of the GNU General Public License // along with this program. If not, see . // // Version history // 20201025 GvB setup for gsignal v0.1.0 //--------------------------------------------------------------------------------------------------------------------- #include using namespace Rcpp; // Based on pseudocode at // https://en.wikipedia.org/wiki/Fast_Walsh%E2%80%93Hadamard_transform // [[Rcpp::export]] NumericMatrix fwht (NumericMatrix x) { int ncols = x.ncol(); int n = x.nrow(); NumericMatrix data = clone(x); for (int icol = 0; icol < ncols; icol++) { int h = 1; while (h < n) { for (int i = 0; i < n; i += h * 2) { for (int j = i; j < i + h; j++) { double xx = data(j, icol); double yy = data(j + h, icol); data(j, icol) = xx + yy; data(j + h, icol) = xx - yy; } } h *= 2; } } return (data); } gsignal/src/conv2d.cpp0000644000176200001440000000562514420222025014365 0ustar liggesusers// conv2.R // Copyright (C) 2020 Geert van Boxtel // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License // as published by the Free Software Foundation; either version 3 // of the License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // You should have received a copy of the GNU General Public License // along with this program. If not, see . // // Version history // 20200227 GvB setup for gsignal v0.1.0 //--------------------------------------------------------------------------------------------------------------------- #include using namespace Rcpp; // [[Rcpp::export]] NumericMatrix conv2df(NumericMatrix a, NumericMatrix b) { int aRows = a.nrow(); int aCols = a.ncol(); int bRows = b.nrow(); int bCols = b.ncol(); int yRows = aRows + bRows - 1; int yCols = aCols + bCols - 1; NumericMatrix y(yRows, yCols); for(int i=0; i < (yRows + bRows - 1); i++) { for(int j=0; j < (yCols + bCols - 1); j++) { for(int m=0; m < bRows; m++) { int im = i-m; for(int n=0; n < bCols; n++) { int jn = j-n; if (im >= 0 && jn >= 0 && im < aRows && jn < aCols) { y(i, j) += a(im, jn) * b(m, n); } } } } } return y; } // [[Rcpp::export]] NumericMatrix conv2ds(NumericMatrix a, NumericMatrix b) { int aRows = a.nrow(); int aCols = a.ncol(); int bRows = b.nrow(); int bCols = b.ncol(); int yRows = aRows; int yCols = aCols; NumericMatrix y(yRows, yCols); int bCX = bCols / 2; int bCY = bRows / 2; for(int i=0; i < yRows; i++) { for(int j=0; j < yCols; j++) { for(int m=0; m < bRows; m++) { int mm = bRows - 1 - m; for(int n=0; n < bCols; n++) { int nn = bCols - 1 - n; int ii = i + (bCY - mm); int jj = j + (bCX - nn); if( ii >= 0 && ii < yRows && jj >= 0 && jj < yCols ) y(i, j) += a(ii, jj) * b(mm, nn); } } } } return y; } // [[Rcpp::export]] NumericMatrix conv2dv(NumericMatrix a, NumericMatrix b) { int aRows = a.nrow(); int aCols = a.ncol(); int bRows = b.nrow(); int bCols = b.ncol(); int yRows = aRows - bRows + 1; int yCols = aCols - bCols + 1; NumericMatrix y(yRows, yCols); for(int i=0; i < yRows; i++) { for(int j=0; j < yCols; j++) { for(int m=0; m < bRows; m++) { int im = i+m; for(int n=0; n < bCols; n++) { int jn = j+n; int br = bRows - m - 1; int bc = bCols - n - 1; y(i, j) += a(im, jn) * b(br, bc); } } } } return y; } gsignal/src/remez.cpp0000644000176200001440000004657214420222025014322 0ustar liggesusers// remez.cpp // Copyright (C) 2020 Geert van Boxtel // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License // as published by the Free Software Foundation; either version 3 // of the License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // You should have received a copy of the GNU General Public License // along with this program. If not, see . // // Version history // 20200803 GvB setup for gsignal v0.1.0 //--------------------------------------------------------------------------------------------------------------------- #include using namespace Rcpp; /* Copyright (C) 1995, 1998 Jake Janovetz Copyright (C) 1999 Paul Kienzle Copyright (C) 2000 Kai Habel This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; see the file COPYING. If not, see . */ /************************************************************************** * There appear to be some problems with the routine Search. See comments * therein [search for PAK:]. I haven't looked closely at the rest * of the code---it may also have some problems. *************************************************************************/ #define CONST const #define BANDPASS 1 #define DIFFERENTIATOR 2 #define HILBERT 3 #define NEGATIVE 0 #define POSITIVE 1 #define Pi 3.1415926535897932 #define Pi2 6.2831853071795865 #define GRIDDENSITY 16 #define MAXITERATIONS 40 /******************* * CreateDenseGrid *================= * Creates the dense grid of frequencies from the specified bands. * Also creates the Desired Frequency Response function (D[]) and * the Weight function (W[]) on that dense grid * * * INPUT: * ------ * int r - 1/2 the number of filter coefficients * int numtaps - Number of taps in the resulting filter * int numband - Number of bands in user specification * double bands[] - User-specified band edges [2*numband] * double des[] - Desired response per band [2*numband] * double weight[] - Weight per band [numband] * int symmetry - Symmetry of filter - used for grid check * int griddensity * * OUTPUT: * ------- * int gridsize - Number of elements in the dense frequency grid * double Grid[] - Frequencies (0 to 0.5) on the dense grid [gridsize] * double D[] - Desired response on the dense grid [gridsize] * double W[] - Weight function on the dense grid [gridsize] *******************/ void CreateDenseGrid(int r, int numtaps, int numband, const NumericVector bands, const NumericVector des, const NumericVector weight, int& gridsize, NumericVector& Grid, NumericVector& D, NumericVector& W, int symmetry, int griddensity) { int i, j, k, band; double delf, lowf, highf, grid0; delf = 0.5/(griddensity*r); /* * For differentiator, hilbert, * symmetry is odd and Grid[0] = max(delf, bands[0]) */ grid0 = (symmetry == NEGATIVE) && (delf > bands[0]) ? delf : bands[0]; j=0; for (band=0; band < numband; band++) { lowf = (band==0 ? grid0 : bands[2*band]); highf = bands[2*band + 1]; k = (int)((highf - lowf)/delf + 0.5); /* .5 for rounding */ if (band == 0 && symmetry == NEGATIVE) k--; for (i=0; i (0.5 - delf)) && (numtaps % 2)) { Grid[gridsize-1] = 0.5-delf; } } /******************** * InitialGuess *============== * Places Extremal Frequencies evenly throughout the dense grid. * * * INPUT: * ------ * int r - 1/2 the number of filter coefficients * int gridsize - Number of elements in the dense frequency grid * * OUTPUT: * ------- * int Ext[] - Extremal indexes to dense frequency grid [r+1] ********************/ void InitialGuess(int r, NumericVector& Ext, int gridsize) { int i; for (i=0; i<=r; i++) Ext[i] = i * (gridsize-1) / r; } /*********************** * CalcParms *=========== * * * INPUT: * ------ * int r - 1/2 the number of filter coefficients * int Ext[] - Extremal indexes to dense frequency grid [r+1] * double Grid[] - Frequencies (0 to 0.5) on the dense grid [gridsize] * double D[] - Desired response on the dense grid [gridsize] * double W[] - Weight function on the dense grid [gridsize] * * OUTPUT: * ------- * double ad[] - 'b' in Oppenheim & Schafer [r+1] * double x[] - [r+1] * double y[] - 'C' in Oppenheim & Schafer [r+1] ***********************/ void CalcParms(int r, NumericVector Ext, NumericVector Grid, NumericVector D, NumericVector W, NumericVector& ad, NumericVector& x, NumericVector& y) { int i, j, k, ld; double sign, xi, delta, denom, numer; /* * Find x[] */ for (i=0; i<=r; i++) x[i] = cos(Pi2 * Grid[Ext[i]]); /* * Calculate ad[] - Oppenheim & Schafer eq 7.132 */ ld = (r-1)/15 + 1; /* Skips around to avoid round errors */ for (i=0; i<=r; i++) { denom = 1.0; xi = x[i]; for (j=0; j0.0) && (E[0]>E[1])) || ((E[0]<0.0) && (E[0]=E[i-1]) && (E[i]>E[i+1]) && (E[i]>0.0)) || ((E[i]<=E[i-1]) && (E[i]= 2*r) return -3; foundExt[k++] = i; } } /* * Check for extremum at 0.5 */ j = gridsize-1; if (((E[j]>0.0) && (E[j]>E[j-1])) || ((E[j]<0.0) && (E[j]= 2*r) return -3; foundExt[k++] = j; } // PAK: we sometimes get not enough extremal frequencies if (k < r+1) return -2; /* * Remove extra extremals */ extra = k - (r+1); assert(extra >= 0); while (extra > 0) { if (E[foundExt[0]] > 0.0) up = 1; /* first one is a maxima */ else up = 0; /* first one is a minima */ l=0; alt = 1; for (j=1; j 0.0)) up = 1; /* switch to a maxima */ else { alt = 0; // PAK: break now and you will delete the smallest overall // extremal. If you want to delete the smallest of the // pair of non-alternating extremals, then you must do: // // if (fabs(E[foundExt[j]]) < fabs(E[foundExt[j-1]])) l=j; // else l=j-1; break; /* Ooops, found two non-alternating */ } /* extrema. Delete smallest of them */ } /* if the loop finishes, all extrema are alternating */ /* * If there's only one extremal and all are alternating, * delete the smallest of the first/last extremals. */ if ((alt) && (extra == 1)) { if (fabs(E[foundExt[k-1]]) < fabs(E[foundExt[0]])) /* Delete last extremal */ l = k-1; // PAK: changed from l = foundExt[k-1]; else /* Delete first extremal */ l = 0; // PAK: changed from l = foundExt[0]; } for (j=l; j max) max = current; } return (((max-min)/max) < 0.0001); } /******************** * remez *======= * Calculates the optimal (in the Chebyshev/minimax sense) * FIR filter impulse response given a set of band edges, * the desired response on those bands, and the weight given to * the error in those bands. * * INPUT: * ------ * int numtaps - Number of filter coefficients * int numband - Number of bands in filter specification * double bands[] - User-specified band edges [2 * numband] * double des[] - User-specified band responses [numband] * double weight[] - User-specified error weights [numband] * int type - Type of filter * * OUTPUT: * ------- * double h[] - Impulse response of final filter [numtaps] * returns - true on success, false on failure to converge ********************/ // [[Rcpp::export]] NumericVector remez(NumericVector h, int numtaps, int numband, const NumericVector bands, const NumericVector des, const NumericVector weight, int type, int griddensity) { int i, iter, gridsize, r, symmetry; double c; if (type == BANDPASS) symmetry = POSITIVE; else symmetry = NEGATIVE; r = numtaps/2; /* number of extrema */ if ((numtaps%2) && (symmetry == POSITIVE)) r++; /* * Predict dense grid size in advance for memory allocation * .5 is so we round up, not truncate */ gridsize = 0; for (i=0; i 0.0001) W[i] = W[i]/Grid[i]; } } /* * For odd or Negative symmetry filters, alter the * D[] and W[] according to Parks McClellan */ if (symmetry == POSITIVE) { if (numtaps % 2 == 0) { for (i=0; i // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License // as published by the Free Software Foundation; either version 3 // of the License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // You should have received a copy of the GNU General Public License // along with this program. If not, see . // // Version history // 20200413 GvB setup for gsignal v0.1.0 // 20210328 GvB v0.3.0; used Python setup to handle initial conditions //--------------------------------------------------------------------------------------------------------------------- #include using namespace Rcpp; // [[Rcpp::export]] List rsosfilt (NumericMatrix sos, NumericVector x, NumericMatrix zi) { // Invalid values should be caught by calling function, but just to be safe int nSections = sos.nrow(); int nSosCol = sos.ncol(); if (nSosCol != 6) { return R_NilValue; } int nSamp = x.size(); if (nSamp <= 0) { return R_NilValue; } int nZiCol = zi.ncol(); if (nZiCol != 2) { return R_NilValue; } int nZiRow = zi.nrow(); if (nZiRow != nSections) { return R_NilValue; } NumericVector y = x; NumericVector zf = clone(zi); double yi = 0.0; for (int iSamp = 0; iSamp < nSamp; iSamp++) { for (int iSection = 0; iSection < nSections; iSection++) { yi = y(iSamp); // make a temporary copy //Use direct II transposed structure: y(iSamp) = sos(iSection, 0) * yi + zf(iSection, 0); zf(iSection, 0) = sos(iSection, 1) * yi - sos(iSection, 4) * y(iSamp) + zf(iSection, 1); zf(iSection, 1) = sos(iSection, 2) * yi - sos(iSection, 5) * y(iSamp); } } List L = List::create(_["y"] = y, _["zf"] = zf); return (L); } gsignal/src/filter.cpp0000644000176200001440000000427614420222025014460 0ustar liggesusers// filter.cpp // Copyright (C) 2021 Geert van Boxtel // // This program is free software; you can redistribute it and/or // modify it under the terms of the GNU General Public License // as published by the Free Software Foundation; either version 3 // of the License, or (at your option) any later version. // // This program is distributed in the hope that it will be useful, // but WITHOUT ANY WARRANTY; without even the implied warranty of // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. // // You should have received a copy of the GNU General Public License // along with this program. If not, see . // // Version history // 20210317 GvB setup for gsignal v0.3.0 (real-valued filter) // 20210515 GvB bugfix: resize a and b vectors; check length zi //--------------------------------------------------------------------------------------------------------------------- #include using namespace Rcpp; // [[Rcpp::export]] List rfilter (NumericVector b, NumericVector a, NumericVector x, NumericVector zi) { int lb = b.length(); int la = a.length(); int lx = x.length(); int lzi = zi.length(); int lab = (la > lb ? la : lb); if (lzi != lab - 1) { return (R_NilValue); } NumericVector bb(lab), aa(lab); for (int i = 0; i < lb; i++) bb(i) = b(i); for (int i = 0; i < la; i++) aa(i) = a(i); NumericVector y(lx); if (la > 1) { for (int i = 0; i < lx; i++) { y(i) = zi(0) + bb(0) * x(i); if (lzi > 0) { for (int j = 0; j < lzi - 1; j++) { zi(j) = zi(j + 1) - aa(j + 1) * y(i) + bb(j + 1) * x(i); } zi(lzi - 1) = bb(lzi) * x(i) - aa(lzi) * y(i); } else { zi(0) = bb(lzi) * x(i) - aa(lzi) * y(i); } } } else if (lzi > 0) { for (int i = 0; i < lx; i++) { y(i) = zi(0) + bb(0) * x(i); if (lzi > 1) { for (int j = 0; j < lzi - 1; j++) { zi(j) = zi(j + 1) + bb(j + 1) * x(i); } zi(lzi - 1) = bb(lzi) * x(i); } else { zi(0) = bb(1) * x(i); } } } List L = List::create(_("y") = y, _("zf") = zi); return (L); } gsignal/NAMESPACE0000644000176200001440000001322314663323315013124 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method(as.Arma,Arma) S3method(as.Arma,Ma) S3method(as.Arma,Sos) S3method(as.Arma,Zpg) S3method(as.Sos,Arma) S3method(as.Sos,Ma) S3method(as.Sos,Sos) S3method(as.Sos,Zpg) S3method(as.Zpg,Arma) S3method(as.Zpg,Ma) S3method(as.Zpg,Sos) S3method(as.Zpg,Zpg) S3method(bilinear,Arma) S3method(bilinear,Zpg) S3method(bilinear,default) S3method(butter,FilterSpecs) S3method(butter,default) S3method(cheby1,FilterSpecs) S3method(cheby1,default) S3method(cheby2,FilterSpecs) S3method(cheby2,default) S3method(ellip,FilterSpecs) S3method(ellip,default) S3method(fftfilt,Ma) S3method(fftfilt,default) S3method(filter,Arma) S3method(filter,Ma) S3method(filter,Sos) S3method(filter,Zpg) S3method(filter,default) S3method(filter,sgolayFilter) S3method(filter_zi,Arma) S3method(filter_zi,Ma) S3method(filter_zi,Sos) S3method(filter_zi,Zpg) S3method(filter_zi,default) S3method(filtfilt,Arma) S3method(filtfilt,Ma) S3method(filtfilt,Sos) S3method(filtfilt,Zpg) S3method(filtfilt,default) S3method(filtic,Arma) S3method(filtic,Ma) S3method(filtic,Sos) S3method(filtic,Zpg) S3method(filtic,default) S3method(freqs,Arma) S3method(freqs,Ma) S3method(freqs,Sos) S3method(freqs,Zpg) S3method(freqs,default) S3method(freqz,Arma) S3method(freqz,Ma) S3method(freqz,Sos) S3method(freqz,Zpg) S3method(freqz,default) S3method(grpdelay,Arma) S3method(grpdelay,Ma) S3method(grpdelay,Sos) S3method(grpdelay,Zpg) S3method(grpdelay,default) S3method(iirlp2mb,Arma) S3method(iirlp2mb,Sos) S3method(iirlp2mb,Zpg) S3method(iirlp2mb,default) S3method(impinvar,Arma) S3method(impinvar,default) S3method(impz,Arma) S3method(impz,Ma) S3method(impz,Sos) S3method(impz,Zpg) S3method(impz,default) S3method(invimpinvar,Arma) S3method(invimpinvar,default) S3method(plot,ar_psd) S3method(plot,grpdelay) S3method(plot,pwelch) S3method(plot,specgram) S3method(print,ar_psd) S3method(print,freqs) S3method(print,freqz) S3method(print,grpdelay) S3method(print,impz) S3method(print,pwelch) S3method(print,specgram) S3method(print,summary.freqs) S3method(print,summary.freqz) S3method(sftrans,Arma) S3method(sftrans,Zpg) S3method(sftrans,default) S3method(summary,freqs) S3method(summary,freqz) S3method(zplane,Arma) S3method(zplane,Ma) S3method(zplane,Sos) S3method(zplane,Zpg) S3method(zplane,default) export(Arma) export(FilterSpecs) export(Ma) export(Sos) export(Zpg) export(ar_psd) export(arburg) export(aryule) export(as.Arma) export(as.Sos) export(as.Zpg) export(barthannwin) export(bartlett) export(besselap) export(besself) export(bilinear) export(bitrevorder) export(blackman) export(blackmanharris) export(blackmannuttall) export(bohmanwin) export(boxcar) export(buffer) export(buttap) export(butter) export(buttord) export(cceps) export(cconv) export(cheb) export(cheb1ap) export(cheb1ord) export(cheb2ap) export(cheb2ord) export(chebwin) export(cheby1) export(cheby2) export(chirp) export(cl2bp) export(clustersegment) export(cmorwavf) export(cohere) export(conv) export(conv2) export(convmtx) export(cplxpair) export(cplxreal) export(cpsd) export(csd) export(czt) export(db2pow) export(dct) export(dct2) export(dctmtx) export(decimate) export(detrend) export(dftmtx) export(digitrevorder) export(diric) export(downsample) export(dst) export(dwt) export(ellip) export(ellipap) export(ellipord) export(fftconv) export(fftfilt) export(fftshift) export(fht) export(filter) export(filter2) export(filter_zi) export(filtfilt) export(filtic) export(findpeaks) export(fir1) export(fir2) export(firls) export(flattopwin) export(fracshift) export(freqs) export(freqs_plot) export(freqz) export(freqz_plot) export(fwhm) export(fwht) export(gauspuls) export(gaussian) export(gausswin) export(gmonopuls) export(grpdelay) export(hamming) export(hann) export(hanning) export(hilbert) export(idct) export(idct2) export(idst) export(ifft) export(ifftshift) export(ifht) export(ifwht) export(iirlp2mb) export(impinvar) export(impz) export(imvfft) export(interp) export(invfreq) export(invfreqs) export(invfreqz) export(invimpinvar) export(kaiser) export(kaiserord) export(levinson) export(marcumq) export(medfilt1) export(mexihat) export(meyeraux) export(morlet) export(movingrms) export(mpoles) export(mscohere) export(ncauer) export(nuttallwin) export(pad) export(parzenwin) export(pburg) export(peak2peak) export(peak2rms) export(pei_tseng_notch) export(poly) export(polyreduce) export(polystab) export(postpad) export(pow2db) export(prepad) export(primitive) export(pulstran) export(pwelch) export(pyulear) export(qp_kaiser) export(rceps) export(rectpuls) export(rectwin) export(remez) export(resample) export(residue) export(residued) export(residuez) export(rms) export(rresidue) export(rssq) export(sampled2continuous) export(sawtooth) export(schtrig) export(sftrans) export(sgolay) export(sgolayfilt) export(shanwavf) export(shiftdata) export(sigmoid_train) export(sinetone) export(sinewave) export(sos2tf) export(sos2zp) export(sosfilt) export(specgram) export(square) export(stft) export(tf2sos) export(tf2zp) export(tfe) export(tfestimate) export(triang) export(tripuls) export(tukeywin) export(udecode) export(uencode) export(ultrwin) export(unshiftdata) export(unwrap) export(upfirdn) export(upsample) export(upsamplefill) export(wconv) export(welchwin) export(wfilters) export(wkeep) export(xcorr) export(xcorr2) export(xcov) export(zerocrossing) export(zp2sos) export(zp2tf) export(zplane) import(grDevices) importFrom(Rcpp,sourceCpp) useDynLib(gsignal, .registration = TRUE) gsignal/NEWS.md0000644000176200001440000001632014670256127013010 0ustar liggesusers# gsignal 0.3.7 * date: 240909 * Fixed issue #21: `findpeaks()` crashes on call to pracma::polyfit * Fixed test on `freqz` which resulted in precision error on CRAN # gsignal 0.3.6 * date: 20240827 * Fixed issue #9: differences between `freqz()` and `signal.scipy.freqz` - updated `freqz()` to match current Octave version - implemented proper `freqz.Sos()` instead of converting to Arma - `freqz.Zpg()` converts to Sos instead of Arma * Implemented changes in 'Octave' 'signal' 1.4.5 with respect to 1.4.1 - added tests for `cplxreal()` (gsignal did not have Octave bug #60606) - added test for `cheb2ap()` (gsignal did not have Octave bug #58218) - all other changes concerned code style or documentation * correct typos in stft.R (H. Dieter Wilhelm - pull request #10) * Negate the signal reversed in time at both ends in `filtfilt()` (Rafael Laboissière - pull request #12) * add check on NULL value in `zapIm()` * Fixed issue #15 (loeriver): incorrect results and error in `residuez()` - removed `Cong()` on calculation of k - made calculation of `r` and `p` conditional * Changed coefficients of the `hamming()` window function as in Matlab/Octave * Fixed issue #17 (dipterix): `decimate()` not compatible with Matlab - replaced call to `fftfilt()` with `filtfilt()` if FIR filter is requested * Bugfix in `fir1()`: adapted calculation of w_o * Fixed issue #19 (jefferis): changed control flow logic in `findpeaks()` (line 174) * Adapt `freqs()` to match `freqz()` - delete freqs_plot.R and add function `freqs_plot()` to freqs.R. --- # gsignal 0.3-5 * date: 20220514 * Fixed Discussion #6: remove padding to nearest power of 2 in `pwelch()` * Fixed Github Issue #5: returning matrix when input is matrix in `pwelch()` * Adapted e-mail addresses in mexihat, morlet, nutallwin, pburg, pyulear * use `inherits()` instead of direct comparison of class name in ar_psd, findpeaks, pwelch, sgolayfilt, upfirdn * defined plot methods for ar_psd, pwelch, specgram classes * Fixed Github Issue #7: decimate with a matrix;, added "fir" argument to ftype --- # gsignal 0.3-4 * date: 20220404 * Fixed test failure in tests/testthat/test_miscellaneous_Functions.R --- # gsignal 0.3-3 * date: 20220330 * Fixed Github Issue #3: Problems with `fftfilt()` when FFT length is provided by user * copy attributes of input object x to output in functions filter, filtfilt, sosfilt, fftfilt * copy dimnames of input object x to output in functions upfirdn, resample, upsample, upsamplefill, downsample, decimate, detrend, fht, sgolayfilt * added `ultrwin()` function * adapted `filter()` to allow data and filter coefficients to be of type complex * adapted `sosfilt()` to allow data and filter coefficients to be of type complex * bugfix in `pwelch()` for multivariate input * Fixed Github Issue #4: Problem with `hilbert()` for small amplitude signals * added `isConjSymm()` function to gsignal-internal * adapted `ifft()` to use `isConjSymm()` instead of `ZapIm()` * reduced default tolerance for `isWhole()` and `zapIm()` * bugfix in `detrend()`: function now returns a vector if input was a vector * bugfix in `filtfilt()`: corrected bug in computing filter ends (default and Sos methods) --- # gsignal 0.3-2 * date: 20210518 * corrected CRAN WARNINGs on ATLAS, MKL, valgrind, fedora, solaris * corrected import NOTE for grDevices * adapted code in vignette "gsignal" * use explicit tolerance in testthat tests * added badges and logo (just for the fun of it) * sort zeros and poles on output in sos2zp(), tf2zp() * use `matrix()` instead of `as.matrix()` in functions `dct()`, `idct()`, `czt()`, `dst()`, `idst()`, `fht()`, `ifht()` * minor bugfix in `arburg()` * bugfix in filter.cpp: resize `a` and `b` vectors, length of `zi` * adapted some examples --- # gsignal 0.3-1 - date: 20210502 - added 'signals' data frame - cleaned code - minor bugfixes - updated tests - added vignette --- # gsignal 0.3-0 - date: 20210411 - Bugfixes in pwelch(), butter(), as.Arma.Sos(), as.Sos.Zpg(), sos2tf() - Added 'output' parameter to butter(), cheby1(), cheby2(), ellip() - Redesigned filter() to correct problems with initial conditions (now direct-form II) - Return objects of respective class tf2zp(), tf2sos(), zp2sos(), zp2tf(), sos2tf(), sos2zp() - Added 'order' argument to zp2sos(); changed default ordering - Added filter_zi() function - Redesigned sosfilt(); added support for initial conditions - Adapted filtfilt(): use padding and Gustafsson method for initial conditions - Function sgolayfilt(): if input x is a matrix, filter its columns - Replace 'dim' argument by 'MARGIN' in functions cplxpair(), cplxpair(), medfilt1() - Solved numerical precision error in chebwin() and cheb() functions - Bugfix in cplxpair(); added additional tests - Return vector if input is a vector in function czt() - Added range parameter ('half' or 'whole') in function pwelch() - Bugfix in calculating time points, function stft() - Changed plotting to S3 functions in function specgram() --- # gsignal 0.2-0 - date: 20201218 - completed documentation - adapted examples and links - license changed to GPL-3 in accordance with Octave signal package license --- # gsignal 0.1-0 - date: 20201213 - initial setup. Functions: - **Signals**: buffer, chirp, cmorwavf, diric, gauspuls, gmonopuls, mexihat, meyeraux, morlet, pulstran, rectpuls, sawtooth, shanwavf, shiftdata, sigmoid_train, sinetone, sinewave, specgram, square, tripuls, udecode, uencode, unshiftdata - **Signal Measurement**: findpeaks, peak2peak, peak2rms, rms, rssq - **Correlation and Convolution**: cconv, convmtx, wconv, xcorr, xcorr2, xcov - **Filtering**: fftfilt, filter, filter2, filtfilt, filtic, medfilt1, movingrms, sgolayfilt, sosfilt - **Filter Analysis**: freqs, freqs_plot, freqz, freqz_plot, fwhm, grpdelay, impz, zplane - **Filter Conversion**: polystab, residued, residuez, sos2tf, sos2zp, tf2sos, tf2zp, zp2sos, zp2tf - **IIR Filter Design**: besselap, besself, bilinear, buttap, butter, buttord, cheb, cheb1ap, cheb1ord, cheb2ap, cheb2ord, cheby1, cheby2 ellip, ellipap, ellipord, iirlp2mb, impinvar, invimpinvar, ncauer, pei_tseng_notch, sftrans - **FIR Filter Design**: cl2bp, fir1, fir2, firls, kaiserord, qp_kaiser, remez, sgolay - **Transforms**: bitrevorder, cceps, cplxreal, czt, dct, dct2, dctmtx, dftmtx, digitrevorder, dst, dwt, fftshift, fht, fwht, hilbert, idct, idct2, idst, ifft, ifftshift, ifht, ifwht, imvfft, rceps, stft - **Power Spectrum Analysis**: ar_psd, cohere, cpsd, csd, db2pow, mscohere, pburg, pow2db, pwelch, pyulear, tfe, tfestimate - **Window Functions**: barthannwin, bartlett, blackman, blackmanharris, blackmannuttall, bohmanwin, boxcar, chebwin, flattopwin, gaussian, gausswin, hamming, hanning, hann, kaiser, nuttallwin, parzenwin, rectwin, triang, tukeywin, ultrwin, welchwin - **System Identification**: arburg, aryule, invfreq, invfreqs, invfreqz, levinson - **Sample Rate Change**: decimate, downsample, interp, resample, upfirdn, upsample - **Utility**: clustersegment, fracshift, marcumq, primitive, sampled2continuous, schtrig, upsamplefill, wkeep, zerocrossing - **Standard Functions**: detrend, pad, postpad, prepad - **Miscellaneous**: Arma, Ma, Zpg, Sos, FilterSpecs, fftconv, unwrap, cplxpair, poly, conv, conv2, residue, polyreduce, mpoles gsignal/inst/0000755000176200001440000000000014670306232012656 5ustar liggesusersgsignal/inst/CITATION0000644000176200001440000000043614473634356014032 0ustar liggesusersbibentry(bibtype = "Manual", header = "To cite package ‘gsignal’ in publications use:", title = "gsignal: Signal Processing", author = person("Van Boxtel, G.J.M., et al."), year = "2021", url = "https://github.com/gjmvanboxtel/gsignal") gsignal/inst/doc/0000755000176200001440000000000014670306232013423 5ustar liggesusersgsignal/inst/doc/gsignal.Rmd0000644000176200001440000007325114525424466015534 0ustar liggesusers--- title: "Signal Processing in R" author: Geert van Boxtel date: April 30, 2021 output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Signal Processing in R} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` # 1. Introduction Most engineers use Matlab (or its open source alternative Octave) to solve their signal processing problems. Languages such as R or Python are not immediately thought of for signal processing, although this has changed a bit in the last few years with the development of the R [signal](https://r-forge.r-project.org/projects/signal/) package and Python [scipy.signal](https://docs.scipy.org/doc/scipy/reference/signal.html). The package `gsignal` aims to further stimulate the use of R for signal processing tasks. It is ported from the Octave [signal](https://octave.sourceforge.io/signal/) package, version 1.4.1 (2019-02-08). The package contains a variety of signal processing tools, such as signal generation and measurement, correlation and convolution, filtering, FIR and IIR filter design, filter analysis and conversion, power spectrum analysis, system identification, decimation and sample rate change, and windowing. This vignette provides a brief and general overview of some of `gsignal`'s functions. ```{r setup} library(gsignal) ``` # 2. Signal generation and measurement The function `pulstran` can be used to generate trains of pulses based on samples of a continuous function (which can be user-defined). The following figures show a periodic rectangular pulse, an asymmetric sawtooth pulse, a periodic Gaussian waveform, and a custom pulse train. ```{r pulstran, fig.height=7, fig.width=7} op <- par(mfrow = c(2, 2)) ## periodic rectangular pulse t <- seq(0, 60, 1/1e3) d <- cbind(seq(0, 60, 2), sin(2 * pi * 0.05 * seq(0, 60, 2))) y <- pulstran(t, d, 'rectpuls') plot(t, y, type = "l", xlab = "", ylab = "", main = "Periodic rectangular pulse") ## assymetric sawtooth waveform fs <- 1e3 t <- seq(0, 1, 1/fs) d <- seq(0, 1, 1/3) x <- tripuls(t, 0.2, -1) y <- pulstran(t, d, x, fs) plot(t, y, type = "l", xlab = "", ylab = "", main = "Asymmetric sawtooth ") ## Periodic Gaussian waveform fs <- 1e7 tc <- 0.00025 t <- seq(-tc, tc, 1/fs) x <- gauspuls(t, 10e3, 0.5) ts <- seq(0, 0.025, 1/50e3) d <- cbind(seq(0, 0.025, 1/1e3), sin(2 * pi * 0.1 * (0:25))) y <- pulstran(ts, d, x, fs) plot(ts, y, type = "l", xlab = "", ylab = "", main = "Gaussian pulse") ## Custom pulse trains fnx <- function(x, fn) sin(2 * pi * fn * x) * exp(-fn * abs(x)) ffs <- 1000 tp <- seq(0, 1, 1 / ffs) pp <- fnx(tp, 30) fs <- 2e3 t <- seq(0, 1.2, 1 / fs) d <- seq(0, 1, 1/3) dd <- cbind(d, 4^-d) z <- pulstran(t, dd, pp, ffs) plot(t, z, type = "l", xlab = "", ylab = "", main = "Custom pulse") par(op) ``` A number of waveform generating functions are available, such as `chirp`, `cmorwavf`, `diric`, `gauspuls`, `gmonopuls`, `mexihat`, `meyeraux`, `morlet`, `rectpuls`, `sawtooth`, `square`, and `tripuls`. The function `findpeaks` can be used to determine (local) minima and maxima in a signal, as the following figures show. ```{r findpeaks, fig.height=4, fig.width=7} t <- 2 * pi * seq(0, 1,length = 1024) y <- sin(3.14 * t) + 0.5 * cos(6.09 * t) + 0.1 * sin(10.11 * t + 1 / 6) + 0.1 * sin(15.3 * t + 1 / 3) data1 <- abs(y) # Positive values peaks1 <- findpeaks(data1) data2 <- y # Double-sided peaks2 <- findpeaks(data2, DoubleSided = TRUE) peaks3 <- findpeaks (data2, DoubleSided = TRUE, MinPeakHeight = 0.5) op <- par(mfrow=c(1,2)) plot(t, data1, type="l", xlab="", ylab="") points(t[peaks1$loc], peaks1$pks, col = "red", pch = 1) plot(t, data2, type = "l", xlab = "", ylab = "") points(t[peaks2$loc], peaks2$pks, col = "red", pch = 1) points(t[peaks3$loc], peaks3$pks, col = "red", pch = 4) par (op) title("Finding the peaks of smooth data is not a big deal") t <- 2 * pi * seq(0, 1, length = 1024) y <- sin(3.14 * t) + 0.5 * cos(6.09 * t) + 0.1 * sin(10.11 * t + 1 / 6) + 0.1 * sin(15.3 * t + 1 / 3) data <- abs(y + 0.1*rnorm(length(y),1)) # Positive values + noise peaks1 <- findpeaks(data, MinPeakHeight=1) dt <- t[2]-t[1] peaks2 <- findpeaks(data, MinPeakHeight=1, MinPeakDistance=round(0.5/dt)) op <- par(mfrow=c(1,2)) plot(t, data, type="l", xlab="", ylab="") points (t[peaks1$loc],peaks1$pks,col="red", pch=1) plot(t, data, type="l", xlab="", ylab="") points (t[peaks2$loc],peaks2$pks,col="red", pch=1) par (op) title(paste("Noisy data may need tuning of the parameters.\n", "In the 2nd example, MinPeakDistance is used\n", "as a smoother of the peaks")) ``` # 3. Filter Design The `gsignal` package contains functions for designing lowpass, highpass, bandpass, and bandstop filters. Both Finite Impulse Response (FIR) and Infinite Impulse Response (IIR) filters can be designed. The `freqz` function displays the frequency response's magnitude and phase of the filter. ## FIR filters A FIR filter is a filter whose impulse response settles to zero in finite time. This is in contrast to IIR filters, which have internal feedback causing them to have an infinitely long impulse response (although usually decaying). For causal discrete-time FIR filters the output is a weighted sum of the most recent input values. Compared to IIR filters, advantages of FIR filters are they are inherently stable (because there is no feedback that propagates indefinitely), and that they have linear phase (constant across frequencies). The main disadvantage is that they require more computation time to obtain sharp transition bands. The package `gsignal` contains various methods to design digital FIR filters. The functions `fir1`, `fir2`, and `kaiserord` use the [windowing method](https://en.wikipedia.org/wiki/Finite_impulse_response#Window_design_method), in which a window is applied to the truncated inverse Fourier transform of the filter's frequency response. The function `firls` is an extension of the `fir1` and `fir2` functions that uses a least-squares approach to minimize errors between the specified and the actual frequency response over sub-bands of the frequency range. The [Parks-McClellan](https://en.wikipedia.org/wiki/Parks-McClellan_method) method using the [Remez exchange algorithm](https://en.wikipedia.org/wiki/Remez_algorithm) for finding an optimal equiripple set of filter coefficients is used by the `remez` function. The `cl2bp` function allows designing FIR filters without explicitly defining the transition bands for the magnitude response. Below are some examples of FIR filter design. The magnitude and the phase of the filter's frequency response are plotted by the function `freqz`. ```{r fir, fig.height=4, fig.width=7} ## FIR filter design by windowing # low-pass filter 10 Hz fs = 256 h <- fir1(40, 10/ (fs / 2), "low") freqz(h, fs = fs) # observe the effect of filter length h <- fir1(80, 10/ (fs / 2), "low") freqz(h, fs = fs) # fir2 allows specifying arbitrary frequency responses f <- c(0, 0.3, 0.3, 0.6, 0.6, 1) m <- c(0, 0, 1, 1/2, 0, 0) fh <- freqz(fir2(100, f, m)) op <- par(mfrow = c(1, 2)) plot(f, m, type = "b", ylab = "magnitude", xlab = "Frequency") lines(fh$w / pi, abs(fh$h), col = "blue") legend("topright", legend = c("specified", "actual"), lty = 1, pch = c(1, NA), col = c("black", "blue")) # plot in dB: plot(f, 20*log10(m+1e-5), type = "b", ylab = "dB", xlab = "Frequency") lines(fh$w / pi, 20*log10(abs(fh$h)), col = "blue") par(op) title("specify arbitrary frequency responses with fir2") ## 50 Hz notch filter with remez fs <- 200 nyquist <- fs / 2 f <- c(0, 48.5 / nyquist, 49.5 / nyquist, 50.5 / nyquist, 51.5 / nyquist, 1) a <- c(1, 1, 0, 0, 1, 1) h <- remez(200, f, a) freqz(h, fs = fs) ``` ### Compensating for filter delay in FIR filters Filtering causes a delay because weighted samples in the past are used. FIR filters have a linear phase, so in the time domain this delay is constant, namely $N / 2$, where $N$ is the filter length (or 'number of taps'). The function `grpdelay` can be used to calculate the [group delay](https://ccrma.stanford.edu/~jos/filters/Group_Delay.html); see Figure (a) below. Because phase is linear, it is easy to to compensate for the filter delay as shown in Figure (b) below. ```{r FIR_delay, fig.height=7, fig.width=7} op <- par(mfrow = c(2, 1)) # design the filter fs = 256 h <- fir1(40, 30/ (fs / 2), "low") # group delay is constant at N/2 gd <- grpdelay(h) plot(gd, ylim = c(0, 40), main = paste("(a) Group delay for FIR filters is constant\n", "(here 40 / 2 = 20)")) # filter electrocardiogram data with added noise data(signals, package = "gsignal") npts <- nrow(signals) ecg <- signals$ecg + 1000 * runif(npts) time <- seq(0, 10, length.out = npts) plot(time, ecg, type = "l", main = "(b) Example ECG signal", xlab = "Time", ylab = "", xlim = c(0,2)) title(ylab = expression(paste("Amplitude (", mu, "V)")), line = 2) f1 <- gsignal::filter(h, ecg) lines(time, f1, col = "red", lwd = 2) delay <- mean(gd$gd) f2 <- c(f1[(delay + 1):npts], rep(NA, delay)) lines(time, f2, col = "blue", lwd = 2) legend("topright", legend = c("Original", "Filtered", "Corrected"), lty = 1, lwd = c(1, 2, 2), col = c("black", "red", "blue")) par(op) ``` ## IIR filters Infinite Impulse Response, or recursive, filters are an efficient way of achieving a long impulse response by not only using past input samples, but also past output samples. Hence, an element of feedback (recursion) is used. IIR filters are specified by a set of *feedback* coefficients (usually termed $a$), in addition to *feedforward* coefficients ($b$) as used in FIR filters. Advantages of IIR filters compared to FIR filters are related to their efficiency in implementation. IIR filters usually require (much) fewer filter coefficients, implying a correspondingly fewer number of calculations. On the other hand, the impulse response of IIR filters does not always decay to zero, which may result in filter instability (see the example below). In addition, the phase of IIR filters is not linear but frequency dependent. Forward and reverse filtering (`filtfilt`) results in zero phase at the expense of additional computing time (there is no free lunch). Some important types of IIR filters are: 1. Butterworth filters have frequency response that is as flat as possible in the passband (function `butter`); 2. Chebyshev filters are IIR filters having a steeper roll-off than Butterworth filters, and either have a passband ripple (Type I - function `cheby1`), or a stopband ripple (Type II - function `cheby2`); 3. Elliptic filters with equalized ripple (equiripple) behavior in both the passband and the stopband (function `ellip`); 4. (Analog) Bessel filters with a maximally linear phase response. The following figure compare the frequency responses of (a) 5th order Butterworth and Chebyshev filters, (b) 5th order Butterworth and elliptic filters, and (c) type I and type II Chebyshev filters. ```{r iir, fig.height=7, fig.width=7} op <- par(mfrow = c(3,1)) # compare Butterworth and Chebyshev filters. bfr <- freqz(butter(5, 0.1)) cfr <- freqz(cheby1(5, .5, 0.1)) plot(bfr$w, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-80, 0), xlab = "Frequency (rad)", ylab = c("dB"), main = "(a) Butterworth and Chebyshev") lines(cfr$w, 20 * log10(abs(cfr$h)), col = "red") legend("topright", legend = c("5th order Butterworth", "5th order Chebyshev"), lty = 1, col = c("black", "red")) # compare Butterworth and elliptic filters. efr <- freqz(ellip(5, 3, 40, 0.1)) plot(bfr$w, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-80, 0), xlab = "Frequency (rad)", ylab = c("dB"), main = "(b) Butterworth and Elliptic") lines(efr$w, 20 * log10(abs(efr$h)), col = "red") legend ("topright", legend = c("5th order Butterworh", "5th order Elliptic"), lty = 1, col = c("black", "red")) # compare type I and type II Chebyshev filters. c1fr <- freqz(cheby1(5, .5, 0.1)) c2fr <- freqz(cheby2(5, 20, 0.1)) plot(c1fr$w, 20 * log10(abs(c1fr$h)), type = "l", ylim = c(-80, 0), xlab = "Frequency (rad)", ylab = c("dB"), main = "(c) Type I and II Chebyshev") lines(c2fr$w, 20 * log10(abs(c2fr$h)), col = "red") legend ("topright", legend = c("5th order Type I", "5th order Type II"), lty = 1, col = c("black", "red")) par(op) ``` ### Numerical precision and stability Using IIR filter coefficients $b, a$ can cause numerical problems. Therefore, IIR filter design functions in `gsignal` have an `output` parameter, allowing the filter coefficients to be returned in one of three forms: * Arma, a `list` containing the moving average polynomial (feedforward) coefficients $b$, and the autoregressive (recursive, feedback) coefficients $a$; * Zpg, a `list` containing the coefficients in zero-pole-gain form * Sos, a `list` of series second order sections ([biquads](https://en.wikipedia.org/wiki/Digital_biquad_filter)) Although the `Arma` form is default for compatibility reasons, the use of `Sos` and the accompanying filtering function `sosfilt` is generally preferred. A second issue that may occur when using IIR filters, is instability. This may be the result of numerical rounding errors or because too many filter coefficients were used. [Pole-Zero Analysis](https://ccrma.stanford.edu/~jos/filters/Pole_Zero_Analysis.html) can be useful here. A filter is stable if its impulse response $h(n)$ decays to 0 when $n$ increases. In terms of poles and zeros, this is true if all of the filter's poles are inside the unit circle in the $z$-plane ([Smith, J.O. (2012)](https://ccrma.stanford.edu/~jos/filters/Stability_Revisited.html)). The package `gsignal` offers the function `zplane` that displays a filter's poles and zeros in the complex $z$-plane, as the following figure illustrates. In the figure the '0's represent the zeros, and the 'X's the poles. ```{r zplane, fig.height=7, fig.width=7} op <- par(no.readonly = TRUE) n <- layout(matrix(c(1, 2, 3, 3), nrow = 2, byrow = TRUE)) stable <- butter(3, 0.2, "low", output = "Zpg") # artificially adapt pole instable <- stable instable$p[2] <- instable$p[2] - 2 zplane(stable, main = "Stable") zplane(instable, main = "Instable") t <- seq(0, 1, len = 100) x <- sin(2* pi * t * 2.3) + 0.5 * rnorm(length(t)) z1 <- filter(stable, x) z2 <- filter(instable, x) plot(t, x, type = "l", xlab = "", ylab = "") lines(t, z1, col = "green", lwd = 2) lines(t, z2, col = "red") legend("bottomleft", legend = c("Original", "Stable", "Instable"), lty = 1, col = c("black", "green", "red"), ncol = 3) par(op) ``` ### Compensating for filter delay in IIR filters Because the phase of the frequency response of IIR filters is not linear, the filter delay cannot be easily compensated for as in the FIR case. Recall that the 40-tap 30 Hz low-pass FIR filter used above for filtering the ECG signal had a linear phase and a constant delay of 20 samples. If a 5th order elliptic low-pass filter at 30 Hz is used, it can easily be seen that its phase is not linear (Figure (a) below), and hence the filter delay is dependent of frequency (Figure (b) below). Note that the group delay is defined to be the negative first derivative of the filter's phase response. ```{r IIR_delay, fig.height=7, fig.width=7} op <- par(mfrow = c(2, 1)) ell <- ellip(5, 0.1, 60, 30/(fs/2), "low") ellf <- freqz(ell, fs = fs) argh <- Arg(ellf$h) argh[which(is.na(argh))] <- 0 phase <- unwrap(argh) plot(ellf$w, phase, type = "l", xlab = "Frequency (Hz)", ylab = "Phase", main = paste("30 Hz 5th order elliptical low-pass IIR filter\n", "phase response is not linear")) gd <- grpdelay(ell, fs = fs) plot(gd, main = paste("group delay depends on frequency\n", "mean:", round(mean(gd$gd), 1), "samples")) par(op) ``` This means that the filter delay cannot be compensated for in the same way as for the FIR filter. An alternative is to use the function `filtfilt`, which applies forward and backward filtering and thus compensates for the delay, as shown in the figure below. ```{r IIR_filtfilt, fig.height=4, fig.width=7} f <- filter(ell, ecg) ff <- filtfilt(ell, ecg) plot(time, ecg, type = "l", xlab = "Time", ylab = "", xlim = c(0,2)) title(ylab = expression(paste("Amplitude (", mu, "V)")), line = 2) lines(time, f, col = "red", lwd = 2) lines(time, ff, col = "blue", lwd = 2) legend("topright", legend = c("Original", "filter()", "filtfilt()"), lty = 1, lwd = c(1, 2, 2), col = c("black", "red", "blue")) ``` # 4. Filtering and Convolution The most straightforward way to implement a digital filter is by [convolving](https://en.wikipedia.org/wiki/Convolution) the input signal with the filter's impulse response. The package `gsignal` contains several functions for convolution. The function `conv` returns the 1-D convolution of two vectors `a` and `b` in 3 'shapes'; "full", for which the output vector has a length equal to `length(a) + length(b) - 1`; "valid", which only returns the central part of the convolution with an output length of `length(a)`; or "valid", which returns only those parts of the convolution that are computed without the zero-padded edges (output length `max(length(a) - length(b) + 1, 0)`). For example: ```{r conv1} u <- rep(1, 3) v <- c(1, 1, 0, 0, 0, 1, 1) conv(u, v, "full") conv(u, v, "same") conv(u, v, "valid") conv(v, u, "valid") ``` Two-dimensional convolution of two matrices can be computed by the `conv2` function. In this case, the size of the output matrix is `nrow(A) + nrow(B) - 1` by `ncol(A) + ncol(B) - 1` for "full" convolution, `nrow(A)` by `ncol(A)` for "same", and `max(nrow(A) - nrow(B) + 1, 0)` by `max(ncol(A) - ncol(B) + 1, 0)` for "valid". The function `conv2` is implemented in C++ for speed. For long series convolution may be sped up by making use of the fact that convolution in the time domain is equivalent to multiplication in the frequency domain. Thus, the two series may be padded to the same length, converted to the frequency domain by FFT, multiplied point-wise, and transformed back to the time domain. The function `cconv` uses this approach. However, if one series is much longer than the other (as in typical filtering operations), zero-padding the shorter series to the length of the longer series may not be the most efficient method. In such cases, even faster methods like the overlap-add method used by the function `fftconv` may be useful. That's the theory at least... ```{r conv2, fig.height=7, fig.width=7} short <- runif(20L) long <- runif(1000L) # convolve two long series ll <- microbenchmark::microbenchmark(conv(long, long), cconv(long, long), fftconv(long, long)) plot1 <- ggplot2::autoplot(ll) # convolve a short and a long series sl <- microbenchmark::microbenchmark(conv(short, long), cconv(short, long), fftconv(short, long)) plot2 <- ggplot2::autoplot(sl) gridExtra::grid.arrange(plot1, plot2, nrow = 2, ncol = 1) ``` One-dimensional Filtering in `gsignal` is performed by the function `filter`. It is a direct form II transposed implementation in C++ of the standard linear time-invariant difference equation $$\sum_{k=0}^{N} a(k+1) y(n-k) + \sum_{k=0}^{M} b(k+1) x(n-k) = 0; 1 \le n \le length(x)$$ If a matrix is passed to `filter`, its columns are filtered. Two-dimensional filtering can be done using `filter2`. The function `fftfilt` uses the overlap-add method and FFT convolution for speed (but your mileage may vary), and `filtfilt` uses forward and backward filtering to avoid filter delay, as used above. If numerical stability of filter coefficients is an issue, filter design using series second order sections and filtering with the function `sosfilt` may be used. ## Filtering long series in chunks The functions `filter` and `sosfilt` can retain the filter state in order to process long data series in chunks. The following piece of code shows how this is done. A long series is split into two parts, which are processed sequentially. In the first call to filter, the final conditions `zf` are asked to be returned after filtering the first part, which are then passed to the second call to filter as the initial conditions `zi` for the second part of the series. The two filtered parts can then be concatenated for form the entire filtered series without discontinuities. ```{r chunks} N <- 10000L long <- runif(N) part1 <- long[1:(N / 2)] part2 <- long[((N / 2) + 1):N] b <- c(2, 3) a <- c(1, 0.2) y <- filter(b, a, long) y1 <- filter(b, a, part1, 'zf') y2 <- filter(b, a, part2, y1$zf) yy <- c(y1$y, y2$y) all.equal(y, yy) ``` ## Using initial conditions to avoid filter startup effects Initial conditions can also be used to set the initial state of the filter so that the output starts at the same value as the first element of the signal to be filtered. The initial conditions for the filter can be computed using the functions `filter_zi`, or `filtic`, as shown in the following example. ```{r zi, fig.height=5, fig.width=7 } t <- seq(-1, 1, length.out = 201) x <- (sin(2 * pi * 0.75 * t * (1 - t) + 2.1) + 0.1 * sin(2 * pi * 1.25 * t + 1) + 0.18 * cos(2 * pi * 3.85 * t)) h <- butter(3, 0.05) zi <- filter_zi(h) ## alternatively, use: ## lab <- max(length(h$b), length(h$a)) - 1 ## zi <- filtic(h, rep(1, lab), rep(1, lab)) z1 <- filter(h, x) z2 <- filter(h, x, zi * x[1]) plot(t, x, type = "l", xlab ="", ylab = "") lines(t, z1, col = "red") lines(t, z2$y, col = "green") legend("bottomright", legend = c("Original signal", "Filtered without initial conditions", "Filtered with initial conditions"), lty = 1, col = c("black", "red", "green")) ``` # 5. Power spectrum analysis The [power spectral density](https://en.wikipedia.org/wiki/Spectral_density) (PSD) of a time series describes the distribution of power (variance) into frequency components composing that signal. The [Fourier Transform](https://en.wikipedia.org/wiki/Fourier_transform) is a nonparametric method of decomposing a signal into its frequency spectrum. The functions `fft` and `ifft` compute the Discrete Fourier Transform with a fast algorithm, the FFT. A parametric alternative for autoregressive (AR) models is available through the functions `ar_psd`, `pburg`, or `pyulear`. The following figure shows how both FFT- and AR-based methods can discover the periodicities of 5 and 12 Hz in a noisy signal. ```{r fft_ar, fig.height=7, fig.width=7} op <- par(mfrow = c(3, 1)) fs <- 200 nsecs <- 10 lx <- fs * nsecs t <- seq(0, nsecs, length.out = lx) # signal of 5 Hz + 12 Hz + noise x <- (sin(2 * pi * 5 * t) + sin(2 * pi * 12 * t) + runif(lx)) plot(t, x, type = "l", xlab = "Time (s)", ylab = "", main = "Original signal") pw <- pwelch(x, window = lx, fs = fs, detrend = "none") plot(pw, xlim = c(0, 20), main = "PSD estimate using FFT") py <- pyulear(x, 30, fs = fs) plot(py, xlim = c(0, 20), main = "PSD estimate using Yule-Walker") par(op) ``` ## Welch's method [Welch (1967)](https://en.wikipedia.org/wiki/Welch%27s_method) proposed a method to estimate the power spectrum that reduces the variance of the spectrum (at the expense of decreasing frequency resolution - remember, there is no free lunch) by splitting the signal into (usually) overlapping segments and windowing each segment, for instance by a Hamming window. The periodogram is then computed for each segment, and the squared magnitude is computed, which is then averaged for all segments. The spectral density is the mean of the modified periodograms, scaled so that area under the spectrum is the same as the mean square of the data. In case of multivariate signals, cross-spectral density, phase, and coherence are also returned. The input data can be demeaned or detrended, overall or for each segment separately. The following figure shows two signals, a sine and a cosine of 5 Hz with noise added. Sines and cosines are the same waveforms, the only difference being that a cosine leads the sine wave by an amount of 90$^{\circ}$ ($\pi / 2$ radians). Hence, a plot of the PSD should show identical shapes for both signals, but a phase difference at $\pi / 2$ radians should be visible at 5 Hz, which should also produce a high magnitude squared coherence (near 1) at that frequency (coherence reflects constant phase differences). ```{r welch, fig.height=7, fig.width=7} op <- par(mfrow = c(3, 1)) fs <- 200 nsecs <- 100 lx <- fs * nsecs t <- seq(0, nsecs, length.out = lx) # sine and cosine of signal of 5 Hz noise x1 <- cos(2 * pi * 5 * t) + runif(lx) x2 <- sin(2 * pi * 5 * t) + runif(lx) x <- cbind(x1, x2) pw <- pwelch(x, fs = fs) plot(pw, plot.type = "spectrum", yscale = "dB", xlim = c(0, 50), main = "A sine and a cosine of 5 Hz have the same PSD") legend("topright", legend = c("Cosine", "Sine"), lty = 1:2, col = 1:2) rect(3, -35, 7, -4, border = "red", lwd = 3) plot(pw, plot.type = "phase", xlim = c(0, 50), main = expression(bold(paste("but differ ", pi/2, " radians in phase at 5 Hz")))) rect(3, -pi, 7, pi, border = "red", lwd = 3) plot(pw, plot.type = "coherence", xlim = c(0, 50), main = "leading to coherence ~ 1 at 5 Hz") rect(3, 0, 7, 1, border = "red", lwd = 3) par(op) ``` ## Time-frequency analysis If your signal's frequency content changes over time, the power spectrum is of limited use. You might then want to use some form of time-frequency analysis. Specialized R packages exist for wavelet analysis capable of doing time-frequency analysis, such as [wavelets](https://CRAN.R-project.org/package=wavelets), [Rwave](https://CRAN.R-project.org/package=Rwave), and [waveslim](https://CRAN.R-project.org/package=waveslim). `gsignal` does contain a basic function for computing the discrete wavelet transform (`dwt`), but is not otherwise specialized for wavelet analysis. Another way of decomposing a signal both in time and frequency is the [Short-Term Fourier Transform](https://en.wikipedia.org/wiki/Short-time_Fourier_transform), which can be calculated by the function `stft`. Here, the data to be transformed is broken up into (overlapping) chunks. Each chunk is then Fourier transformed, and added to a record of magnitude and phase for each point in time and frequency. Alternatively, the spectrogram (`specgram`) in essence does the same - the spectogram is the squared magnitude of the STFT of the signal. The following figure represents the spectrogram of a `chirp` signal, which is a signal in which the frequency changes with time. By default, the `specgram` and `stft` function produce grayscale plots, but here it is shown how other color palettes can be used. ```{r specgram, fig.height=7, fig.width=7} op <- par(mfrow = c(2, 1)) jet <- grDevices::colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) sp <- specgram(chirp(seq(0, 5, by = 1/8000), 200, 2, 500, "logarithmic"), fs = 8000) plot(sp, col = jet(20)) c2w <- grDevices::colorRampPalette(colors = c("red", "white", "blue")) plot(sp, col = c2w(50)) par(op) ``` # 6. Miscellaneous functions The package also contains many other functions that may be useful in various signal processing applications. * **Windowing functions**. [Window functions](https://en.wikipedia.org/wiki/Window_function) are usually bell-shaped functions (although rectangular and triangular shapes are also used), which are multiplied by the signal in order to taper the ends of the signal to zero to reduce spectral leakage. For instance, the `pwelch` function described above uses a window function (default Hamming) before FFT-ing the segments. The window functions available in `gsignal` are: + Modified Bartlett-Hann (`barthannwin`) + Bartlett (triangular - `bartlett`) + Blackman window (`blackman`) + Blackman-Harris (`blackmanharris`) + Blackman-Nuttall (`blackmannuttall`) + Bohman (`bohmanwin`) + Boxcar (rectangular - `boxcar`) + Chebyshev (`chebwin`) + Flat top (`flattopwin`) + Gaussian (`gausswin`) + Hamming (`hamming`), + Hanning (`hanning` - alias `hann`) + Kaiser (`kaiser`) + Nuttall (`nuttallwin`) + Parzen (`parzenwin`) + Rectangular (`rectwin`) + Triangular (`triang`) + Tukey (`tukeywin`) + Ultraspherical (`ultrwin`) + Welch (`welchwin`) * **Resampling functions**. Up- or downsampling signals by an integer factor can be done with `upsample` and `downsample`. The function `decimate` and `interp` also down- or upsample by an integer factor, but allows specifying an IIR or FIR filter to be applied before resampling to avoid aliasing. The more general function `resample` allows changing the sampling rate by arbitrary factors, and also takes an impulse response of a FIR filter as an optional argument (if not specified `resample` will design an optimal filter for you). The function `upfirdn` performs three operations; it first upsamples the input signal by inserting zeros, then applies a FIR filter, and finally downsamples the signal by throwing away samples. Because this function uses a polyphase implementation for filtering, it is often faster than when `filter` is used (the `resample` function uses `upfirdn` for exactly that reason). * **Other functions**. Various other functions not specifically addressed in this vignette are also included, which can be used for a variety of signal processing operations, such as padding data (`pad`, `prepad`, `postpad`), detrending data (`detrend`), unwrapping frequency response phase (`unwrap`), data transformations (`cceps`, `czt` `dct`, `dct2`, `dctmtx`, `dftmtx`, `dst`, `dwt`, `fftshift`, `fht`, `fwht`, `hilbert`, `idct`, `idct2`, `idst`, `ifht`, `ifwht`, `rceps`), polynomial analysis (`poly`, `polystab`, `residue`, `residued`, `residuez`, `polyreduce`, `mpoles`). Some helper functions (`cplxpair`, `cplxreal`, `db2pow`, `pow2db`, `fftshift`, `ifftshift`, `digitrevorder`), and other utilities are also included (e.g., `buffer`, `shiftdata`, `unshiftdata`, `peak2peak`, `peak2rms`, `rms`, `rssq`, `clustersegment`, `fracshift`, `marcumq`, `primitive`, `sampled2continuous`, `schtrig`, `upsamplefill`, `wkeep`, `zerocrossing`) gsignal/inst/doc/gsignal.R0000644000176200001440000002774514670306232015211 0ustar liggesusers## ----include = FALSE---------------------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----setup-------------------------------------------------------------------- library(gsignal) ## ----pulstran, fig.height=7, fig.width=7-------------------------------------- op <- par(mfrow = c(2, 2)) ## periodic rectangular pulse t <- seq(0, 60, 1/1e3) d <- cbind(seq(0, 60, 2), sin(2 * pi * 0.05 * seq(0, 60, 2))) y <- pulstran(t, d, 'rectpuls') plot(t, y, type = "l", xlab = "", ylab = "", main = "Periodic rectangular pulse") ## assymetric sawtooth waveform fs <- 1e3 t <- seq(0, 1, 1/fs) d <- seq(0, 1, 1/3) x <- tripuls(t, 0.2, -1) y <- pulstran(t, d, x, fs) plot(t, y, type = "l", xlab = "", ylab = "", main = "Asymmetric sawtooth ") ## Periodic Gaussian waveform fs <- 1e7 tc <- 0.00025 t <- seq(-tc, tc, 1/fs) x <- gauspuls(t, 10e3, 0.5) ts <- seq(0, 0.025, 1/50e3) d <- cbind(seq(0, 0.025, 1/1e3), sin(2 * pi * 0.1 * (0:25))) y <- pulstran(ts, d, x, fs) plot(ts, y, type = "l", xlab = "", ylab = "", main = "Gaussian pulse") ## Custom pulse trains fnx <- function(x, fn) sin(2 * pi * fn * x) * exp(-fn * abs(x)) ffs <- 1000 tp <- seq(0, 1, 1 / ffs) pp <- fnx(tp, 30) fs <- 2e3 t <- seq(0, 1.2, 1 / fs) d <- seq(0, 1, 1/3) dd <- cbind(d, 4^-d) z <- pulstran(t, dd, pp, ffs) plot(t, z, type = "l", xlab = "", ylab = "", main = "Custom pulse") par(op) ## ----findpeaks, fig.height=4, fig.width=7------------------------------------- t <- 2 * pi * seq(0, 1,length = 1024) y <- sin(3.14 * t) + 0.5 * cos(6.09 * t) + 0.1 * sin(10.11 * t + 1 / 6) + 0.1 * sin(15.3 * t + 1 / 3) data1 <- abs(y) # Positive values peaks1 <- findpeaks(data1) data2 <- y # Double-sided peaks2 <- findpeaks(data2, DoubleSided = TRUE) peaks3 <- findpeaks (data2, DoubleSided = TRUE, MinPeakHeight = 0.5) op <- par(mfrow=c(1,2)) plot(t, data1, type="l", xlab="", ylab="") points(t[peaks1$loc], peaks1$pks, col = "red", pch = 1) plot(t, data2, type = "l", xlab = "", ylab = "") points(t[peaks2$loc], peaks2$pks, col = "red", pch = 1) points(t[peaks3$loc], peaks3$pks, col = "red", pch = 4) par (op) title("Finding the peaks of smooth data is not a big deal") t <- 2 * pi * seq(0, 1, length = 1024) y <- sin(3.14 * t) + 0.5 * cos(6.09 * t) + 0.1 * sin(10.11 * t + 1 / 6) + 0.1 * sin(15.3 * t + 1 / 3) data <- abs(y + 0.1*rnorm(length(y),1)) # Positive values + noise peaks1 <- findpeaks(data, MinPeakHeight=1) dt <- t[2]-t[1] peaks2 <- findpeaks(data, MinPeakHeight=1, MinPeakDistance=round(0.5/dt)) op <- par(mfrow=c(1,2)) plot(t, data, type="l", xlab="", ylab="") points (t[peaks1$loc],peaks1$pks,col="red", pch=1) plot(t, data, type="l", xlab="", ylab="") points (t[peaks2$loc],peaks2$pks,col="red", pch=1) par (op) title(paste("Noisy data may need tuning of the parameters.\n", "In the 2nd example, MinPeakDistance is used\n", "as a smoother of the peaks")) ## ----fir, fig.height=4, fig.width=7------------------------------------------- ## FIR filter design by windowing # low-pass filter 10 Hz fs = 256 h <- fir1(40, 10/ (fs / 2), "low") freqz(h, fs = fs) # observe the effect of filter length h <- fir1(80, 10/ (fs / 2), "low") freqz(h, fs = fs) # fir2 allows specifying arbitrary frequency responses f <- c(0, 0.3, 0.3, 0.6, 0.6, 1) m <- c(0, 0, 1, 1/2, 0, 0) fh <- freqz(fir2(100, f, m)) op <- par(mfrow = c(1, 2)) plot(f, m, type = "b", ylab = "magnitude", xlab = "Frequency") lines(fh$w / pi, abs(fh$h), col = "blue") legend("topright", legend = c("specified", "actual"), lty = 1, pch = c(1, NA), col = c("black", "blue")) # plot in dB: plot(f, 20*log10(m+1e-5), type = "b", ylab = "dB", xlab = "Frequency") lines(fh$w / pi, 20*log10(abs(fh$h)), col = "blue") par(op) title("specify arbitrary frequency responses with fir2") ## 50 Hz notch filter with remez fs <- 200 nyquist <- fs / 2 f <- c(0, 48.5 / nyquist, 49.5 / nyquist, 50.5 / nyquist, 51.5 / nyquist, 1) a <- c(1, 1, 0, 0, 1, 1) h <- remez(200, f, a) freqz(h, fs = fs) ## ----FIR_delay, fig.height=7, fig.width=7------------------------------------- op <- par(mfrow = c(2, 1)) # design the filter fs = 256 h <- fir1(40, 30/ (fs / 2), "low") # group delay is constant at N/2 gd <- grpdelay(h) plot(gd, ylim = c(0, 40), main = paste("(a) Group delay for FIR filters is constant\n", "(here 40 / 2 = 20)")) # filter electrocardiogram data with added noise data(signals, package = "gsignal") npts <- nrow(signals) ecg <- signals$ecg + 1000 * runif(npts) time <- seq(0, 10, length.out = npts) plot(time, ecg, type = "l", main = "(b) Example ECG signal", xlab = "Time", ylab = "", xlim = c(0,2)) title(ylab = expression(paste("Amplitude (", mu, "V)")), line = 2) f1 <- gsignal::filter(h, ecg) lines(time, f1, col = "red", lwd = 2) delay <- mean(gd$gd) f2 <- c(f1[(delay + 1):npts], rep(NA, delay)) lines(time, f2, col = "blue", lwd = 2) legend("topright", legend = c("Original", "Filtered", "Corrected"), lty = 1, lwd = c(1, 2, 2), col = c("black", "red", "blue")) par(op) ## ----iir, fig.height=7, fig.width=7------------------------------------------- op <- par(mfrow = c(3,1)) # compare Butterworth and Chebyshev filters. bfr <- freqz(butter(5, 0.1)) cfr <- freqz(cheby1(5, .5, 0.1)) plot(bfr$w, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-80, 0), xlab = "Frequency (rad)", ylab = c("dB"), main = "(a) Butterworth and Chebyshev") lines(cfr$w, 20 * log10(abs(cfr$h)), col = "red") legend("topright", legend = c("5th order Butterworth", "5th order Chebyshev"), lty = 1, col = c("black", "red")) # compare Butterworth and elliptic filters. efr <- freqz(ellip(5, 3, 40, 0.1)) plot(bfr$w, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-80, 0), xlab = "Frequency (rad)", ylab = c("dB"), main = "(b) Butterworth and Elliptic") lines(efr$w, 20 * log10(abs(efr$h)), col = "red") legend ("topright", legend = c("5th order Butterworh", "5th order Elliptic"), lty = 1, col = c("black", "red")) # compare type I and type II Chebyshev filters. c1fr <- freqz(cheby1(5, .5, 0.1)) c2fr <- freqz(cheby2(5, 20, 0.1)) plot(c1fr$w, 20 * log10(abs(c1fr$h)), type = "l", ylim = c(-80, 0), xlab = "Frequency (rad)", ylab = c("dB"), main = "(c) Type I and II Chebyshev") lines(c2fr$w, 20 * log10(abs(c2fr$h)), col = "red") legend ("topright", legend = c("5th order Type I", "5th order Type II"), lty = 1, col = c("black", "red")) par(op) ## ----zplane, fig.height=7, fig.width=7---------------------------------------- op <- par(no.readonly = TRUE) n <- layout(matrix(c(1, 2, 3, 3), nrow = 2, byrow = TRUE)) stable <- butter(3, 0.2, "low", output = "Zpg") # artificially adapt pole instable <- stable instable$p[2] <- instable$p[2] - 2 zplane(stable, main = "Stable") zplane(instable, main = "Instable") t <- seq(0, 1, len = 100) x <- sin(2* pi * t * 2.3) + 0.5 * rnorm(length(t)) z1 <- filter(stable, x) z2 <- filter(instable, x) plot(t, x, type = "l", xlab = "", ylab = "") lines(t, z1, col = "green", lwd = 2) lines(t, z2, col = "red") legend("bottomleft", legend = c("Original", "Stable", "Instable"), lty = 1, col = c("black", "green", "red"), ncol = 3) par(op) ## ----IIR_delay, fig.height=7, fig.width=7------------------------------------- op <- par(mfrow = c(2, 1)) ell <- ellip(5, 0.1, 60, 30/(fs/2), "low") ellf <- freqz(ell, fs = fs) argh <- Arg(ellf$h) argh[which(is.na(argh))] <- 0 phase <- unwrap(argh) plot(ellf$w, phase, type = "l", xlab = "Frequency (Hz)", ylab = "Phase", main = paste("30 Hz 5th order elliptical low-pass IIR filter\n", "phase response is not linear")) gd <- grpdelay(ell, fs = fs) plot(gd, main = paste("group delay depends on frequency\n", "mean:", round(mean(gd$gd), 1), "samples")) par(op) ## ----IIR_filtfilt, fig.height=4, fig.width=7---------------------------------- f <- filter(ell, ecg) ff <- filtfilt(ell, ecg) plot(time, ecg, type = "l", xlab = "Time", ylab = "", xlim = c(0,2)) title(ylab = expression(paste("Amplitude (", mu, "V)")), line = 2) lines(time, f, col = "red", lwd = 2) lines(time, ff, col = "blue", lwd = 2) legend("topright", legend = c("Original", "filter()", "filtfilt()"), lty = 1, lwd = c(1, 2, 2), col = c("black", "red", "blue")) ## ----conv1-------------------------------------------------------------------- u <- rep(1, 3) v <- c(1, 1, 0, 0, 0, 1, 1) conv(u, v, "full") conv(u, v, "same") conv(u, v, "valid") conv(v, u, "valid") ## ----conv2, fig.height=7, fig.width=7----------------------------------------- short <- runif(20L) long <- runif(1000L) # convolve two long series ll <- microbenchmark::microbenchmark(conv(long, long), cconv(long, long), fftconv(long, long)) plot1 <- ggplot2::autoplot(ll) # convolve a short and a long series sl <- microbenchmark::microbenchmark(conv(short, long), cconv(short, long), fftconv(short, long)) plot2 <- ggplot2::autoplot(sl) gridExtra::grid.arrange(plot1, plot2, nrow = 2, ncol = 1) ## ----chunks------------------------------------------------------------------- N <- 10000L long <- runif(N) part1 <- long[1:(N / 2)] part2 <- long[((N / 2) + 1):N] b <- c(2, 3) a <- c(1, 0.2) y <- filter(b, a, long) y1 <- filter(b, a, part1, 'zf') y2 <- filter(b, a, part2, y1$zf) yy <- c(y1$y, y2$y) all.equal(y, yy) ## ----zi, fig.height=5, fig.width=7-------------------------------------------- t <- seq(-1, 1, length.out = 201) x <- (sin(2 * pi * 0.75 * t * (1 - t) + 2.1) + 0.1 * sin(2 * pi * 1.25 * t + 1) + 0.18 * cos(2 * pi * 3.85 * t)) h <- butter(3, 0.05) zi <- filter_zi(h) ## alternatively, use: ## lab <- max(length(h$b), length(h$a)) - 1 ## zi <- filtic(h, rep(1, lab), rep(1, lab)) z1 <- filter(h, x) z2 <- filter(h, x, zi * x[1]) plot(t, x, type = "l", xlab ="", ylab = "") lines(t, z1, col = "red") lines(t, z2$y, col = "green") legend("bottomright", legend = c("Original signal", "Filtered without initial conditions", "Filtered with initial conditions"), lty = 1, col = c("black", "red", "green")) ## ----fft_ar, fig.height=7, fig.width=7---------------------------------------- op <- par(mfrow = c(3, 1)) fs <- 200 nsecs <- 10 lx <- fs * nsecs t <- seq(0, nsecs, length.out = lx) # signal of 5 Hz + 12 Hz + noise x <- (sin(2 * pi * 5 * t) + sin(2 * pi * 12 * t) + runif(lx)) plot(t, x, type = "l", xlab = "Time (s)", ylab = "", main = "Original signal") pw <- pwelch(x, window = lx, fs = fs, detrend = "none") plot(pw, xlim = c(0, 20), main = "PSD estimate using FFT") py <- pyulear(x, 30, fs = fs) plot(py, xlim = c(0, 20), main = "PSD estimate using Yule-Walker") par(op) ## ----welch, fig.height=7, fig.width=7----------------------------------------- op <- par(mfrow = c(3, 1)) fs <- 200 nsecs <- 100 lx <- fs * nsecs t <- seq(0, nsecs, length.out = lx) # sine and cosine of signal of 5 Hz noise x1 <- cos(2 * pi * 5 * t) + runif(lx) x2 <- sin(2 * pi * 5 * t) + runif(lx) x <- cbind(x1, x2) pw <- pwelch(x, fs = fs) plot(pw, plot.type = "spectrum", yscale = "dB", xlim = c(0, 50), main = "A sine and a cosine of 5 Hz have the same PSD") legend("topright", legend = c("Cosine", "Sine"), lty = 1:2, col = 1:2) rect(3, -35, 7, -4, border = "red", lwd = 3) plot(pw, plot.type = "phase", xlim = c(0, 50), main = expression(bold(paste("but differ ", pi/2, " radians in phase at 5 Hz")))) rect(3, -pi, 7, pi, border = "red", lwd = 3) plot(pw, plot.type = "coherence", xlim = c(0, 50), main = "leading to coherence ~ 1 at 5 Hz") rect(3, 0, 7, 1, border = "red", lwd = 3) par(op) ## ----specgram, fig.height=7, fig.width=7-------------------------------------- op <- par(mfrow = c(2, 1)) jet <- grDevices::colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) sp <- specgram(chirp(seq(0, 5, by = 1/8000), 200, 2, 500, "logarithmic"), fs = 8000) plot(sp, col = jet(20)) c2w <- grDevices::colorRampPalette(colors = c("red", "white", "blue")) plot(sp, col = c2w(50)) par(op) gsignal/inst/doc/gsignal.html0000644000176200001440000451724514670306232015757 0ustar liggesusers Signal Processing in R

Signal Processing in R

Geert van Boxtel

April 30, 2021

1. Introduction

Most engineers use Matlab (or its open source alternative Octave) to solve their signal processing problems. Languages such as R or Python are not immediately thought of for signal processing, although this has changed a bit in the last few years with the development of the R signal package and Python scipy.signal.

The package gsignal aims to further stimulate the use of R for signal processing tasks. It is ported from the Octave signal package, version 1.4.1 (2019-02-08). The package contains a variety of signal processing tools, such as signal generation and measurement, correlation and convolution, filtering, FIR and IIR filter design, filter analysis and conversion, power spectrum analysis, system identification, decimation and sample rate change, and windowing.

This vignette provides a brief and general overview of some of gsignal’s functions.

library(gsignal)
#> 
#> Attaching package: 'gsignal'
#> The following objects are masked from 'package:stats':
#> 
#>     filter, gaussian, poly

2. Signal generation and measurement

The function pulstran can be used to generate trains of pulses based on samples of a continuous function (which can be user-defined). The following figures show a periodic rectangular pulse, an asymmetric sawtooth pulse, a periodic Gaussian waveform, and a custom pulse train.


op <- par(mfrow = c(2, 2))

## periodic rectangular pulse
t <- seq(0, 60, 1/1e3)
d <- cbind(seq(0, 60, 2), sin(2 * pi * 0.05 * seq(0, 60, 2)))
y <- pulstran(t, d, 'rectpuls')
plot(t, y, type = "l", xlab = "", ylab = "",
     main = "Periodic rectangular pulse")

## assymetric sawtooth waveform
fs <- 1e3
t <- seq(0, 1, 1/fs)
d <- seq(0, 1, 1/3)
x <- tripuls(t, 0.2, -1)
y <- pulstran(t, d, x, fs)
plot(t, y, type = "l", xlab = "", ylab = "",
     main = "Asymmetric sawtooth ")

## Periodic Gaussian waveform
fs <- 1e7
tc <- 0.00025
t <- seq(-tc, tc, 1/fs)
x <- gauspuls(t, 10e3, 0.5)
ts <- seq(0, 0.025, 1/50e3)
d <- cbind(seq(0, 0.025, 1/1e3), sin(2 * pi * 0.1 * (0:25)))
y <- pulstran(ts, d, x, fs)
plot(ts, y, type = "l", xlab = "", ylab = "",
     main = "Gaussian pulse")

## Custom pulse trains
fnx <- function(x, fn) sin(2 * pi * fn * x) * exp(-fn * abs(x))
ffs <- 1000
tp <- seq(0, 1, 1 / ffs)
pp <- fnx(tp, 30)
fs <- 2e3
t <- seq(0, 1.2, 1 / fs)
d <- seq(0, 1, 1/3)
dd <- cbind(d, 4^-d)
z <- pulstran(t, dd, pp, ffs)
plot(t, z, type = "l", xlab = "", ylab = "",
     main = "Custom pulse")


par(op)

A number of waveform generating functions are available, such as chirp, cmorwavf, diric, gauspuls, gmonopuls, mexihat, meyeraux, morlet, rectpuls, sawtooth, square, and tripuls.

The function findpeaks can be used to determine (local) minima and maxima in a signal, as the following figures show.


t <- 2 * pi * seq(0, 1,length = 1024)
y <- sin(3.14 * t) + 0.5 * cos(6.09 * t) +
     0.1 * sin(10.11 * t + 1 / 6) + 0.1 * sin(15.3 * t + 1 / 3)
data1 <- abs(y) # Positive values
peaks1 <- findpeaks(data1)
data2 <- y # Double-sided
peaks2 <- findpeaks(data2, DoubleSided = TRUE)
peaks3 <- findpeaks (data2, DoubleSided = TRUE, MinPeakHeight = 0.5)

op <- par(mfrow=c(1,2))
plot(t, data1, type="l", xlab="", ylab="")
points(t[peaks1$loc], peaks1$pks, col = "red", pch = 1)
plot(t, data2, type = "l", xlab = "", ylab = "")
points(t[peaks2$loc], peaks2$pks, col = "red", pch = 1)
points(t[peaks3$loc], peaks3$pks, col = "red", pch = 4)
par (op)
title("Finding the peaks of smooth data is not a big deal")


t <- 2 * pi * seq(0, 1, length = 1024)
y <- sin(3.14 * t) + 0.5 * cos(6.09 * t) + 0.1 *
     sin(10.11 * t + 1 / 6) + 0.1 * sin(15.3 * t + 1 / 3)
data <- abs(y + 0.1*rnorm(length(y),1))   # Positive values + noise
peaks1 <- findpeaks(data, MinPeakHeight=1)
dt <- t[2]-t[1]
peaks2 <- findpeaks(data, MinPeakHeight=1, MinPeakDistance=round(0.5/dt))
op <- par(mfrow=c(1,2))
plot(t, data, type="l", xlab="", ylab="")
points (t[peaks1$loc],peaks1$pks,col="red", pch=1)
plot(t, data, type="l", xlab="", ylab="")
points (t[peaks2$loc],peaks2$pks,col="red", pch=1)
par (op)
title(paste("Noisy data may need tuning of the parameters.\n",
            "In the 2nd example, MinPeakDistance is used\n",
            "as a smoother of the peaks"))

3. Filter Design

The gsignal package contains functions for designing lowpass, highpass, bandpass, and bandstop filters. Both Finite Impulse Response (FIR) and Infinite Impulse Response (IIR) filters can be designed. The freqz function displays the frequency response’s magnitude and phase of the filter.

FIR filters

A FIR filter is a filter whose impulse response settles to zero in finite time. This is in contrast to IIR filters, which have internal feedback causing them to have an infinitely long impulse response (although usually decaying).

For causal discrete-time FIR filters the output is a weighted sum of the most recent input values. Compared to IIR filters, advantages of FIR filters are they are inherently stable (because there is no feedback that propagates indefinitely), and that they have linear phase (constant across frequencies). The main disadvantage is that they require more computation time to obtain sharp transition bands.

The package gsignal contains various methods to design digital FIR filters. The functions fir1, fir2, and kaiserord use the windowing method, in which a window is applied to the truncated inverse Fourier transform of the filter’s frequency response. The function firls is an extension of the fir1 and fir2 functions that uses a least-squares approach to minimize errors between the specified and the actual frequency response over sub-bands of the frequency range. The Parks-McClellan method using the Remez exchange algorithm for finding an optimal equiripple set of filter coefficients is used by the remez function. The cl2bp function allows designing FIR filters without explicitly defining the transition bands for the magnitude response.

Below are some examples of FIR filter design. The magnitude and the phase of the filter’s frequency response are plotted by the function freqz.


## FIR filter design by windowing

# low-pass filter 10 Hz
fs = 256
h <- fir1(40, 10/ (fs / 2), "low")
freqz(h, fs = fs)

# observe the effect of filter length
h <- fir1(80, 10/ (fs / 2), "low")
freqz(h, fs = fs)


# fir2 allows specifying arbitrary frequency responses
f <- c(0, 0.3, 0.3, 0.6, 0.6, 1)
m <- c(0, 0, 1, 1/2, 0, 0)
fh <- freqz(fir2(100, f, m))
op <- par(mfrow = c(1, 2))
plot(f, m, type = "b", ylab = "magnitude", xlab = "Frequency")
lines(fh$w / pi, abs(fh$h), col = "blue")
legend("topright", legend = c("specified", "actual"), lty = 1,
       pch = c(1, NA), col = c("black", "blue"))
# plot in dB:
plot(f, 20*log10(m+1e-5), type = "b", ylab = "dB", xlab = "Frequency")
lines(fh$w / pi, 20*log10(abs(fh$h)), col = "blue")
par(op)
title("specify arbitrary frequency responses with fir2")


## 50 Hz notch filter with remez
fs <- 200
nyquist <- fs / 2
f <- c(0, 48.5 / nyquist, 49.5 / nyquist, 50.5 / nyquist, 51.5 / nyquist, 1)
a <- c(1, 1, 0, 0, 1, 1)
h <- remez(200, f, a)
freqz(h, fs = fs)

Compensating for filter delay in FIR filters

Filtering causes a delay because weighted samples in the past are used. FIR filters have a linear phase, so in the time domain this delay is constant, namely \(N / 2\), where \(N\) is the filter length (or ‘number of taps’). The function grpdelay can be used to calculate the group delay; see Figure (a) below. Because phase is linear, it is easy to to compensate for the filter delay as shown in Figure (b) below.


op <- par(mfrow = c(2, 1))
# design the filter
fs = 256
h <- fir1(40, 30/ (fs / 2), "low")

# group delay is constant at N/2
gd <- grpdelay(h)
plot(gd, ylim = c(0, 40),
     main = paste("(a) Group delay for FIR filters is constant\n",
                  "(here 40 / 2 = 20)"))

# filter electrocardiogram data with added noise
data(signals, package = "gsignal")
npts <- nrow(signals)
ecg <- signals$ecg + 1000 * runif(npts)
time <- seq(0, 10, length.out = npts)
plot(time, ecg, type = "l", main = "(b) Example ECG signal",
     xlab = "Time", ylab = "", xlim = c(0,2))
title(ylab = expression(paste("Amplitude (", mu, "V)")), line = 2)
f1 <- gsignal::filter(h, ecg)
lines(time, f1, col = "red", lwd = 2)
delay <- mean(gd$gd)
f2 <- c(f1[(delay + 1):npts], rep(NA, delay))
lines(time, f2, col = "blue", lwd = 2)
legend("topright", legend = c("Original", "Filtered", "Corrected"),
       lty = 1, lwd = c(1, 2, 2), col = c("black", "red", "blue"))


par(op)

IIR filters

Infinite Impulse Response, or recursive, filters are an efficient way of achieving a long impulse response by not only using past input samples, but also past output samples. Hence, an element of feedback (recursion) is used. IIR filters are specified by a set of feedback coefficients (usually termed \(a\)), in addition to feedforward coefficients (\(b\)) as used in FIR filters.

Advantages of IIR filters compared to FIR filters are related to their efficiency in implementation. IIR filters usually require (much) fewer filter coefficients, implying a correspondingly fewer number of calculations. On the other hand, the impulse response of IIR filters does not always decay to zero, which may result in filter instability (see the example below). In addition, the phase of IIR filters is not linear but frequency dependent. Forward and reverse filtering (filtfilt) results in zero phase at the expense of additional computing time (there is no free lunch).

Some important types of IIR filters are:

  1. Butterworth filters have frequency response that is as flat as possible in the passband (function butter);
  2. Chebyshev filters are IIR filters having a steeper roll-off than Butterworth filters, and either have a passband ripple (Type I - function cheby1), or a stopband ripple (Type II - function cheby2);
  3. Elliptic filters with equalized ripple (equiripple) behavior in both the passband and the stopband (function ellip);
  4. (Analog) Bessel filters with a maximally linear phase response.

The following figure compare the frequency responses of (a) 5th order Butterworth and Chebyshev filters, (b) 5th order Butterworth and elliptic filters, and (c) type I and type II Chebyshev filters.


op <- par(mfrow = c(3,1))

# compare Butterworth and Chebyshev filters.
bfr <- freqz(butter(5, 0.1))
cfr <- freqz(cheby1(5, .5, 0.1))
plot(bfr$w, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-80, 0),
     xlab = "Frequency (rad)", ylab = c("dB"),
     main = "(a) Butterworth and Chebyshev")
lines(cfr$w, 20 * log10(abs(cfr$h)), col = "red")
legend("topright", legend = c("5th order Butterworth", "5th order Chebyshev"),
       lty = 1, col = c("black", "red"))

# compare Butterworth and elliptic filters.
efr <- freqz(ellip(5, 3, 40, 0.1))
plot(bfr$w, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-80, 0),
    xlab = "Frequency (rad)", ylab = c("dB"),
    main = "(b) Butterworth and Elliptic")
lines(efr$w, 20 * log10(abs(efr$h)), col = "red")
legend ("topright", legend = c("5th order Butterworh", "5th order Elliptic"),
       lty = 1, col = c("black", "red"))

# compare type I and type II Chebyshev filters.
c1fr <- freqz(cheby1(5, .5, 0.1))
c2fr <- freqz(cheby2(5, 20, 0.1))
plot(c1fr$w, 20 * log10(abs(c1fr$h)), type = "l", ylim = c(-80, 0),
     xlab = "Frequency (rad)", ylab = c("dB"),
     main = "(c) Type I and II Chebyshev")
lines(c2fr$w, 20 * log10(abs(c2fr$h)), col = "red")
legend ("topright", legend = c("5th order Type I", "5th order Type II"),
       lty = 1, col = c("black", "red"))


par(op)

Numerical precision and stability

Using IIR filter coefficients \(b, a\) can cause numerical problems. Therefore, IIR filter design functions in gsignal have an output parameter, allowing the filter coefficients to be returned in one of three forms:

  • Arma, a list containing the moving average polynomial (feedforward) coefficients \(b\), and the autoregressive (recursive, feedback) coefficients \(a\);
  • Zpg, a list containing the coefficients in zero-pole-gain form
  • Sos, a list of series second order sections (biquads)

Although the Arma form is default for compatibility reasons, the use of Sos and the accompanying filtering function sosfilt is generally preferred.

A second issue that may occur when using IIR filters, is instability. This may be the result of numerical rounding errors or because too many filter coefficients were used. Pole-Zero Analysis can be useful here. A filter is stable if its impulse response \(h(n)\) decays to 0 when \(n\) increases. In terms of poles and zeros, this is true if all of the filter’s poles are inside the unit circle in the \(z\)-plane (Smith, J.O. (2012)). The package gsignal offers the function zplane that displays a filter’s poles and zeros in the complex \(z\)-plane, as the following figure illustrates. In the figure the ’0’s represent the zeros, and the ’X’s the poles.


op <- par(no.readonly = TRUE)
n <- layout(matrix(c(1, 2, 3, 3), nrow = 2, byrow = TRUE))
stable <- butter(3, 0.2, "low", output = "Zpg")

# artificially adapt pole
instable <- stable
instable$p[2] <- instable$p[2] - 2

zplane(stable, main = "Stable")
zplane(instable, main = "Instable")

t <- seq(0, 1, len = 100)
x <- sin(2* pi * t * 2.3) + 0.5 * rnorm(length(t))
z1 <- filter(stable, x)
z2 <- filter(instable, x)
plot(t, x, type = "l", xlab = "", ylab = "")
lines(t, z1, col = "green", lwd = 2)
lines(t, z2, col = "red")
legend("bottomleft", legend = c("Original", "Stable", "Instable"),
       lty = 1, col = c("black", "green", "red"), ncol = 3)

par(op)

Compensating for filter delay in IIR filters

Because the phase of the frequency response of IIR filters is not linear, the filter delay cannot be easily compensated for as in the FIR case. Recall that the 40-tap 30 Hz low-pass FIR filter used above for filtering the ECG signal had a linear phase and a constant delay of 20 samples. If a 5th order elliptic low-pass filter at 30 Hz is used, it can easily be seen that its phase is not linear (Figure (a) below), and hence the filter delay is dependent of frequency (Figure (b) below). Note that the group delay is defined to be the negative first derivative of the filter’s phase response.

op <- par(mfrow = c(2, 1))
ell <- ellip(5, 0.1, 60, 30/(fs/2), "low")
ellf <- freqz(ell, fs = fs)
argh <- Arg(ellf$h)
argh[which(is.na(argh))] <- 0
phase <- unwrap(argh)
plot(ellf$w, phase, type = "l", xlab = "Frequency (Hz)", ylab = "Phase",
     main = paste("30 Hz 5th order elliptical low-pass IIR filter\n",
                  "phase response is not linear"))
gd <- grpdelay(ell, fs = fs)
#> Warning in grpdelay.default(filt$b, filt$a, ...): setting group delay to 0 at
#> singularity
plot(gd, main = paste("group delay depends on frequency\n",
                      "mean:", round(mean(gd$gd), 1), "samples"))

par(op)

This means that the filter delay cannot be compensated for in the same way as for the FIR filter. An alternative is to use the function filtfilt, which applies forward and backward filtering and thus compensates for the delay, as shown in the figure below.


f <- filter(ell, ecg)
ff <- filtfilt(ell, ecg)
plot(time, ecg, type = "l", xlab = "Time", ylab = "", xlim = c(0,2))
title(ylab = expression(paste("Amplitude (", mu, "V)")), line = 2)
lines(time, f, col = "red", lwd = 2)
lines(time, ff, col = "blue", lwd = 2)
legend("topright", legend = c("Original", "filter()", "filtfilt()"),
       lty = 1, lwd = c(1, 2, 2), col = c("black", "red", "blue"))

4. Filtering and Convolution

The most straightforward way to implement a digital filter is by convolving the input signal with the filter’s impulse response. The package gsignal contains several functions for convolution. The function conv returns the 1-D convolution of two vectors a and b in 3 ‘shapes’; “full”, for which the output vector has a length equal to length(a) + length(b) - 1; “valid”, which only returns the central part of the convolution with an output length of length(a); or “valid”, which returns only those parts of the convolution that are computed without the zero-padded edges (output length max(length(a) - length(b) + 1, 0)). For example:


u <- rep(1, 3)
v <- c(1, 1, 0, 0, 0, 1, 1)
conv(u, v, "full")
#> [1] 1 2 2 1 0 1 2 2 1
conv(u, v, "same")
#> [1] 1 0 1
conv(u, v, "valid")
#> NULL
conv(v, u, "valid")
#> [1] 2 1 0 1 2

Two-dimensional convolution of two matrices can be computed by the conv2 function. In this case, the size of the output matrix is nrow(A) + nrow(B) - 1 by ncol(A) + ncol(B) - 1 for “full” convolution, nrow(A) by ncol(A) for “same”, and max(nrow(A) - nrow(B) + 1, 0) by max(ncol(A) - ncol(B) + 1, 0) for “valid”. The function conv2 is implemented in C++ for speed.

For long series convolution may be sped up by making use of the fact that convolution in the time domain is equivalent to multiplication in the frequency domain. Thus, the two series may be padded to the same length, converted to the frequency domain by FFT, multiplied point-wise, and transformed back to the time domain. The function cconv uses this approach. However, if one series is much longer than the other (as in typical filtering operations), zero-padding the shorter series to the length of the longer series may not be the most efficient method. In such cases, even faster methods like the overlap-add method used by the function fftconv may be useful. That’s the theory at least…


  short <- runif(20L)
  long <- runif(1000L)

  # convolve two long series
  ll <- microbenchmark::microbenchmark(conv(long, long),
                                       cconv(long, long),
                                       fftconv(long, long))
  plot1 <- ggplot2::autoplot(ll)

  # convolve a short and a long series
  sl <- microbenchmark::microbenchmark(conv(short, long),
                                       cconv(short, long),
                                       fftconv(short, long))
  plot2 <- ggplot2::autoplot(sl)
 
  gridExtra::grid.arrange(plot1, plot2, nrow = 2, ncol = 1)

One-dimensional Filtering in gsignal is performed by the function filter. It is a direct form II transposed implementation in C++ of the standard linear time-invariant difference equation \[\sum_{k=0}^{N} a(k+1) y(n-k) + \sum_{k=0}^{M} b(k+1) x(n-k) = 0; 1 \le n \le length(x)\] If a matrix is passed to filter, its columns are filtered. Two-dimensional filtering can be done using filter2. The function fftfilt uses the overlap-add method and FFT convolution for speed (but your mileage may vary), and filtfilt uses forward and backward filtering to avoid filter delay, as used above. If numerical stability of filter coefficients is an issue, filter design using series second order sections and filtering with the function sosfilt may be used.

Filtering long series in chunks

The functions filter and sosfilt can retain the filter state in order to process long data series in chunks. The following piece of code shows how this is done. A long series is split into two parts, which are processed sequentially. In the first call to filter, the final conditions zf are asked to be returned after filtering the first part, which are then passed to the second call to filter as the initial conditions zi for the second part of the series. The two filtered parts can then be concatenated for form the entire filtered series without discontinuities.


N <- 10000L
long <- runif(N)
part1 <- long[1:(N / 2)]
part2 <- long[((N / 2) + 1):N]

b <- c(2, 3)
a <- c(1, 0.2)

y <- filter(b, a, long)
y1 <- filter(b, a, part1, 'zf')
y2 <- filter(b, a, part2, y1$zf)
yy <- c(y1$y, y2$y)
all.equal(y, yy)
#> [1] TRUE

Using initial conditions to avoid filter startup effects

Initial conditions can also be used to set the initial state of the filter so that the output starts at the same value as the first element of the signal to be filtered. The initial conditions for the filter can be computed using the functions filter_zi, or filtic, as shown in the following example.


t <- seq(-1, 1, length.out =  201)
x <- (sin(2 * pi * 0.75 * t * (1 - t) + 2.1)
     + 0.1 * sin(2 * pi * 1.25 * t + 1)
     + 0.18 * cos(2 * pi * 3.85 * t))
h <- butter(3, 0.05)
zi <- filter_zi(h)
## alternatively, use:
## lab <- max(length(h$b), length(h$a)) - 1
## zi <- filtic(h, rep(1, lab), rep(1, lab))
z1 <- filter(h, x)
z2 <- filter(h, x, zi * x[1])
plot(t, x, type = "l", xlab ="", ylab = "")
lines(t, z1, col = "red")
lines(t, z2$y, col = "green")
legend("bottomright", legend = c("Original signal",
       "Filtered without initial conditions",
       "Filtered with initial conditions"),
      lty = 1, col = c("black", "red", "green"))

5. Power spectrum analysis

The power spectral density (PSD) of a time series describes the distribution of power (variance) into frequency components composing that signal. The Fourier Transform is a nonparametric method of decomposing a signal into its frequency spectrum. The functions fft and ifft compute the Discrete Fourier Transform with a fast algorithm, the FFT. A parametric alternative for autoregressive (AR) models is available through the functions ar_psd, pburg, or pyulear. The following figure shows how both FFT- and AR-based methods can discover the periodicities of 5 and 12 Hz in a noisy signal.


op <- par(mfrow = c(3, 1))
fs <- 200
nsecs <- 10
lx <- fs * nsecs
t <- seq(0, nsecs, length.out =  lx)
# signal of 5 Hz + 12 Hz + noise
x <- (sin(2 * pi * 5 * t)
     + sin(2 * pi * 12 * t)
     + runif(lx))
plot(t, x, type = "l", xlab = "Time (s)", ylab = "", main = "Original signal")
pw <- pwelch(x, window = lx, fs = fs, detrend = "none")
plot(pw, xlim = c(0, 20), main = "PSD estimate using FFT")

py <- pyulear(x, 30, fs = fs)
plot(py, xlim = c(0, 20), main = "PSD estimate using Yule-Walker")

par(op)

Welch’s method

Welch (1967) proposed a method to estimate the power spectrum that reduces the variance of the spectrum (at the expense of decreasing frequency resolution - remember, there is no free lunch) by splitting the signal into (usually) overlapping segments and windowing each segment, for instance by a Hamming window. The periodogram is then computed for each segment, and the squared magnitude is computed, which is then averaged for all segments. The spectral density is the mean of the modified periodograms, scaled so that area under the spectrum is the same as the mean square of the data. In case of multivariate signals, cross-spectral density, phase, and coherence are also returned. The input data can be demeaned or detrended, overall or for each segment separately.

The following figure shows two signals, a sine and a cosine of 5 Hz with noise added. Sines and cosines are the same waveforms, the only difference being that a cosine leads the sine wave by an amount of 90\(^{\circ}\) (\(\pi / 2\) radians). Hence, a plot of the PSD should show identical shapes for both signals, but a phase difference at \(\pi / 2\) radians should be visible at 5 Hz, which should also produce a high magnitude squared coherence (near 1) at that frequency (coherence reflects constant phase differences).


op <- par(mfrow = c(3, 1))
fs <- 200
nsecs <- 100
lx <- fs * nsecs
t <- seq(0, nsecs, length.out =  lx)
# sine and cosine of signal of 5 Hz noise
x1 <- cos(2 * pi * 5 * t) + runif(lx)
x2 <- sin(2 * pi * 5 * t) + runif(lx)
x <- cbind(x1, x2)
pw <- pwelch(x, fs = fs)
plot(pw, plot.type = "spectrum", yscale = "dB", xlim = c(0, 50),
    main = "A sine and a cosine of 5 Hz have the same PSD")
legend("topright", legend = c("Cosine", "Sine"), lty = 1:2, col = 1:2)
rect(3, -35, 7, -4, border = "red", lwd = 3)
plot(pw, plot.type = "phase", xlim = c(0, 50),
    main = expression(bold(paste("but differ ", pi/2, " radians in phase at 5 Hz"))))
rect(3, -pi, 7, pi, border = "red", lwd = 3)
plot(pw, plot.type = "coherence", xlim = c(0, 50),
    main = "leading to coherence ~ 1 at 5 Hz")
rect(3, 0, 7, 1, border = "red", lwd = 3)

par(op)

Time-frequency analysis

If your signal’s frequency content changes over time, the power spectrum is of limited use. You might then want to use some form of time-frequency analysis. Specialized R packages exist for wavelet analysis capable of doing time-frequency analysis, such as wavelets, Rwave, and waveslim. gsignal does contain a basic function for computing the discrete wavelet transform (dwt), but is not otherwise specialized for wavelet analysis.

Another way of decomposing a signal both in time and frequency is the Short-Term Fourier Transform, which can be calculated by the function stft. Here, the data to be transformed is broken up into (overlapping) chunks. Each chunk is then Fourier transformed, and added to a record of magnitude and phase for each point in time and frequency. Alternatively, the spectrogram (specgram) in essence does the same - the spectogram is the squared magnitude of the STFT of the signal.

The following figure represents the spectrogram of a chirp signal, which is a signal in which the frequency changes with time. By default, the specgram and stft function produce grayscale plots, but here it is shown how other color palettes can be used.


op <- par(mfrow = c(2, 1))

jet <- grDevices::colorRampPalette(c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F",
                                     "yellow", "#FF7F00", "red", "#7F0000"))
sp <- specgram(chirp(seq(0, 5, by = 1/8000), 200, 2, 500, "logarithmic"), fs = 8000)
plot(sp, col = jet(20))

c2w <- grDevices::colorRampPalette(colors = c("red", "white", "blue"))
plot(sp, col = c2w(50))


par(op)

6. Miscellaneous functions

The package also contains many other functions that may be useful in various signal processing applications.

  • Windowing functions. Window functions are usually bell-shaped functions (although rectangular and triangular shapes are also used), which are multiplied by the signal in order to taper the ends of the signal to zero to reduce spectral leakage. For instance, the pwelch function described above uses a window function (default Hamming) before FFT-ing the segments. The window functions available in gsignal are:

    • Modified Bartlett-Hann (barthannwin)
    • Bartlett (triangular - bartlett)
    • Blackman window (blackman)
    • Blackman-Harris (blackmanharris)
    • Blackman-Nuttall (blackmannuttall)
    • Bohman (bohmanwin)
    • Boxcar (rectangular - boxcar)
    • Chebyshev (chebwin)
    • Flat top (flattopwin)
    • Gaussian (gausswin)
    • Hamming (hamming),
    • Hanning (hanning - alias hann)
    • Kaiser (kaiser)
    • Nuttall (nuttallwin)
    • Parzen (parzenwin)
    • Rectangular (rectwin)
    • Triangular (triang)
    • Tukey (tukeywin)
    • Ultraspherical (ultrwin)
    • Welch (welchwin)

  • Resampling functions. Up- or downsampling signals by an integer factor can be done with upsample and downsample. The function decimate and interp also down- or upsample by an integer factor, but allows specifying an IIR or FIR filter to be applied before resampling to avoid aliasing. The more general function resample allows changing the sampling rate by arbitrary factors, and also takes an impulse response of a FIR filter as an optional argument (if not specified resample will design an optimal filter for you). The function upfirdn performs three operations; it first upsamples the input signal by inserting zeros, then applies a FIR filter, and finally downsamples the signal by throwing away samples. Because this function uses a polyphase implementation for filtering, it is often faster than when filter is used (the resample function uses upfirdn for exactly that reason).

  • Other functions. Various other functions not specifically addressed in this vignette are also included, which can be used for a variety of signal processing operations, such as padding data (pad, prepad, postpad), detrending data (detrend), unwrapping frequency response phase (unwrap), data transformations (cceps, czt dct, dct2, dctmtx, dftmtx, dst, dwt, fftshift, fht, fwht, hilbert, idct, idct2, idst, ifht, ifwht, rceps), polynomial analysis (poly, polystab, residue, residued, residuez, polyreduce, mpoles). Some helper functions (cplxpair, cplxreal, db2pow, pow2db, fftshift, ifftshift, digitrevorder), and other utilities are also included (e.g., buffer, shiftdata, unshiftdata, peak2peak, peak2rms, rms, rssq, clustersegment, fracshift, marcumq, primitive, sampled2continuous, schtrig, upsamplefill, wkeep, zerocrossing)

gsignal/inst/COPYRIGHTS0000644000176200001440000000104314420222025014260 0ustar liggesusersCopyrights ========== Most of the files are translations of files from Octave Forge, and they are copyrighted by various authors and most are licensed under the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. Some files are modifications of the signal package (Version: 0.7-6, Date: 2015-07-29), some of which are of which are copyright (C) 2006, EPRI Solutions, Inc. See each file for a copyright notice and license information. gsignal/README.md0000644000176200001440000000303314670303052013154 0ustar liggesusers # gsignal [![Project Status: Active – The project has reached a stable, usable state and is being actively developed.](https://www.repostatus.org/badges/latest/active.svg)](https://www.repostatus.org/#active) [![CRAN_Status_Badge](https://www.r-pkg.org/badges/version/gsignal)](https://cran.r-project.org/package=gsignal) [![R-CMD-check](https://github.com/gjmvanboxtel/gsignal/workflows/R-CMD-check/badge.svg)](https://github.com/gjmvanboxtel/gsignal/actions) [![](https://cranlogs.r-pkg.org/badges/gsignal)](https://CRAN.R-project.org/package=gsignal) [![license](https://img.shields.io/badge/license-GPL--3-blue.svg)](https://www.gnu.org/licenses/gpl-3.0.en.html) [![codecov](https://codecov.io/github/gjmvanboxtel/gsignal/graph/badge.svg?token=7ZAU9VV73X)](https://app.codecov.io/github/gjmvanboxtel/gsignal) [![R-CMD-check](https://github.com/gjmvanboxtel/gsignal/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/gjmvanboxtel/gsignal/actions/workflows/R-CMD-check.yaml) R implementation of the ‘Octave’ package ‘signal’. ## Installation To install the stable version from CRAN: install.packages("gsignal") The latest development version can be downloaded directly from [GitHub](https://github.com/gjmvanboxtel/gsignal): library(devtools) install_github("gjmvanboxtel/gsignal") An overview of the functions in the package is available in the [vignette](https://CRAN.R-project.org/package=gsignal). gsignal/build/0000755000176200001440000000000014670306232013000 5ustar liggesusersgsignal/build/vignette.rds0000644000176200001440000000032414670306232015336 0ustar liggesusersmP0l>@MLH<|Ⅰ TlRiI7\\63G9J7C`DԼTDYUX4 aierfkkܚJX75#|E\HZ1mW13YׯzY=Z͌9$႙wϼn'c3OOmdf~A]{oC-gsignal/build/partial.rdb0000644000176200001440000000007514670306211015124 0ustar liggesusersb```b`aad`b1 H020piּb C"he7gsignal/man/0000755000176200001440000000000014661623627012466 5ustar liggesusersgsignal/man/conv.Rd0000644000176200001440000000415014420222025013676 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/conv.R \name{conv} \alias{conv} \title{Convolution and polynomial multiplication} \usage{ conv(a, b, shape = c("full", "same", "valid")) } \arguments{ \item{a, b}{Input, coerced to vectors, can be different lengths or data types.} \item{shape}{Subsection of convolution, partially matched to \code{"full"} (full convolution - default), \code{"same"} (central part of the convolution of the same size as \code{a}), or \code{"valid"} (only those parts of the convolution that are computed without the zero-padded edges)} } \value{ Output vector with length equal to \code{length (a) + length (b) - 1}. When the parameter \code{shape} is set to \code{"valid"}, the length of the output is \code{max(length(a) - length(b) + 1, 0)}, except when length(b) is zero. In that case, the length of the output vector equals \code{length(a)}. When \code{a} and \code{b} are the coefficient vectors of two polynomials, the convolution represents the coefficient vector of the product polynomial. } \description{ Convolve two vectors \code{a} and \code{b}. } \details{ The convolution of two vectors, \code{a} and \code{b}, represents the area of overlap under the points as \code{B} slides across \code{a}. Algebraically, convolution is the same operation as multiplying polynomials whose coefficients are the elements of \code{a} and \code{b}. The function \code{conv} uses the \code{\link{filter}} function, NOT \code{fft}, which may be faster for large vectors. } \examples{ u <- rep(1L, 3) v <- c(1, 1, 0, 0, 0, 1, 1) w <- conv(u, v) ## Create vectors u and v containing the coefficients of the polynomials ## x^2 + 1 and 2x + 7. u <- c(1, 0, 1) v <- c(2, 7) ## Use convolution to multiply the polynomials. w <- conv(u, v) ## w contains the polynomial coefficients for 2x^3 + 7x^2 + 2x + 7. ## Central part of convolution u <- c(-1, 2, 3, -2, 0, 1, 2) v <- c(2, 4, -1, 1) w <- conv(u, v, 'same') } \author{ Tony Richardson, \email{arichard@stark.cc.oh.us}, adapted by John W. Eaton.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/Ma.Rd0000644000176200001440000000101114420222025013257 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Ma.R \name{Ma} \alias{Ma} \title{Moving average (MA) model} \usage{ Ma(b) } \arguments{ \item{b}{moving average (MA) polynomial coefficients.} } \value{ A list of class \code{Ma} with the polynomial coefficients } \description{ Create an MA model representing a filter or system model } \examples{ f <- Ma(b = c(1, 2, 1) / 3) freqz(f) zplane(f) } \seealso{ See also \code{\link{Arma}} } \author{ Tom Short, \email{tshort@eprisolutions.com} } gsignal/man/upsample.Rd0000644000176200001440000000207514420222025014563 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/upsample.R \name{upsample} \alias{upsample} \title{Increase sample rate} \usage{ upsample(x, n, phase = 0) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{n}{upsampling factor, specified as a positive integer. The signal is upsampled by inserting \code{n - 1} zeros between samples.} \item{phase}{offset, specified as a positive integer from \code{0} to \code{n - 1}. Default: 0.} } \value{ Upsampled signal, returned as a vector or matrix. } \description{ Upsample a signal by an integer factor. } \examples{ x <- seq_len(4) u <- upsample(x, 3) u <- upsample(x, 3, 2) x <- matrix(seq_len(6), 3, byrow = TRUE) u <- upsample(x, 3) } \seealso{ \code{\link{downsample}}, \code{\link{interp}}, \code{\link{decimate}}, \code{\link{resample}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/idst.Rd0000644000176200001440000000211614420222025013674 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/idst.R \name{idst} \alias{idst} \title{Inverse Discrete Sine Transform} \usage{ idst(x, n = NROW(x)) } \arguments{ \item{x}{input discrete cosine transform, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{n}{transform length, specified as a positive integer scalar. Default: \code{NROW(x)}.} } \value{ Inverse discrete sine transform, returned as a vector or matrix. } \description{ Compute the inverse discrete sine transform of a signal. } \details{ The discrete sine transform (DST) is closely related to the discrete Fourier transform. but using a purely real matrix. It is equivalent to the imaginary parts of a DFT of roughly twice the length. } \examples{ x <- seq_len(100) + 50 * cos(seq_len(100) * 2 * pi / 40) X <- dst(x) xx <- idst(X) all.equal(x, xx) } \seealso{ \code{\link{dst}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/xcov.Rd0000644000176200001440000000506014420222025013711 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/xcov.R \name{xcov} \alias{xcov} \title{Cross-covariance} \usage{ xcov( x, y = NULL, maxlag = if (is.matrix(x)) nrow(x) - 1 else max(length(x), length(y)) - 1, scale = c("none", "biased", "unbiased", "coeff") ) } \arguments{ \item{x}{Input, numeric or complex vector or matrix. Must not be missing.} \item{y}{Input, numeric or complex vector data. If \code{x} is a matrix (not a vector), \code{y} must be omitted. \code{y} may be omitted if \code{x} is a vector; in this case \code{xcov} estimates the autocovariance of \code{x}.} \item{maxlag}{Integer scalar. Maximum covariance lag. If omitted, the default value is \code{N-1}, where \code{N} is the greater of the lengths of \code{x} and \code{y} or, if \code{x} is a matrix, the number of rows in \code{x}.} \item{scale}{Character string. Specifies the type of scaling applied to the covariation vector (or matrix). matched to one of: \describe{ \item{"none"}{return the unscaled covariance, C} \item{"biased"}{return the biased average, C/N} \item{"unbiased"}{return the unbiased average, C(k)/(N-|k|)} \item{"coeff"}{return C/(covariance at lag 0)}, where \code{k} is the lag, and \code{N} is the length of \code{x} } If omitted, the default value is \code{"none"}. If \code{y} is supplied but does not have the same length as \code{x}, scale must be \code{"none"}.} } \value{ A list containing the following variables: \describe{ \item{C}{array of covariance estimates} \item{lags}{vector of covariance lags \code{[-maxlag:maxlag]}} } The array of covariance estimates has one of the following forms: \enumerate{ \item Cross-covariance estimate if X and Y are vectors. \item Autocovariance estimate if is a vector and Y is omitted. \item If \code{x} is a matrix, \code{C} is a matrix containing the cross-covariance estimates of each column with every other column. Lag varies with the first index so that \code{C} has \code{2 * maxlag + 1} rows and \eqn{P^2} columns where \code{P} is the number of columns in \code{x}. } } \description{ Compute covariance at various lags (= correlation(x-mean(x), y-mean(y))). } \examples{ \donttest{ N <- 128 fs <- 5 t <- seq(0, 1, length.out = N) x <- sin(2 * pi * fs * t) + runif(N) cl <- xcov(x, maxlag = 20, scale = 'coeff') plot (cl$lags, cl$C, type = "h", xlab = "", ylab = "") points (cl$lags, cl$C) abline(h = 0) } } \seealso{ \code{\link{xcorr}}. } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/sampled2continuous.Rd0000644000176200001440000000325414420222025016573 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sampled2continuous.R \name{sampled2continuous} \alias{sampled2continuous} \title{Signal reconstruction} \usage{ sampled2continuous(xn, fs, t) } \arguments{ \item{xn}{the sampled input signal, specified as a vector} \item{fs}{sampling frequency in Hz used in collecting \code{x}, specified as a positive scalar value. Default: 1} \item{t}{time points at which data is to be reconstructed, specified as a vector relative to \code{x[0]} (not real time).} } \value{ Reconstructed signal x(t), returned as a vector. } \description{ Analog signal reconstruction from discrete samples. } \details{ Given a discrete signal x[n] sampled with a frequency of \code{fs} Hz, this function reconstruct the original analog signal x(t) at time points \code{t}. The function can be used, for instance, to calculate sampling rate effects on aliasing. } \examples{ # 'analog' signal: 3 Hz cosine t <- seq(0, 1, length.out = 100) xt <- cos(3 * 2 * pi * t) plot(t, xt, type = "l", xlab = "", ylab = "", ylim = c(-1, 1.2)) # 'sample' it at 4 Hz to simulate aliasing fs <- 4 n <- ceiling(length(t) / fs) xn <- xt[seq(ceiling(n / 2), length(t), n)] s4 <- sampled2continuous(xn, fs, t) lines(t, s4, col = "red") # 'sample' it > 6 Hz to avoid aliasing fs <- 7 n <- ceiling(length(t) / fs) xn <- xt[seq(ceiling(n / 2), length(t), n)] s7 <- sampled2continuous(xn, fs, t) lines(t, s7, col = "green") legend("topright", legend = c("original", "aliased", "non-aliased"), lty = 1, col = c("black", "red", "green")) } \author{ Muthiah Annamalai, \email{muthiah.annamalai@uta.edu}. Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/blackman.Rd0000644000176200001440000000250414420222025014502 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/blackman.R \name{blackman} \alias{blackman} \title{Blackman window} \usage{ blackman(n, method = c("symmetric", "periodic")) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{method}{Character string. Window sampling method, specified as: \describe{ \item{"symmetric" (Default)}{Use this option when using windows for filter design.} \item{"periodic"}{This option is useful for spectral analysis because it enables a windowed signal to have the perfect periodic extension implicit in the discrete Fourier transform. When "periodic" is specified, the function computes a window of length \code{n + 1} and returns the first \code{n} points.} }} } \value{ Blackman window, returned as a vector. } \description{ Return the filter coefficients of a Blackman window. } \details{ The Blackman window is a member of the family of cosine sum windows. } \examples{ h <- blackman(64) plot (h, type = "l", xlab = "Samples", ylab =" Amplitude") bs = blackman(64,'symmetric') bp = blackman(63,'periodic') plot (bs, type = "l", xlab = "Samples", ylab =" Amplitude") lines(bp, col="red") } \author{ Andreas Weingessel, \email{Andreas.Weingessel@ci.tuwien.ac.at}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/residue.Rd0000644000176200001440000000302714420222025014373 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/residue.R \name{residue} \alias{residue} \alias{rresidue} \title{Partial fraction expansion} \usage{ residue(b, a, tol = 0.001) rresidue(r, p, k, tol = 0.001) } \arguments{ \item{b}{coefficients of numerator polynomial} \item{a}{coefficients of denominator polynomial} \item{tol}{tolerance. Default: 0.001} \item{r}{residues of partial fraction expansion} \item{p}{poles of partial fraction expansion} \item{k}{direct term} } \value{ For \code{residue}, a list containing \code{r}, \code{p} and \code{k}. For \code{rresidue}, a list containing \code{b} and \code{a}. } \description{ Finds the residues, poles, and direct term of a Partial Fraction Expansion of the ratio of two polynomials. } \details{ The call \code{res <- residue(b, a)} computes the partial fraction expansion for the quotient of the polynomials, \code{b} and \code{a}. The call \code{res <- rresidue(r, p, k)} performs the inverse operation and computes the reconstituted quotient of polynomials, b(s) / a(s), from the partial fraction expansion; represented by the residues, poles, and a direct polynomial specified by \code{r}, \code{p} and \code{k}, and the pole multiplicity \code{e}. } \examples{ b <- c(-4, 8) a <- c(1, 6, 8) rpk <- residue(b, a) ba <- rresidue(rpk$r, rpk$p, rpk$k) } \author{ Tony Richardson, \email{arichard@stark.cc.oh.us},\cr Ben Abbott, \email{bpabbott@mac.com},\cr adapted by John W. Eaton.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com} } gsignal/man/tukeywin.Rd0000644000176200001440000000343614420222025014616 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tukeywin.R \name{tukeywin} \alias{tukeywin} \title{Tukey (tapered cosine) window} \usage{ tukeywin(n, r = 1/2) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{r}{Cosine fraction, specified as a real scalar. The Tukey window is a rectangular window with the first and last \code{r / 2} percent of the samples equal to parts of a cosine. For example, setting \code{r = 0.5} (default) produces a Tukey window where 1/2 of the entire window length consists of segments of a phase-shifted cosine with period 2r = 1. If you specify r <= 0, an n-point rectangular window is returned. If you specify r >= 1, an n-point von Hann window is returned.} } \value{ Tukey window, returned as a vector. } \description{ Return the filter coefficients of a Tukey window (also known as the cosine-tapered window) of length \code{n}. } \details{ The Tukey window, also known as the tapered cosine window, can be regarded as a cosine lobe that is convolved with a rectangular window. \code{r} defines the ratio between the constant section and and the cosine section. It has to be between 0 and 1. The function returns a Hann window for \code{r} equal to 1 and a rectangular window for \code{r} equal to 0. } \examples{ n <- 128 t0 <- tukeywin(n, 0) # Equivalent to a rectangular window t25 <- tukeywin(n, 0.25) t5 <- tukeywin(n) # default r = 0.5 t75 <- tukeywin(n, 0.75) t1 <- tukeywin(n, 1) # Equivalent to a Hann window plot(t0, type = "l", xlab = "Samples", ylab =" Amplitude", ylim=c(0,1.2)) lines(t25, col = 2) lines(t5, col = 3) lines(t75, col = 4) lines(t1, col = 5) } \author{ Laurent Mazet, \email{mazet@crm.mot.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/upsamplefill.Rd0000644000176200001440000000206514420222025015431 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/upsamplefill.R \name{upsamplefill} \alias{upsamplefill} \title{Upsample and Fill} \usage{ upsamplefill(x, v, copy = FALSE) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{v}{vector of values to be placed between the elements of \code{x}.} \item{copy}{logical. If TRUE then \code{v} should be a scalar (\code{length(v) == 1)} and each value in \code{x} are repeated \code{v} times. If FALSE (default), the values in the vector \code{v} are placed between the elements of \code{x}.} } \value{ upsampled vector or matrix } \description{ Upsample and fill with given values or copies of the vector elements. } \examples{ u <- upsamplefill(diag(2), 2, TRUE) u <- upsamplefill(diag(2), rep(-1, 3)) } \seealso{ \code{\link{upsample}} } \author{ Juan Pablo Carbajal, \email{carbajal@ifi.uzh.ch}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/dctmtx.Rd0000644000176200001440000000303214666070241014247 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dctmtx.R \name{dctmtx} \alias{dctmtx} \title{Discrete Cosine Transform Matrix} \usage{ dctmtx(n) } \arguments{ \item{n}{Size of DCT matrix, specified as a positive integer.} } \value{ Discrete cosine transform, returned as a vector or matrix. } \description{ Compute the discrete cosine transform matrix. } \details{ A DCT transformation matrix is useful for doing things like JPEG image compression, in which an 8x8 DCT matrix is applied to non-overlapping blocks throughout an image and only a sub-block on the top left of each block is kept. During restoration, the remainder of the block is filled with zeros and the inverse transform is applied to the block. The two-dimensional DCT of A can be computed as \code{D \%*\% A \%*\% t(D)}. This computation is sometimes faster than using \code{dct2}, especially if you are computing a large number of small DCTs, because D needs to be determined only once. For example, in JPEG compression, the DCT of each 8-by-8 block is computed. To perform this computation, use \code{dctmtx} to determine D of input image A, and then calculate each DCT using \code{D \%*\% A \%*\% t(D)} (where A is each 8-by-8 block). This is faster than calling \code{dct2} for each individual block. } \examples{ D <- dctmtx(8) } \seealso{ \code{\link{dct}}, \code{\link{dct2}}, \code{\link{idct}}, \code{\link{idct2}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/mexihat.Rd0000644000176200001440000000312614420222025014372 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mexihat.R \name{mexihat} \alias{mexihat} \title{Mexicat Hat} \usage{ mexihat(lb = -5, ub = 5, n = 1000) } \arguments{ \item{lb, ub}{Lower and upper bounds of the interval to evaluate the wavelet on. Default: -5 to 5.} \item{n}{Number of points on the grid between \code{lb} and \code{ub} (length of the wavelet). Default: 1000.} } \value{ A list containing 2 variables; \code{x}, the grid on which the complex Mexican Hat wavelet was evaluated, and \code{psi} (\eqn{\Psi}), the evaluated wavelet on the grid \code{x}. } \description{ Generate a Mexican Hat (Ricker) wavelet sampled on a regular grid. } \details{ The Mexican Hat or Ricker wavelet is the negative normalized second derivative of a Gaussian function, i.e., up to scale and normalization, the second Hermite function. It is a special case of the family of continuous wavelets (wavelets used in a continuous wavelet transform) known as Hermitian wavelets. The Ricker wavelet is frequently employed to model seismic data, and as a broad spectrum source term in computational electrodynamics. It is usually only referred to as the Mexican hat wavelet in the Americas, due to taking the shape of a sombrero when used as a 2D image processing kernel. It is also known as the Marr wavelet (source: Wikipedia) } \examples{ mh <- mexihat(-5, 5, 1000) plot(mh$x, mh$psi, type="l", main = "Mexican Hat Wavelet", xlab = "", ylab = "") } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/meyeraux.Rd0000644000176200001440000000222014420222025014564 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/meyeraux.R \name{meyeraux} \alias{meyeraux} \title{Meyer wavelet auxiliary function} \usage{ meyeraux(x) } \arguments{ \item{x}{Input array, specified as a real scalar, vector, matrix, or multidimensional array.} } \value{ Output array, returned as a real-valued scalar, vector, matrix, or multidimensional array of the same size as x. } \description{ Compute the Meyer wavelet auxiliary function. } \details{ The code \code{y = meyeraux(x)} returns values of the auxiliary function used for Meyer wavelet generation evaluated at the elements of \code{x}. The input \code{x} is a vector or matrix of real values. The function is \deqn{y = 35x^{4} - 84x^{5} + 70x^{6} - 20x^{7}.} \code{x} and \code{y} have the same dimensions. The range of \code{meyeraux} is the closed interval c(0, 1). } \examples{ x <- seq(0, 1, length.out = 100) y <- meyeraux(x) plot(x, y, type="l", main = "Meyer wavelet auxiliary function", xlab = "", ylab = "") } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/cpsd.Rd0000644000176200001440000001033014420222025013657 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cpsd.R \name{cpsd} \alias{cpsd} \alias{csd} \title{Cross power spectral density} \usage{ cpsd( x, window = nextpow2(sqrt(NROW(x))), overlap = 0.5, nfft = ifelse(isScalar(window), window, length(window)), fs = 1, detrend = c("long-mean", "short-mean", "long-linear", "short-linear", "none") ) csd( x, window = nextpow2(sqrt(NROW(x))), overlap = 0.5, nfft = ifelse(isScalar(window), window, length(window)), fs = 1, detrend = c("long-mean", "short-mean", "long-linear", "short-linear", "none") ) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{window}{If \code{window} is a vector, each segment has the same length as \code{window} and is multiplied by \code{window} before (optional) zero-padding and calculation of its periodogram. If \code{window} is a scalar, each segment has a length of \code{window} and a Hamming window is used. Default: \code{nextpow2(sqrt(length(x)))} (the square root of the length of \code{x} rounded up to the next power of two). The window length must be larger than 3.} \item{overlap}{segment overlap, specified as a numeric value expressed as a multiple of window or segment length. 0 <= overlap < 1. Default: 0.5.} \item{nfft}{Length of FFT, specified as an integer scalar. The default is the length of the \code{window} vector or has the same value as the scalar \code{window} argument. If \code{nfft} is larger than the segment length, (seg_len), the data segment is padded \code{nfft - seg_len} zeros. The default is no padding. Nfft values smaller than the length of the data segment (or window) are ignored. Note that the use of padding to increase the frequency resolution of the spectral estimate is controversial.} \item{fs}{sampling frequency (Hertz), specified as a positive scalar. Default: 1.} \item{detrend}{character string specifying detrending option; one of: \describe{ \item{\code{"long-mean"}}{remove the mean from the data before splitting into segments (default)} \item{\code{"short-mean"}}{remove the mean value of each segment} \item{\code{"long-linear"}}{remove linear trend from the data before splitting into segments} \item{\code{"short-linear"}}{remove linear trend from each segment} \item{\code{"none"}}{no detrending} }} } \value{ A list containing the following elements: \describe{ \item{\code{freq}}{vector of frequencies at which the spectral variables are estimated. If \code{x} is numeric, power from negative frequencies is added to the positive side of the spectrum, but not at zero or Nyquist (fs/2) frequencies. This keeps power equal in time and spectral domains. If \code{x} is complex, then the whole frequency range is returned.} \item{\code{cross}}{NULL for univariate series. For multivariate series, a matrix containing the squared coherence between different series. Column \eqn{i + (j - 1) * (j - 2)/2 } of \code{coh} contains the cross-spectral estimates between columns \eqn{i} and \eqn{j} of \eqn{x}, where \eqn{i < j}.} } } \description{ Estimates the cross power spectral density (CPSD) of discrete-time signals. } \details{ \code{cpsd} estimates the cross power spectral density function using Welch’s overlapped averaged periodogram method [1]. } \note{ The function \code{cpsd} (and its deprecated alias \code{csd}) is a wrapper for the function \code{pwelch}, which is more complete and more flexible. } \examples{ fs <- 1000 f <- 250 t <- seq(0, 1 - 1/fs, 1/fs) s1 <- sin(2 * pi * f * t) + runif(length(t)) s2 <- sin(2 * pi * f * t - pi / 3) + runif(length(t)) rv <- cpsd(cbind(s1, s2), fs = fs) plot(rv$freq, 10 * log10(rv$cross), type="l", xlab = "Frequency", ylab = "Cross Spectral Density (dB)") } \references{ [1] Welch, P.D. (1967). The use of Fast Fourier Transform for the estimation of power spectra: A method based on time averaging over short, modified periodograms. IEEE Transactions on Audio and Electroacoustics, AU-15 (2): 70–73.\cr } \author{ Peter V. Lanspeary, \email{pvl@mecheng.adelaide.edu.au}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/digitrevorder.Rd0000644000176200001440000000254514420222025015610 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/digitrevorder.R \name{digitrevorder} \alias{digitrevorder} \title{Permute input to digit-reversed order} \usage{ digitrevorder(x, r, index.return = FALSE) } \arguments{ \item{x}{input data, specified as a vector. The length of \code{x} must be an integer power of \code{r}.} \item{r}{radix base used for the number conversion, which can be any integer from 2 to 36. The elements of \code{x} are converted to radix \code{r} and reversed.} \item{index.return}{logical indicating if the ordering index vector should be returned as well. Default \code{FALSE}.} } \value{ The digit-reversed input vector. If \code{index.return = TRUE}, then a list containing the digit-reversed input vector (\code{y}, and the digit-reversed indices (\code{i}). } \description{ Reorder the elements of the input vector in digit-reversed order. } \details{ This function is useful for pre-ordering a vector of filter coefficients for use in frequency-domain filtering algorithms, in which the fft and ifft transforms are computed without digit-reversed ordering for improved run-time efficiency. } \examples{ res <- digitrevorder(0:8, 3) } \seealso{ \code{\link{bitrevorder}}, \code{\link{fft}}, \code{\link{ifft}} } \author{ Mike Miller.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/shanwavf.Rd0000644000176200001440000000313514420222025014550 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shanwavf.R \name{shanwavf} \alias{shanwavf} \title{Complex Shannon Wavelet} \usage{ shanwavf(lb = -8, ub = 8, n = 1000, fb = 5, fc = 1) } \arguments{ \item{lb, ub}{Lower and upper bounds of the interval to evaluate the waveform on. Default: -8 to 8.} \item{n}{Number of points on the grid between \code{lb} and \code{ub} (length of the wavelet). Default: 1000.} \item{fb}{Time-decay parameter of the wavelet (bandwidth in the frequency domain). Must be a positive scalar. Default: 5.} \item{fc}{Center frequency of the wavelet. Must be a positive scalar. Default: 1.} } \value{ A list containing 2 variables; \code{x}, the grid on which the complex Shannon wavelet was evaluated, and \code{psi} (\eqn{\Psi}), the evaluated wavelet on the grid \code{x}. } \description{ Compute the Complex Shannon wavelet. } \details{ The complex Shannon wavelet is defined by a bandwidth parameter \code{fb}, a wavelet center frequency \code{fc}, and the expression \deqn{\psi(x) = (fb^{0.5} * (sinc(fb * x) * e^{2 * 1i * pi * fc * x}))} on an \code{n}-point regular grid in the interval of \code{lb} to \code{ub}. } \examples{ fb <- 1 fc <- 1.5 lb <- -20 ub <- 20 n <- 1000 sw <- shanwavf(lb, ub, n, fb, fc) op <- par(mfrow = c(2,1)) plot(sw$x, Re(sw$psi), type="l", main = "Complex Shannon Wavelet", xlab = "real part", ylab = "") plot(sw$x, Im(sw$psi), type="l", xlab = "imaginary part", ylab = "") par(op) } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/dct2.Rd0000644000176200001440000000233514420222025013570 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dct2.R \name{dct2} \alias{dct2} \title{2-D Discrete Cosine Transform} \usage{ dct2(x, m = NROW(x), n = NCOL(x)) } \arguments{ \item{x}{2-D numeric matrix} \item{m}{Number of rows, specified as a positive integer. \code{dct2} pads or truncates \code{x} so that is has \code{m} rows. Default: \code{NROW(x)}.} \item{n}{Number of columns, specified as a positive integer. \code{dct2} pads or truncates \code{x} so that is has \code{n} columns. Default: \code{NCOL(x)}.} } \value{ \code{m}-by-\code{n} numeric discrete cosine transformed matrix. } \description{ Compute the two-dimensional discrete cosine transform of a matrix. } \details{ The discrete cosine transform (DCT) is closely related to the discrete Fourier transform. It is a separable linear transformation; that is, the two-dimensional transform is equivalent to a one-dimensional DCT performed along a single dimension followed by a one-dimensional DCT in the other dimension. } \examples{ A <- matrix(runif(100), 10, 10) B <- dct2(A) } \seealso{ \code{\link{idct2}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/parzenwin.Rd0000644000176200001440000000140514420222025014746 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/parzenwin.R \name{parzenwin} \alias{parzenwin} \title{Parzen (de la Vallée Poussin) window} \usage{ parzenwin(n) } \arguments{ \item{n}{Window length, specified as a positive integer.} } \value{ Parzen window, returned as a vector. } \description{ Return the filter coefficients of a Parzen window of length \code{n}. } \details{ Parzen windows are piecewise-cubic approximations of Gaussian windows. } \examples{ p <- parzenwin(64) g <- gausswin(64) plot (p, type = "l", xlab = "Samples", ylab =" Amplitude", ylim = c(0, 1)) lines(g, col = "red") } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/fwht.Rd0000644000176200001440000000322314420222025013701 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fwht.R \name{ifwht} \alias{ifwht} \alias{fwht} \title{Fast Walsh-Hadamard Transform} \usage{ ifwht(x, n = NROW(x), ordering = c("sequency", "hadamard", "dyadic")) fwht(x, n = NROW(x), ordering = c("sequency", "hadamard", "dyadic")) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal. \code{fwht} operates only on signals with length equal to a power of 2. If the length of \code{x} is less than a power of 2, its length is padded with zeros to the next greater power of two before processing.} \item{n}{transform length, specified as a positive integer scalar. Default: \code{NROW(x)}.} \item{ordering}{order of the Walsh-Hadamard transform coefficients, one of: \describe{ \item{"sequency"}{(Default) Coefficients in order of increasing sequency value, where each row has an additional zero crossing.} \item{"hadamard"}{Coefficients in normal Hadamard order} \item{"dyadic"}{Coefficients in Gray code order, where a single bit change occurs from one coefficient to the next} }} } \value{ (Inverse) Fast Walsh Hadamard transform, returned as a vector or matrix. } \description{ Compute the (inverse) Fast Walsh-Hadamard transform of a signal. } \examples{ x <- c(19, -1, 11, -9, -7, 13, -15, 5) X <- fwht(x) all.equal(x, ifwht(X)) } \references{ \url{https://en.wikipedia.org/wiki/Hadamard_transform} \url{https://en.wikipedia.org/wiki/Fast_Walsh-Hadamard_transform} } \author{ Mike Miller.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/filter_zi.Rd0000644000176200001440000000466214663324252014746 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/filter_zi.R \name{filter_zi} \alias{filter_zi} \alias{filter_zi.default} \alias{filter_zi.Arma} \alias{filter_zi.Ma} \alias{filter_zi.Sos} \alias{filter_zi.Zpg} \title{Filter initial conditions} \usage{ filter_zi(filt, ...) \method{filter_zi}{default}(filt, a, ...) \method{filter_zi}{Arma}(filt, ...) \method{filter_zi}{Ma}(filt, ...) \method{filter_zi}{Sos}(filt, ...) \method{filter_zi}{Zpg}(filt, ...) } \arguments{ \item{filt}{For the default case, the moving-average coefficients of an ARMA filter (normally called \code{b}), specified as a vector.} \item{...}{additional arguments (ignored).} \item{a}{the autoregressive (recursive) coefficients of an ARMA filter, specified as a vector.} } \value{ The initial state for the filter, returned as a vector. } \description{ Construct initial conditions for a filter } \details{ This function computes an initial state for the filter function that corresponds to the steady state of the step response. In other words, it finds the initial condition for which the response to an input of all ones is a constant. Therefore, the results returned by this function can also be obtained using the function \code{\link{filtic}} by setting \code{x} and \code{y} to all 1s (see the examples). A typical use of this function is to set the initial state so that the output of the filter starts at the same value as the first element of the signal to be filtered. } \examples{ ## taken from Python scipy.signal.lfilter_zi documentation h <- butter(5, 0.25) zi <- filter_zi(h) y <- filter(h, rep(1, 10), zi) ## output is all 1, as expected. y2 <- filter(h, rep(1, 10)) ## if the zi argument is not given, the output ## does not return the final conditions x <- c(0.5, 0.5, 0.5, 0.0, 0.0, 0.0, 0.0) y <- filter(h, x, zi = zi*x[1]) ## Note that the zi argument to filter was computed using ## filter_zi and scaled by x[1]. Then the output y has no ## transient until the input drops from 0.5 to 0.0. ## obtain the same results with filtic lab <- max(length(h$b), length(h$a)) - 1 ic <- filtic(h, rep(1, lab), rep(1, lab)) all.equal(zi, ic) } \references{ Gustafsson, F. (1996). Determining the initial states in forward-backward filtering. IEEE Transactions on Signal Processing, 44(4), 988 - 992. } \seealso{ \code{\link{filtic}} } \author{ Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}, converted to R from Python scipy.signal.lfilter_zi. } gsignal/man/hann.Rd0000644000176200001440000000302214420222025013652 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hanning.R \name{hann} \alias{hann} \alias{hanning} \title{Hann window} \usage{ hann(n, method = c("symmetric", "periodic")) hanning(n, method = c("symmetric", "periodic")) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{method}{Character string. Window sampling method, specified as: \describe{ \item{"symmetric"}{(Default). Use this option when using windows for filter design.} \item{"periodic"}{This option is useful for spectral analysis because it enables a windowed signal to have the perfect periodic extension implicit in the discrete Fourier transform. When \code{"periodic"} is specified, the function computes a window of length \code{n + 1} and returns the first \code{n} points.} }} } \value{ Hann window, returned as a vector. } \description{ Return the filter coefficients of a Hann window of length \code{n}. } \details{ The Hann window is a member of the family of cosine sum windows. It was named after Julius von Hann, and is sometimes referred to as Hanning, presumably due to its linguistic and formulaic similarities to Hamming window. } \examples{ h <- hann(64) plot (h, type = "l", xlab = "Samples", ylab =" Amplitude") hs = hann(64,'symmetric') hp = hann(63,'periodic') plot (hs, type = "l", xlab = "Samples", ylab =" Amplitude") lines(hp, col="red") } \author{ Andreas Weingessel, \email{Andreas.Weingessel@ci.tuwien.ac.at}.\cr Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/arburg.Rd0000644000176200001440000000726614420222025014226 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/arburg.R \name{arburg} \alias{arburg} \title{Autoregressive model coefficients - Burg's method} \usage{ arburg(x, p, criterion = NULL) } \arguments{ \item{x}{input data, specified as a numeric or complex vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{p}{model order; number of poles in the AR model or limit to the number of poles if a valid criterion is provided. Must be < length(x) - 2.} \item{criterion}{model-selection criterion. Limits the number of poles so that spurious poles are not added when the whitened data has no more information in it. Recognized values are: \describe{ \item{AKICc}{approximate corrected Kullback information criterion (recommended)} \item{KIC}{Kullback information criterion} \item{AICc}{corrected Akaike information criterion} \item{AIC}{Akaike information criterion} \item{FPE}{final prediction error} } The default is to NOT use a model-selection criterion (NULL)} } \value{ A \code{list} containing the following elements: \describe{ \item{a}{vector or matrix containing \code{(p+1)} autoregression coefficients. If \code{x} is a matrix, then each row of a corresponds to a column of \code{x}. \code{a} has \code{p + 1} columns.} \item{e}{white noise input variance, returned as a vector. If \code{x} is a matrix, then each element of e corresponds to a column of \code{x}.} \item{k}{Reflection coefficients defining the lattice-filter embodiment of the model returned as vector or a matrix. If \code{x} is a matrix, then each column of \code{k} corresponds to a column of \code{x}. \code{k} has \code{p} rows.} } } \description{ Calculate the coefficients of an autoregressive model using the whitening lattice-filter method of Burg (1968)[1]. } \details{ The inverse of the autoregressive model is a moving-average filter which reduces \code{x} to white noise. The power spectrum of the AR model is an estimate of the maximum entropy power spectrum of the data. The function \code{ar_psd} calculates the power spectrum of the AR model. For data input \code{x(n)} and white noise \code{e(n)}, the autoregressive model is \if{latex}{ \deqn{x(n) = \sqrt{v} \cdot e(n) + \sum_{k=1}^{p+1} a(k) \cdot x(n-k)} } \if{html}{\preformatted{ p+1 x(n) = sqrt(v).e(n) + SUM a(k).x(n-k) k=1 }} \code{arburg} does not remove the mean from the data. You should remove the mean from the data if you want a power spectrum. A non-zero mean can produce large errors in a power-spectrum estimate. See \code{\link{detrend}} } \note{ AIC, AICc, KIC and AKICc are based on information theory. They attempt to balance the complexity (or length) of the model against how well the model fits the data. AIC and KIC are biased estimates of the asymmetric and the symmetric Kullback-Leibler divergence, respectively. AICc and AKICc attempt to correct the bias. See reference [2]. } \examples{ A <- Arma(1, c(1, -2.7607, 3.8106, -2.6535, 0.9238)) y <- filter(A, 0.2 * rnorm(1024)) coefs <- arburg(y, 4) } \references{ [1] Burg, J.P. (1968) A new analysis technique for time series data, NATO advanced study Institute on Signal Processing with Emphasis on Underwater Acoustics, Enschede, Netherlands, Aug. 12-23, 1968.\cr [2] Seghouane, A. and Bekara, M. (2004). A small sample model selection criterion based on Kullback’s symmetric divergence. IEEE Trans. Sign. Proc., 52(12), pp 3314-3323, } \seealso{ \code{\link{ar_psd}} } \author{ Peter V. Lanspeary, \email{pvl@mecheng.adelaide.edu.au}.\cr Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@gmail.com}. } gsignal/man/movingrms.Rd0000644000176200001440000000251414420222025014754 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/movingrms.R \name{movingrms} \alias{movingrms} \title{Moving Root Mean Square} \usage{ movingrms(x, width = 0.1, rc = 0.001, fs = 1) } \arguments{ \item{x}{Input signal, specified as a numeric vector or matrix. In case of a matrix, the function operates along the columns} \item{width}{width of the sigmoid window, in units relative to \code{fs}. Default: 0.1} \item{rc}{Rise time (time constant) of the sigmoid window, in units relative to \code{fs}. Default: 1e-3} \item{fs}{Sampling frequency. Default: 1} } \value{ A \code{\link{list}} containing 2 variables: \describe{ \item{rmsx}{Output signal with the same dimensions as \code{x}} \item{w}{Window, returned as a vector} } } \description{ Compute the moving root mean square (RMS) of the input signal. } \details{ The signal is convoluted against a sigmoid window of width \code{w} and risetime \code{rc}. The units of these parameters are relative to the value of the sampling frequency given in \code{fs}. } \examples{ N <- 128 fs <- 5 t <- seq(0, 1, length.out = N) x <- sin(2 * pi * fs * t) + runif(N) y <- movingrms(x, 5) } \seealso{ \code{\link{sigmoid_train}} } \author{ Juan Pablo Carbajal, \email{carbajal@ifi.uzh.ch}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/freqs.Rd0000644000176200001440000000412414661635224014072 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/freqs.R \name{freqs} \alias{freqs} \alias{freqs.default} \alias{freqs.Arma} \alias{freqs.Ma} \alias{freqs.Sos} \alias{freqs.Zpg} \alias{print.freqs} \alias{summary.freqs} \alias{print.summary.freqs} \alias{freqs_plot} \title{Frequency response of analog filters} \usage{ freqs(filt, ...) \method{freqs}{default}(filt, a, w, ...) \method{freqs}{Arma}(filt, w, ...) \method{freqs}{Ma}(filt, w, ...) \method{freqs}{Sos}(filt, w, ...) \method{freqs}{Zpg}(filt, w, ...) \method{print}{freqs}(x, ...) \method{summary}{freqs}(object, ...) \method{print}{summary.freqs}(x, ...) freqs_plot(x, ...) } \arguments{ \item{filt}{for the default case, moving average (MA) polynomial coefficients, specified as a numeric vector or matrix. In case of a matrix, then each row corresponds to an output of the system. The number of columns of \code{b} must be less than or equal to the length of \code{a}.} \item{...}{for methods of \code{freqs}, arguments are passed to the default method. For \code{freqs_plot}, additional arguments are passed through to plot.} \item{a}{autoregressive (AR) polynomial coefficients, specified as a vector.} \item{w}{angular frequencies, specified as a positive real vector expressed in rad/second.} \item{x}{object to be printed or plotted.} \item{object}{object of class \code{"freqs"} for \code{summary}} } \value{ For \code{freqs}, a list of class \code{'freqs'} with items: \describe{ \item{h}{complex array of frequency responses at frequencies \code{f}.} \item{w}{array of frequencies.} } } \description{ Compute the s-plane frequency response of an IIR filter. } \details{ The s-plane frequency response of the IIR filter \code{B(s) / A(s)} is computed as \code{H = polyval(B, 1i * W) / polyval(A, 1i * W)}. If called with no output argument, a plot of magnitude and phase are displayed. } \examples{ b <- c(1, 2); a <- c(1, 1) w <- seq(0, 4, length.out = 128) freqs (b, a, w) } \author{ Julius O. Smith III, \email{jos@ccrma.stanford.edu}.\cr Conversion to R by Geert van Boxtel \email{gjmvanboxtel@gmail.com} } gsignal/man/FilterSpecs.Rd0000644000176200001440000000276614420222025015167 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/FilterSpecs.R \name{FilterSpecs} \alias{FilterSpecs} \title{Filter specifications} \usage{ FilterSpecs(n, Wc, type, ...) } \arguments{ \item{n}{filter order.} \item{Wc}{cutoff frequency.} \item{type}{filter type, normally one of \code{"low"}, \code{"high"}, \code{"stop"}, or \code{"pass"}.} \item{...}{other filter description characteristics, possibly including Rp for dB of pass band ripple or Rs for dB of stop band ripple, depending on filter type (Butterworth, Chebyshev, etc.).} } \value{ A list of class \code{'FilterSpecs'} with the following list elements (repeats of the input arguments): \describe{ \item{n}{filter order} \item{Wc}{cutoff frequency} \item{type}{filter type, normally one of \code{"low"}, \code{"high"}, \code{"stop"}, or \code{"pass"}.} \item{...}{other filter description characteristics, possibly including Rp for dB of pass band ripple or Rs for dB of stop band ripple, depending on filter type (Butterworth, Chebyshev, etc.).} } } \description{ Filter specifications, including order, frequency cutoff, type, and possibly others. } \examples{ filt <- FilterSpecs(3, 0.1, "low") } \seealso{ \code{\link{filter}}, \code{\link{butter}} and \code{\link{buttord}}, \code{\link{cheby1}} and \code{\link{cheb1ord}}, \code{\link{ellip}} and \code{\link{ellipord}}. } \author{ Tom Short, \email{tshort@eprisolutions.com},\cr renamed and adapted by Geert van Boxtel, \email{gjmvanboxtel@gmail.com} } gsignal/man/convmtx.Rd0000644000176200001440000000255114420222025014432 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/convmtx.R \name{convmtx} \alias{convmtx} \title{Convolution matrix} \usage{ convmtx(h, n) } \arguments{ \item{h}{Input, coerced to a vector, representing the filter kernel} \item{n}{Length of vector(s) that \code{h} is to be convolved with.} } \value{ Convolution matrix of input \code{h} for a vector of length \code{n}. If \code{h} is a vector of length \code{m}, then the convolution matrix has \code{m + n - 1} rows and \code{n} columns. } \description{ Returns the convolution matrix for a filter kernel. } \details{ Computing a convolution using \code{conv} when the signals are vectors is generally more efficient than using \code{convmtx}. For multichannel signals, however, when a large number of vectors are to be convolved with the same filter kernel, \code{convmtx} might be more efficient. The code \code{cm <- convmtx(h, n)} computes the convolution matrix of the filter kernel \code{h} with a vector of length \code{n}. Then, \code{cm %*% x} gives the convolution of \code{h} and \code{x}. } \examples{ N <- 1000 a <- runif(N) b <- runif(N) cm <- convmtx(b, N) d <- cm \%*\% a cref = conv(a, b) all.equal(max(d - cref), 0) } \seealso{ \code{\link{conv}} } \author{ David Bateman \email{adb014@gmail.com}.\cr Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/dst.Rd0000644000176200001440000000450114420222025013523 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dst.R \name{dst} \alias{dst} \title{Discrete Sine Transform} \usage{ dst(x, n = NROW(x)) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{n}{transform length, specified as a positive integer scalar. Default: \code{NROW(x)}.} } \value{ Discrete sine transform, returned as a vector or matrix. } \description{ Compute the discrete sine transform of a signal. } \details{ The discrete sine transform (DST) is closely related to the discrete Fourier transform. but using a purely real matrix. It is equivalent to the imaginary parts of a DFT of roughly twice the length. The DST has four standard variants. This function implements the DCT-I according to the definition in [1], which is the most common variant, and the original variant first proposed for image processing. The 'Matlab' documentation for the DST warns that the use of the function is not recommended. They do not state the reason why, but it is likely that use of the discrete cosine transform (DCT)is preferred for image processing. Because cos(0) is 1, the first coefficient of the DCT (II) is the mean of the values being transformed. This makes the first coefficient of each 8x8 block represent the average tone of its constituent pixels, which is obviously a good start. Subsequent coefficients add increasing levels of detail, starting with sweeping gradients and continuing into increasingly fiddly patterns, and it just so happens that the first few coefficients capture most of the signal in photographic images. Sin(0) is 0, so the DSTs start with an offset of 0.5 or 1, and the first coefficient is a gentle mound rather than a flat plain. That is unlikely to suit ordinary images, and the result is that DSTs require more coefficients than DCTs to encode most blocks. This explanation was provided by Douglas Bagnall on Stackoverflow. } \examples{ x <- matrix(seq_len(100) + 50 * cos(seq_len(100) * 2 * pi / 40)) ct <- dct(x) st <- dst(x) } \references{ [1] \url{https://en.wikipedia.org/wiki/Discrete_sine_transform} } \seealso{ \code{\link{idst}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/ifftshift.Rd0000644000176200001440000000210114420222025014711 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ifftshift.R \name{ifftshift} \alias{ifftshift} \title{Inverse zero-frequency shift} \usage{ ifftshift(x, MARGIN = 2) } \arguments{ \item{x}{input data, specified as a vector or matrix.} \item{MARGIN}{dimension to operate along, 1 = row, 2 = columns (default). Specifying \code{MARGIN = c(1, 2)} centers along both rows and columns. Ignored when \code{x} is a vector.} } \value{ back-transformed vector or matrix. } \description{ Rearranges a zero-frequency-shifted Fourier transform back to the original. } \details{ Undo the action of the fftshift function. For even length \code{x}, \code{fftshift} is its own inverse, but not for odd length input. } \examples{ Xeven <- 1:6 res <- fftshift(fftshift(Xeven)) Xodd <- 1:7 res <- fftshift(fftshift(Xodd)) res <- ifftshift(fftshift(Xodd)) } \seealso{ \code{\link{fftshift}} } \author{ Vincent Cautaerts, \email{vincent@comf5.comm.eng.osaka-u.ac.jp},\cr adapted by John W. Eaton.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/marcumq.Rd0000644000176200001440000000134014420222025014374 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/marcumq.R \name{marcumq} \alias{marcumq} \title{Marcum Q function} \usage{ marcumq(a, b, m = 1) } \arguments{ \item{a, b}{input arguments, specified as non-negative real numbers.} \item{m}{order, specified as a positive integer} } \value{ Marcum Q function. } \description{ Compute the generalized Marcum Q function } \details{ The code for this function was taken from the help file of the \code{cdfkmu} function in the \code{lmomco} package, based on a suggestion of Daniel Wollschlaeger. } \examples{ mq <- marcumq(12.4, 12.5) } \references{ \url{https://cran.r-project.org/package=lmomco} } \author{ William Asquith, \email{william.asquith@ttu.edu}. } gsignal/man/sos2tf.Rd0000644000176200001440000000237114420222025014154 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sos2tf.R \name{sos2tf} \alias{sos2tf} \title{Sos to transfer function} \usage{ sos2tf(sos, g = 1) } \arguments{ \item{sos}{Second-order section representation, specified as an nrow-by-6 matrix, whose rows contain the numerator and denominator coefficients of the second-order sections:\cr \code{sos <- rbind(cbind(B1, A1), cbind(...), cbind(Bn, An))}, where \code{B1 <- c(b0, b1, b2)}, and \code{A1 <- c(a0, a1, a2)} for section 1, etc. The b0 entry must be nonzero for each section.} \item{g}{Overall gain factor that effectively scales the output \code{b} vector (or any one of the input \code{Bi} vectors). Default: 1.} } \value{ An object of class "Arma" with the following list elements: \describe{ \item{b}{moving average (MA) polynomial coefficients} \item{a}{autoregressive (AR) polynomial coefficients} } } \description{ Convert digital filter second-order section data to transfer function form. } \examples{ sos <- rbind(c(1, 1, 1, 1, 0, -1), c(-2, 3, 1, 1, 10, 1)) ba <- sos2tf(sos) } \seealso{ \code{\link{as.Arma}}, \code{\link{filter}} } \author{ Julius O. Smith III, \email{jos@ccrma.stanford.edu}.\cr Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@gmail.com}. } gsignal/man/stft.Rd0000644000176200001440000000550314661623627013740 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/stft.R \name{stft} \alias{stft} \title{Short-Term Fourier Transform} \usage{ stft( x, window = nextpow2(sqrt(NROW(x))), overlap = 0.75, nfft = ifelse(isScalar(window), window, length(window)), fs = 1 ) } \arguments{ \item{x}{input data, specified as a numeric or complex vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{window}{If \code{window} is a vector, each segment has the same length as \code{window} and is multiplied by \code{window} before (optional) zero-padding and calculation of its periodogram. If \code{window} is a scalar, each segment has a length of \code{window} and a Hamming window is used. Default: \code{nextpow2(sqrt(NROW(x)))} (the square root of the length of \code{x} rounded up to the next power of two). The window length must be larger than 3.} \item{overlap}{segment overlap, specified as a numeric value expressed as a multiple of window or segment length. 0 <= overlap < 1. Default: 0.75.} \item{nfft}{Length of FFT, specified as an integer scalar. The default is the length of the \code{window} vector or has the same value as the scalar \code{window} argument. If \code{nfft} is larger than the segment length, (seg_len), the data segment is padded \code{nfft - seg_len} zeros. The default is no padding. Nfft values smaller than the length of the data segment (or window) are ignored. Note that the use of padding to increase the frequency resolution of the spectral estimate is controversial.} \item{fs}{sampling frequency (Hertz), specified as a positive scalar. Default: 1.} } \value{ A list containing the following elements: \describe{ \item{\code{f}}{vector of frequencies at which the STFT is estimated. If \code{x} is numeric, power from negative frequencies is added to the positive side of the spectrum, but not at zero or Nyquist (fs/2) frequencies. This keeps power equal in time and spectral domains. If \code{x} is complex, then the whole frequency range is returned.} \item{\code{t}}{vector of time points at which the STFT is estimated.} \item{\code{s}}{Short-time Fourier transform, returned as a matrix or a 3-D array. Time increases across the columns of \code{s} and frequency increases down the rows. The third dimension, if present, corresponds to the input channels.} } } \description{ Compute the short-term Fourier transform of a vector or matrix. } \examples{ fs <- 8000 y <- chirp(seq(0, 5 - 1/fs, by = 1/fs), 200, 2, 500, "logarithmic") ft <- stft (y, fs = fs) filled.contour(ft$t, ft$f, t(ft$s), xlab = "Time (s)", ylab = "Frequency (Hz)") } \author{ Andreas Weingessel, \email{Andreas.Weingessel@ci.tuwien.ac.at}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/bilinear.Rd0000644000176200001440000000617714420222025014531 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bilinear.R \name{bilinear} \alias{bilinear} \alias{bilinear.Zpg} \alias{bilinear.Arma} \alias{bilinear.default} \title{Bilinear transformation} \usage{ bilinear(Sz, ...) \method{bilinear}{Zpg}(Sz, T = 2 * tan(1/2), ...) \method{bilinear}{Arma}(Sz, T = 2 * tan(1/2), ...) \method{bilinear}{default}(Sz, Sp, Sg, T = 2 * tan(1/2), ...) } \arguments{ \item{Sz}{In the generic case, a model to be transformed. In the default case, a vector containing the zeros in a pole-zero-gain model.} \item{...}{arguments passed to the generic function.} \item{T}{the sampling frequency represented in the z plane. Default: \code{2 * tan(1 / 2)}.} \item{Sp}{a vector containing the poles in a pole-zero-gain model.} \item{Sg}{a vector containing the gain in a pole-zero-gain model.} } \value{ For the default case or for bilinear.Zpg, an object of class \code{'Zpg'}, containing the list elements: \describe{ \item{z}{complex vector of the zeros of the transformed model} \item{p}{complex vector of the poles of the transformed model} \item{g}{gain of the transformed model} } For bilinear.Arma, an object of class \code{'Arma'}, containing the list elements: \describe{ \item{b}{moving average (MA) polynomial coefficients} \item{a}{autoregressive (AR) polynomial coefficients} } } \description{ Transform a s-plane (analog) filter specification into a z-plane (digital) specification. } \details{ Given a piecewise flat filter design, you can transform it from the s-plane to the z-plane while maintaining the band edges by means of the bilinear transform. This maps the left hand side of the s-plane into the interior of the unit circle. The mapping is highly non-linear, so you must design your filter with band edges in the s-plane positioned at \eqn{2/T tan(wT / 2)} so that they will be positioned at \code{w} after the bilinear transform is complete. The bilinear transform is: \deqn{z = (1 + sT / 2) / (1 - sT / 2)} \deqn{s = (T / 2) (z - 1) / (z + 1)} Please note that a pole and a zero at the same place exactly cancel. This is significant since the bilinear transform creates numerous extra poles and zeros, most of which cancel. Those which do not cancel have a “fill-in” effect, extending the shorter of the sets to have the same number of as the longer of the sets of poles and zeros (or at least split the difference in the case of the band pass filter). There may be other opportunistic cancellations, but it will not check for them. Also note that any pole on the unit circle or beyond will result in an unstable filter. Because of cancellation, this will only happen if the number of poles is smaller than the number of zeros. The analytic design methods all yield more poles than zeros, so this will not be a problem. } \examples{ ## 6th order Bessel low-pass analog filter zp <- besselap(6) w <- seq(0, 4, length.out = 128) freqs(zp, w) zzp <- bilinear(zp) freqz(zzp) } \references{ \url{https://en.wikipedia.org/wiki/Bilinear_transform} } \author{ Paul Kienzle \email{pkienzle@users.sf.net}. Conversion to R by Tom Short, adapted by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/invfreq.Rd0000644000176200001440000000532014420222025014403 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/invfreq.R \name{invfreq} \alias{invfreq} \alias{invfreqs} \alias{invfreqz} \title{Inverse Frequency Response} \usage{ invfreq( h, w, nb, na, wt = rep(1, length(w)), plane = c("z", "s"), method = c("ols", "tls", "qr"), norm = TRUE ) invfreqs( h, w, nb, na, wt = rep(1, length(w)), method = c("ols", "tls", "qr"), norm = TRUE ) invfreqz( h, w, nb, na, wt = rep(1, length(w)), method = c("ols", "tls", "qr"), norm = TRUE ) } \arguments{ \item{h}{Frequency response, specified as a vector} \item{w}{Angular frequencies at which \code{h} is computed, specified as a vector} \item{nb, na}{Desired order of the numerator and denominator polynomials, specified as positive integers.} \item{wt}{Weighting factors, specified as a vector of the same length as \code{w}. Default: \code{rep(1, length(w))}} \item{plane}{\code{"z"} (default) for discrete-time spectra; \code{"s"} for continuous-time spectra} \item{method}{minimization method used to solve the normal equations, one of: \describe{ \item{"ols"}{ordinary least squares (default)} \item{"tls"}{total least squares} \item{"qr"}{QR decomposition} }} \item{norm}{logical indicating whether frequencies must be normalized to avoid matrices with rank deficiency. Default: TRUE} } \value{ A list of class \code{'Arma'} with the following list elements: \describe{ \item{b}{moving average (MA) polynomial coefficients} \item{a}{autoregressive (AR) polynomial coefficients} } } \description{ Identify filter parameters from frequency response data. } \details{ Given a desired (one-sided, complex) spectrum \code{h(w)} at equally spaced angular frequencies \eqn{w = (2 \pi k) / N}, k = 0, ... N-1, this function finds the filter \code{B(z)/A(z)} or \code{B(s)/A(s)} with \code{nb} zeroes and \code{na} poles. Optionally, the fit-errors can be weighted with respect to frequency according to the weights \code{wt}. } \examples{ order <- 6 # order of test filter fc <- 1/2 # sampling rate / 4 n <- 128 # frequency grid size ba <- butter(order, fc) hw <- freqz(ba, n) BA = invfreq(hw$h, hw$w, order, order) HW = freqz(BA, n) plot(hw$w, abs(hw$h), type = "l", xlab = "Frequency (rad/sample)", ylab = "Magnitude") lines(HW$w, abs(HW$h), col = "red") legend("topright", legend = c("Original", "Measured"), lty = 1, col = 1:2) err <- norm(hw$h - HW$h, type = "2") title(paste('L2 norm of frequency response error =', err)) } \references{ \url{https://ccrma.stanford.edu/~jos/filters/FFT_Based_Equation_Error_Method.html} } \author{ Julius O. Smith III, Rolf Schirmacher, Andrew Fitting, Pascal Dupuis.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/poly.Rd0000644000176200001440000000206314663323315013732 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/poly.R \name{poly} \alias{poly} \title{Polynomial with specified roots} \usage{ poly(x) } \arguments{ \item{x}{Real or complex vector, or square matrix.} } \value{ A vector of the coefficients of the polynomial in order from highest to lowest polynomial power. } \description{ Compute the coefficients of a polynomial when the roots are given, or the characteristic polynomial of a matrix. } \details{ If a vector is passed as an argument, then \code{poly(x)} is a vector of the coefficients of the polynomial whose roots are the elements of \code{x}. If an \eqn{N x N} square matrix is given, \code{poly(x)} is the row vector of the coefficients of \code{det (z * diag (N) - x)}, which is the characteristic polynomial of \code{x}. } \examples{ p <- poly(c(1, -1)) p <- poly(pracma::roots(1:3)) p <- poly(matrix(1:9, 3, 3)) } \seealso{ \code{\link[pracma]{roots}} } \author{ Kurt Hornik.\cr Conversion to R by Tom Short,\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com} } gsignal/man/rssq.Rd0000644000176200001440000000330314420222025013720 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rssq.R \name{rssq} \alias{rssq} \title{Root-sum-of-squares} \usage{ rssq(x, MARGIN = 2) } \arguments{ \item{x}{the data, expected to be a vector, a matrix, an array.} \item{MARGIN}{a vector giving the subscripts which the function will be applied over. E.g., for a matrix 1 indicates rows, 2 indicates columns, c(1, 2) indicates rows and columns. Where \code{x} has named dimnames, it can be a character vector selecting dimension names. Default: 2 (usually columns)} } \value{ Vector or array of values containing the root-sum-of-squares of the specified \code{MARGIN} of \code{x}. } \description{ Compute the root-sum-of-squares (SSQ) of the object \code{x}. } \details{ The input \code{x} can be a vector, a matrix or an array. If the input is a vector, a single value is returned representing the root-sum-of-squares of the vector. If the input is a matrix or an array, a vector or an array of values is returned representing the root-sum-of-squares of the dimensions of \code{x} indicated by the \code{MARGIN} argument. Support for complex valued input is provided. The sum of squares of complex numbers is defined by \code{sum(x * Conj(x))} } \examples{ ## numeric vector x <- c(1:5) p <- rssq(x) ## numeric matrix x <- matrix(c(1,2,3, 100, 150, 200, 1000, 1500, 2000), 3, 3) p <- rssq(x) p <- rssq(x, 1) ## numeric array x <- array(c(1, 1.5, 2, 100, 150, 200, 1000, 1500, 2000, 10000, 15000, 20000), c(2,3,2)) p <- rssq(x, 1) p <- rssq(x, 2) p <- rssq(x, 3) ## complex input x <- c(1+1i, 2+3i, 3+5i, 4+7i, 5+9i) p <- rssq(x) } \author{ Mike Miller.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/cheb1ord.Rd0000644000176200001440000000335614420222025014427 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cheb1ord.R \name{cheb1ord} \alias{cheb1ord} \title{Chebyshev Type I filter order} \usage{ cheb1ord(Wp, Ws, Rp, Rs, plane = c("z", "s")) } \arguments{ \item{Wp, Ws}{pass-band and stop-band edges. For a low-pass or high-pass filter, \code{Wp} and \code{Ws} are scalars. For a band-pass or band-rejection filter, both are vectors of length 2. For a low-pass filter, \code{Wp < Ws}. For a high-pass filter, \code{Ws > Wp}. For a band-pass \code{(Ws[1] < Wp[1] < Wp[2] < Ws[2])} or band-reject \code{(Wp[1] < Ws[1] < Ws[2] < Wp[2])} filter design, \code{Wp} gives the edges of the pass band, and \code{Ws} gives the edges of the stop band. For digital filters, frequencies are normalized to [0, 1], corresponding to the range [0, fs/2]. In case of an analog filter, all frequencies are specified in radians per second.} \item{Rp}{allowable decibels of ripple in the pass band.} \item{Rs}{minimum attenuation in the stop band in dB.} \item{plane}{"z" for a digital filter or "s" for an analog filter.} } \value{ A list of class \code{'FilterSpecs'} with the following list elements: \describe{ \item{n}{filter order} \item{Wc}{cutoff frequency} \item{type}{filter type, normally one of \code{"low"}, \code{"high"}, \code{"stop"}, or \code{"pass"}.} } } \description{ Compute Chebyshev type-I filter order and cutoff for the desired response characteristics. } \examples{ ## low-pass 30 Hz filter fs <- 128 spec <- cheb1ord(30/(fs/2), 40/(fs/2), 0.5, 40) cf <- cheby1(spec) freqz(cf, fs = fs) } \seealso{ \code{\link{cheby1}} } \author{ Paul Kienzle, Laurent S. Mazet, Charles Praplan.\cr Conversion to R by Tom Short, adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/schtrig.Rd0000644000176200001440000000434014420222025014375 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/schtrig.R \name{schtrig} \alias{schtrig} \title{Schmitt Trigger} \usage{ schtrig(x, lvl, st = NULL) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{lvl}{threshold levels against which \code{x} is compared, specified as a vector. If this is a scalar, the thresholds are symmetric around 0, i.e. \code{c(-lvl, lvl)}.} \item{st}{trigger state, specified as a vector of length \code{ncol(x}. The trigger state is returned in the output list and may be passed again to a subsequent call to \code{schtrig}. Default: NULL.} } \value{ a \code{\link{list}} containing the following variables: \describe{ \item{v}{vector or matrix of 0's and 1's, according to whether \code{x} is above or below \code{lvl}, or the value of \code{x} if indeterminate} \item{rng}{ranges in which the output is high, so the indexes \code{rng[1,i]:rng[2,i]} point to the i-th segment of 1s in \code{v}. See \code{\link{clustersegment}} for a detailed explanation.} \item{st}{trigger state, returned as a vector with a length of the number of columns in \code{x}.} } } \description{ Multisignal Schmitt trigger with levels. } \details{ The trigger works compares each column in \code{x} to the levels in \code{lvl}, when the value is higher than \code{max(lvl)}, the output \code{v} is high (i.e. 1); when the value is below \code{min(lvl)} the output is low (i.e. 0); and when the value is between the two levels the output retains its value. } \examples{ t <- seq(0, 1, length.out = 100) x <- sin(2 * pi * 2 * t) + sin(2 * pi * 5 * t) \%*\% matrix(c(0.8, 0.3), 1, 2) lvl <- c(0.8, 0.25) trig <- schtrig (x, lvl) op <- par(mfrow = c(2, 1)) plot(t, x[, 1], type = "l", xlab = "", ylab = "") abline(h = lvl, col = "blue") lines(t, trig$v[, 1], col = "red", lwd = 2) plot(t, x[, 2], type = "l", xlab = "", ylab = "") abline(h = lvl, col = "blue") lines(t, trig$v[, 2], col = "red", lwd = 2) par(op) } \seealso{ \code{\link{clustersegment}} } \author{ Juan Pablo Carbajal, \email{carbajal@ifi.uzh.ch}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/pburg.Rd0000644000176200001440000000655214420222025014060 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pburg.R \name{pburg} \alias{pburg} \title{Autoregressive PSD estimate - Burg's method} \usage{ pburg( x, p, criterion = NULL, freq = 256, fs = 1, range = NULL, method = if (length(freq) == 1 && bitwAnd(freq, freq - 1) == 0) "fft" else "poly" ) } \arguments{ \item{x}{input data, specified as a numeric or complex vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{p}{model order; number of poles in the AR model or limit to the number of poles if a valid criterion is provided. Must be < length(x) - 2.} \item{criterion}{model-selection criterion. Limits the number of poles so that spurious poles are not added when the whitened data has no more information in it. Recognized values are: \describe{ \item{"AKICc"}{approximate corrected Kullback information criterion (recommended)} \item{"KIC"}{Kullback information criterion} \item{"AICc"}{corrected Akaike information criterion} \item{"AIC"}{Akaike information criterion} \item{"FPE"}{final prediction error} } The default is to NOT use a model-selection criterion (NULL)} \item{freq}{vector of frequencies at which power spectral density is calculated, or a scalar indicating the number of uniformly distributed frequency values at which spectral density is calculated. Default: 256.} \item{fs}{sampling frequency (Hz). Default: 1} \item{range}{character string. one of: \describe{ \item{\code{"half"} or \code{"onesided"}}{frequency range of the spectrum is from zero up to but not including \code{fs / 2}. Power from negative frequencies is added to the positive side of the spectrum.} \item{\code{"whole"} or \code{"twosided"}}{frequency range of the spectrum is \code{-fs / 2} to \code{fs / 2}, with negative frequencies stored in "wrap around order" after the positive frequencies; e.g. frequencies for a 10-point \code{"twosided"} spectrum are 0 0.1 0.2 0.3 0.4 0.5 -0.4 -0.3 -0.2. -0.1.} \item{\code{"shift"} or \code{"centerdc"}}{same as \code{"whole"} but with the first half of the spectrum swapped with second half to put the zero-frequency value in the middle. If \code{freq} is a vector, \code{"shift"} is ignored.} } Default: If model coefficients \code{a} are real, the default range is \code{"half"}, otherwise the default range is \code{"whole"}.} \item{method}{method used to calculate the power spectral density, either \code{"fft"} (use the Fast Fourier Transform) or \code{"poly"} (calculate the power spectrum as a polynomial). This argument is ignored if the \code{freq} argument is a vector. The default is \code{"poly"} unless the \code{freq} argument is an integer power of 2.} } \value{ An object of class "ar_psd" , which is a list containing two elements, \code{freq} and \code{psd} containing the frequency values and the estimates of power-spectral density, respectively. } \description{ Calculate Burg maximum-entropy power spectral density. } \note{ This function is a wrapper for \code{arburg} and \code{ar_psd}. } \examples{ A <- Arma(1, c(1, -2.7607, 3.8106, -2.6535, 0.9238)) y <- filter(A, 0.2 * rnorm(1024)) plot(pb <- pburg(y, 4)) } \seealso{ \code{\link{ar_psd}}, \code{\link{arburg}} } \author{ Peter V. Lanspeary, \email{pvl@mecheng.adelaide.edu.au}.\cr Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@gmail.com} } gsignal/man/tf2sos.Rd0000644000176200001440000000234414420222025014154 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tf2sos.R \name{tf2sos} \alias{tf2sos} \title{Transfer function to second-order sections form} \usage{ tf2sos(b, a) } \arguments{ \item{b}{moving average (MA) polynomial coefficients} \item{a}{autoregressive (AR) polynomial coefficients} } \value{ A list with the following list elements: \describe{ \item{sos}{Second-order section representation, specified as an nrow-by-6 matrix, whose rows contain the numerator and denominator coefficients of the second-order sections:\cr \code{sos <- rbind(cbind(B1, A1), cbind(...), cbind(Bn, An))}, where \code{B1 <- c(b0, b1, b2)}, and \code{A1 <- c(a0, a1, a2)} for section 1, etc. The b0 entry must be nonzero for each section.} \item{g}{Overall gain factor that effectively scales the output \code{b} vector (or any one of the input \code{Bi} vectors).} } } \description{ Convert digital filter transfer function data to second-order section form. } \examples{ b <- c(1, 0, 0, 0, 0, 1) a <- c(1, 0, 0, 0, 0, .9) sosg <- tf2sos (b, a) } \seealso{ See also \code{\link{filter}} } \author{ Julius O. Smith III, \email{jos@ccrma.stanford.edu}.\cr Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@gmail.com}. } gsignal/man/residued.Rd0000644000176200001440000000251614420222025014541 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/residued.R \name{residued} \alias{residued} \title{delayed z-transform partial fraction expansion} \usage{ residued(b, a) } \arguments{ \item{b}{coefficients of numerator polynomial} \item{a}{coefficients of denominator polynomial} } \value{ A \code{\link{list}} containing \describe{ \item{r}{vector of filter pole residues of the partial fraction} \item{p}{vector of partial fraction poles} \item{k}{vector containing FIR part, if any (empty if \code{length(b) < length(a)})} } } \description{ Finds the residues, poles, and direct term of a Partial Fraction Expansion of the ratio of two polynomials. } \details{ In the usual PFE function \code{residuez}, the IIR part (poles \code{p} and residues \code{r}) is driven in parallel with the FIR part (\code{f}). In this variant, the IIR part is driven by the output of the FIR part. This structure can be more accurate in signal modeling applications. } \examples{ b <- c(2, 6, 6, 2) a <- c(1, -2, 1) resd <- residued(b, a) resz <- residuez(b, a) } \references{ \url{https://ccrma.stanford.edu/~jos/filters/residued.html} } \seealso{ \code{\link{residue}}, \code{\link{residuez}} } \author{ Julius O. Smith III, \email{jos@ccrma.stanford.edu}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com} } gsignal/man/signals.Rd0000644000176200001440000000223314420222025014371 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/signals.R \docType{data} \name{signals} \alias{signals} \title{signals} \format{ A \code{\link{data.frame}} containing 10 seconds of data electrophysiological data, sampled at 256 Hz with a 24 bit A/D converter, measured in microVolts. The data frame consists of 2 columns (channels): \describe{ \item{eeg}{electroencephalogram (EEG) data measured from electrode Pz according to the 10-20 system, referred to algebraically linked mastoids (the brain's alpha rhythm is clearly visible).} \item{ecg}{electrocardiogram (ECG) data, recorded bipolarly with a V6 versus V1 chest lead (this lead maximizes the R wave of the ECG with respect to the P, Q, S, T and U waves of the cardiac cycle).} } } \usage{ signals } \description{ Sample EEG and ECG data. } \examples{ data(signals) time <- seq(0, 10, length.out = nrow(signals)) op <- par(mfcol = c(2, 1)) plot(time, signals[, 1], type = "l", xlab = "Time", ylab = "EEG (uV)") plot(time, signals[, 2], type = "l", xlab = "Time", ylab = "ECG (uV)") par(op) } \author{ Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com} } \keyword{datasets} gsignal/man/cheb2ap.Rd0000644000176200001440000000153614420222025014242 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cheb2ap.R \name{cheb2ap} \alias{cheb2ap} \title{Chebyshev Type II filter prototype} \usage{ cheb2ap(n, Rs) } \arguments{ \item{n}{Order of the filter.} \item{Rs}{dB of stop-band ripple.} } \value{ list of class \code{\link{Zpg}} containing poles and gain of the filter } \description{ Return the poles and gain of an analog Chebyshev Type II lowpass filter prototype. } \details{ This function exists for compatibility with 'Matlab' and 'Octave' only, and is equivalent to \code{cheby2(n, Rp, 1, "low", "s")}. } \examples{ ## 9th order Chebyshev type II low-pass analog filter zp <- cheb2ap(9, 30) w <- seq(0, 4, length.out = 128) freqs(zp, w) } \author{ Carne Draug, \email{carandraug+dev@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/unwrap.Rd0000644000176200001440000000177614420222025014260 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/unwrap.R \name{unwrap} \alias{unwrap} \title{Unwrap phase angles} \usage{ unwrap(x, tol = pi) } \arguments{ \item{x}{Input array, specified as a vector or a matrix. If \code{x} is a matrix, unwrapping along the columns of \code{x} is applied.} \item{tol}{Jump threshold to apply phase shift, specified as a scalar. A jump threshold less than \eqn{pi} has the same effect as the threshold \eqn{pi}. Default: \deqn{pi}.} } \value{ Unwrapped phase angle, returned as a vector, matrix, or multidimensional array. } \description{ Unwrap radian phases by adding or subtracting multiples of \code{2 * pi}. } \examples{ ## Define spiral shape. t <- seq(0, 6 * pi, length.out = 201) x <- t / pi * cos(t) y <- t / pi * sin(t) plot(x, y, type = "l") ## find phase angle p = atan2(y, x) plot(t, p, type="l") ## unwrap it q = unwrap(p) plot(t, q, type ="l") } \author{ Bill Lash.\cr Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@gmail.com} } gsignal/man/Sos.Rd0000644000176200001440000000277514420222025013510 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Sos.R \name{Sos} \alias{Sos} \alias{as.Sos} \alias{as.Sos.Arma} \alias{as.Sos.Ma} \alias{as.Sos.Sos} \alias{as.Sos.Zpg} \title{Second-order sections} \usage{ Sos(sos, g = 1) as.Sos(x, ...) ## S3 method for class 'Arma' as.Sos(x, ...) ## S3 method for class 'Ma' as.Sos(x, ...) ## S3 method for class 'Sos' as.Sos(x, ...) ## S3 method for class 'Zpg' as.Sos(x, ...) } \arguments{ \item{sos}{second-order sections representation of the model} \item{g}{overall gain factor} \item{x}{model to be converted.} \item{...}{additional arguments (ignored).} } \value{ A list of class \code{Sos} with the following list elements: \describe{ \item{sos}{second-order section representation of the model, returned as an \code{L x 6} matrix, one row for each section \code{1:L}. Each row consists of an \code{[B, A]}, pair, where \code{B = c(b0, b1, b2)}, and \code{A = c(1, a1, a2)}, the filer coefficients for each section. Each \code{b0} entry must be nonzero for each section.} \item{g}{overall gain factor that scales any one of the \eqn{B_i} vectors. Default: 1} } } \description{ Create or convert filter models to second-order sections form. } \details{ \code{as.Sos} converts from other forms, including \code{Arma}, \code{Ma}, and \code{Zpg}. } \examples{ ba <- butter(3, 0.2) sos <- as.Sos(ba) } \seealso{ \code{\link{Arma}}, \code{\link{Ma}}, \code{\link{Zpg}} } \author{ Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/blackmannuttall.Rd0000644000176200001440000000261214420222025016106 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/blackmannuttall.R \name{blackmannuttall} \alias{blackmannuttall} \title{Blackman-Nuttall window} \usage{ blackmannuttall(n, method = c("symmetric", "periodic")) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{method}{Character string. Window sampling method, specified as: \describe{ \item{"symmetric" (Default)}{Use this option when using windows for filter design.} \item{"periodic"}{This option is useful for spectral analysis because it enables a windowed signal to have the perfect periodic extension implicit in the discrete Fourier transform. When "periodic" is specified, the function computes a window of length \code{n + 1} and returns the first \code{n} points.} }} } \value{ Blackman-Nuttall window, returned as a vector. } \description{ Return the filter coefficients of a Blackman-Nuttal window. } \details{ The Blackman-Nuttall window is a member of the family of cosine sum windows. } \examples{ b <- blackmannuttall(64) plot (b, type = "l", xlab = "Samples", ylab =" Amplitude") bs = blackmannuttall(64,'symmetric') bp = blackmannuttall(63,'periodic') plot (bs, type = "l", xlab = "Samples", ylab =" Amplitude") lines(bp, col="red") } \author{ Muthiah Annamalai, \email{muthiah.annamalai@uta.edu}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/rms.Rd0000644000176200001440000000330014420222025013526 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rms.R \name{rms} \alias{rms} \title{Root-mean-square} \usage{ rms(x, MARGIN = 2) } \arguments{ \item{x}{the data, expected to be a vector, a matrix, an array.} \item{MARGIN}{a vector giving the subscripts which the function will be applied over. E.g., for a matrix 1 indicates rows, 2 indicates columns, c(1, 2) indicates rows and columns. Where \code{x} has named dimnames, it can be a character vector selecting dimension names. Default: 2 (columns)} } \value{ Vector or array of values containing the root-mean-squares of the specified \code{MARGIN} of \code{x}. } \description{ Compute the root-mean-square (RMS) of the object \code{x}. } \details{ The input \code{x} can be a vector, a matrix or an array. If the input is a vector, a single value is returned representing the root-mean-square of the vector. If the input is a matrix or an array, a vector or an array of values is returned representing the root-mean-square of the dimensions of \code{x} indicated by the \code{MARGIN} argument. Support for complex valued input is provided. The sum of squares of complex numbers is defined by \code{sum(x * Conj(x))} } \examples{ ## numeric vector x <- c(1:5) r <- rms(x) ## numeric matrix x <- matrix(c(1,2,3, 100, 150, 200, 1000, 1500, 2000), 3, 3) p <- rms(x) p <- rms(x, 1) ## numeric array x <- array(c(1, 1.5, 2, 100, 150, 200, 1000, 1500, 2000, 10000, 15000, 20000), c(2,3,2)) p <- rms(x, 1) p <- rms(x, 2) p <- rms(x, 3) ## complex input x <- c(1+1i, 2+3i, 3+5i, 4+7i, 5+9i) p <- rms(x) } \author{ Andreas Weber, \email{octave@tech-chat.de}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/ar_psd.Rd0000644000176200001440000000676614420222025014220 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ar_psd.R \name{ar_psd} \alias{ar_psd} \alias{plot.ar_psd} \alias{print.ar_psd} \title{Power spectrum of AR model} \usage{ ar_psd( a, v = 1, freq = 256, fs = 1, range = ifelse(is.numeric(a), "half", "whole"), method = ifelse(length(freq) == 1 && bitwAnd(freq, freq - 1) == 0, "fft", "poly") ) \method{plot}{ar_psd}( x, yscale = c("linear", "log", "dB"), xlab = NULL, ylab = NULL, main = NULL, ... ) \method{print}{ar_psd}( x, yscale = c("linear", "log", "dB"), xlab = NULL, ylab = NULL, main = NULL, ... ) } \arguments{ \item{a}{numeric vector of autoregressive model coefficients. The first element is the zero-lag coefficient, which always has a value of 1.} \item{v}{square of the moving average coefficient, specified as a positive scalar Default: 1} \item{freq}{vector of frequencies at which power spectral density is calculated, or a scalar indicating the number of uniformly distributed frequency values at which spectral density is calculated. Default: 256.} \item{fs}{sampling frequency (Hz). Default: 1} \item{range}{character string. one of: \describe{ \item{\code{"half"} or \code{"onesided"}}{frequency range of the spectrum is from zero up to but not including \code{fs / 2}. Power from negative frequencies is added to the positive side of the spectrum.} \item{\code{"whole"} or \code{"twosided"}}{frequency range of the spectrum is \code{-fs / 2} to \code{fs / 2}, with negative frequencies stored in "wrap around order" after the positive frequencies; e.g. frequencies for a 10-point \code{"twosided"} spectrum are 0 0.1 0.2 0.3 0.4 0.5 -0.4 -0.3 -0.2. -0.1.} \item{\code{"shift"} or \code{"centerdc"}}{same as \code{"whole"} but with the first half of the spectrum swapped with second half to put the zero-frequency value in the middle. If \code{freq} is a vector, \code{"shift"} is ignored.} } Default: If model coefficients \code{a} are real, the default range is \code{"half"}, otherwise the default range is \code{"whole"}.} \item{method}{method used to calculate the power spectral density, either \code{"fft"} (use the Fast Fourier Transform) or \code{"poly"} (calculate the power spectrum as a polynomial). This argument is ignored if the \code{freq} argument is a vector. The default is \code{"poly"} unless the \code{freq} argument is an integer power of 2.} \item{x}{object to plot.} \item{yscale}{character string specifying scaling of Y-axis; one of \code{"linear"}, \code{"log"}, \code{"dB"}} \item{xlab, ylab, main}{labels passed to plotting function. Default: NULL} \item{...}{additional arguments passed to functions} } \value{ An object of class \code{"ar_psd"} , which is a list containing two elements, \code{freq} and \code{psd} containing the frequency values and the estimates of power-spectral density, respectively. } \description{ Compute the power spectral density of an autoregressive model. } \details{ This function calculates the power spectrum of the autoregressive model \if{latex}{ \deqn{x(n) = \sqrt{v} \cdot e(n) + \sum_{k=1}^{M} a(k) \cdot x(n-k)} } \if{html}{\preformatted{ M x(n) = sqrt(v).e(n) + SUM a(k).x(n-k) k=1 }} where \code{x(n)} is the output of the model and \code{e(n)} is white noise. } \examples{ a <- c(1, -2.7607, 3.8106, -2.6535, 0.9238) psd <- ar_psd(a) } \author{ Peter V. Lanspeary, \email{pvl@mecheng.adelaide.edu.au}.\cr Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@gmail.com} } gsignal/man/besselap.Rd0000644000176200001440000000307614661623627014561 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/besselap.R \name{besselap} \alias{besselap} \title{Bessel analog low-pass filter prototype} \usage{ besselap(n) } \arguments{ \item{n}{order of the filter; must be < 25.} } \value{ List of class \code{\link{Zpg}} containing poles and gain of the filter } \description{ Return the poles and gain of a Bessel analog low-pass filter prototype. } \details{ The transfer function is \if{latex}{ \deqn{H(s) = \frac{k}{(s-p(1))(s-p(2))...(s-p(n))}} } \if{html}{\preformatted{ k H(s) = ----------------------------- (s-p(1))(s-p(2))...(s-p(n)) }} \code{besselap} normalizes the poles and gain so that at low frequency and high frequency the Bessel prototype is asymptotically equivalent to the Butterworth prototype of the same order. The magnitude of the filter is less than \eqn{1/\sqrt{2}} at the unity cutoff frequency \eqn{\Omega_c = 1}. Analog Bessel filters are characterized by a group delay that is maximally flat at zero frequency and almost constant throughout the passband. The group delay at zero frequency is \if{latex}{ \deqn{\left( \frac{(2n)!}{2^{n}n!} \right) ^{1/n}} } \if{html}{\preformatted{ / (2n!) \ 2 | ------ | \ 2^n n! / }} } \examples{ ## 6th order Bessel low-pass analog filter zp <- besselap(6) w <- seq(0, 4, length.out = 128) freqs(zp, w) } \references{ \url{https://en.wikipedia.org/wiki/Bessel_polynomials} } \author{ Thomas Sailer, \email{t.sailer@alumni.ethz.ch}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/butter.Rd0000644000176200001440000000613214420222025014240 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/butter.R \name{butter} \alias{butter} \alias{butter.FilterSpecs} \alias{butter.default} \title{Butterworth filter design} \usage{ butter(n, ...) \method{butter}{FilterSpecs}(n, ...) \method{butter}{default}( n, w, type = c("low", "high", "stop", "pass"), plane = c("z", "s"), output = c("Arma", "Zpg", "Sos"), ... ) } \arguments{ \item{n}{filter order.} \item{...}{additional arguments passed to butter, overriding those given by \code{n} of class \code{\link{FilterSpecs}}.} \item{w}{critical frequencies of the filter. \code{w} must be a scalar for low-pass and high-pass filters, and \code{w} must be a two-element vector c(low, high) specifying the lower and upper bands in radians/second. For digital filters, w must be between 0 and 1 where 1 is the Nyquist frequency.} \item{type}{filter type, one of \code{"low"}, (default) \code{"high"}, \code{"stop"}, or \code{"pass"}.} \item{plane}{"z" for a digital filter or "s" for an analog filter.} \item{output}{Type of output, one of: \describe{ \item{"Arma"}{Autoregressive-Moving average (aka numerator/denominator, aka b/a)} \item{"Zpg"}{Zero-pole-gain format} \item{"Sos"}{Second-order sections} } Default is \code{"Arma"} for compatibility with the 'signal' package and the 'Matlab' and 'Octave' equivalents, but \code{"Sos"} should be preferred for general-purpose filtering because of numeric stability.} } \value{ Depending on the value of the \code{output} parameter, a list of class \code{\link{Arma}}, \code{\link{Zpg}}, or \code{\link{Sos}} containing the filter coefficients } \description{ Compute the transfer function coefficients of a Butterworth filter. } \details{ Butterworth filters have a magnitude response that is maximally flat in the passband and monotonic overall. This smoothness comes at the price of decreased rolloff steepness. Elliptic and Chebyshev filters generally provide steeper rolloff for a given filter order. Because butter is generic, it can be extended to accept other inputs, using \code{buttord} to generate filter criteria for example. } \examples{ ## 50 Hz notch filter fs <- 256 bf <- butter(4, c(48, 52) / (fs / 2), "stop") freqz(bf, fs = fs) ## EEG alpha rhythm (8 - 12 Hz) bandpass filter fs <- 128 fpass <- c(8, 12) wpass <- fpass / (fs / 2) but <- butter(5, wpass, "pass") freqz(but, fs = fs) ## filter to remove vocals from songs, 25 dB attenuation in stop band ## (not optimal with a Butterworth filter) fs <- 44100 specs <- buttord(230/(fs/2), 450/(fs/2), 1, 25) bf <- butter(specs) freqz(bf, fs = fs) zplane(bf) } \references{ \url{https://en.wikipedia.org/wiki/Butterworth_filter} } \seealso{ \code{\link{Arma}}, \code{\link{Zpg}}, \code{\link{Sos}}, \code{\link{filter}}, \code{\link{cheby1}}, \code{\link{ellip}}, \code{\link{buttord}}. } \author{ Paul Kienzle, \email{pkienzle@users.sf.net},\cr Doug Stewart, \email{dastew@sympatico.ca},\cr Alexander Klein, \email{alexander.klein@math.uni-giessen.de},\cr John W. Eaton.\cr Conversion to R by Tom Short,\cr adapted by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/zp2sos.Rd0000644000176200001440000000337014420222025014174 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/zp2sos.R \name{zp2sos} \alias{zp2sos} \title{Zero-pole-gain to second-order section format} \usage{ zp2sos(z, p, g = 1, order = c("down", "up")) } \arguments{ \item{z}{complex vector of the zeros of the model (roots of \code{B(z)})} \item{p}{complex vector of the poles of the model (roots of \code{A(z)})} \item{g}{overall gain (\code{B(Inf)}). Default: 1} \item{order}{row order, specified as: \describe{ \item{"up"}{order the sections so the first row contains the poles farthest from the unit circle.} \item{"down" (Default)}{order the sections so the first row of \code{sos} contains the poles closest to the unit circle.} } The ordering influences round-off noise and the probability of overflow.} } \value{ A list with the following list elements: \describe{ \item{sos}{Second-order section representation, specified as an nrow-by-6 matrix, whose rows contain the numerator and denominator coefficients of the second-order sections:\cr \code{sos <- rbind(cbind(B1, A1), cbind(...), cbind(Bn, An))}, where \code{B1 <- c(b0, b1, b2)}, and \code{A1 <- c(a0, a1, a2)} for section 1, etc. The b0 entry must be nonzero for each section.} \item{g}{Overall gain factor that effectively scales the output \code{b} vector (or any one of the input \code{Bi} vectors).} } } \description{ Convert digital filter zero-pole-gain data to second-order section form. } \examples{ zpk <- tf2zp (c(1, 0, 0, 0, 0, 1), c(1, 0, 0, 0, 0, .9)) sosg <- zp2sos (zpk$z, zpk$p, zpk$g) } \seealso{ \code{\link{as.Sos}}, \code{\link{filter}}, \code{\link{sosfilt}} } \author{ Julius O. Smith III, \email{jos@ccrma.stanford.edu}.\cr Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@gmail.com} } gsignal/man/sftrans.Rd0000644000176200001440000001762114420222025014420 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sftrans.R \name{sftrans} \alias{sftrans} \alias{sftrans.Zpg} \alias{sftrans.Arma} \alias{sftrans.default} \title{Transform filter band edges} \usage{ sftrans(Sz, ...) \method{sftrans}{Zpg}(Sz, w, stop = FALSE, ...) \method{sftrans}{Arma}(Sz, w, stop = FALSE, ...) \method{sftrans}{default}(Sz, Sp, Sg, w, stop = FALSE, ...) } \arguments{ \item{Sz}{In the generic case, a model to be transformed. In the default case, a vector containing the zeros in a pole-zero-gain model.} \item{...}{arguments passed to the generic function.} \item{w}{critical frequencies of the target filter specified in radians. \code{w} must be a scalar for low-pass and high-pass filters, and \code{w} must be a two-element vector c(low, high) specifying the lower and upper bands in radians.} \item{stop}{FALSE for a low-pass or band-pass filter, TRUE for a high-pass or band-stop filter.} \item{Sp}{a vector containing the poles in a pole-zero-gain model.} \item{Sg}{a vector containing the gain in a pole-zero-gain model.} } \value{ For the default case or for sftrans.Zpg, an object of class "Zpg", containing the list elements: \describe{ \item{z}{complex vector of the zeros of the transformed model} \item{p}{complex vector of the poles of the transformed model} \item{g}{gain of the transformed model} } For sftrans.Arma, an object of class "Arma", containing the list elements: \describe{ \item{b}{moving average (MA) polynomial coefficients} \item{a}{autoregressive (AR) polynomial coefficients} } } \description{ Transform band edges of a generic lowpass filter to a filter with different band edges and to other filter types (high pass, band pass, or band stop). } \details{ Given a low pass filter represented by poles and zeros in the splane, you can convert it to a low pass, high pass, band pass or band stop by transforming each of the poles and zeros individually. The following summarizes the transformations: \if{latex}{ \tabular{lll}{ \strong{Transform} \tab \strong{Zero at x} \tab \strong{Pole at x} \cr ------------------------- \tab ------------------------- \tab ------------------------- \cr \strong{Low-Pass} \tab zero: \eqn{Fc x/C} \tab pole: \eqn{Fc x/C} \cr \eqn{S \rightarrow C S/Fc} \tab gain: \eqn{C/Fc} \tab gain: \eqn{Fc/C} \cr ------------------------- \tab ------------------------- \tab ------------------------- \cr \strong{High Pass} \tab zero: \eqn{Fc C/x} \tab pole: \eqn{Fc C/x} \cr \eqn{S \rightarrow C Fc/S} \tab pole: \eqn{0} \tab zero: \eqn{0} \cr \tab gain: \eqn{-x} \tab gain: \eqn{-1/x} \cr ------------------------- \tab ------------------------- \tab ------------------------- \cr \strong{Band Pass} \tab zero: \eqn{b +- \sqrt{(b^2-FhFl)}} \tab pole: \eqn{b \pm \sqrt{(b^2-FhFl)}} \cr \tab pole: \eqn{0} \tab zero: \eqn{0} \cr S -> \eqn{C \frac{S^2+FhFl}{S(Fh-Fl)}} \tab gain: \eqn{C/(Fh-Fl)} \tab gain: \eqn{(Fh-Fl)/C} \cr \tab \eqn{b=x/C (Fh-Fl)/2} \tab \eqn{b=x/C (Fh-Fl)/2} \cr ------------------------- \tab ------------------------- \tab ------------------------- \cr \strong{Band Stop} \tab zero: \eqn{b \pm \sqrt{(b^2-FhFl)}} \tab pole: \eqn{b +- \sqrt{(b^2-FhFl)}} \cr \tab pole: \eqn{\pm \sqrt{(-FhFl)}} \tab zero: \eqn{\pm \sqrt{(-FhFl)}} \cr S -> \eqn{C \frac{S(Fh-Fl)}{S^2+FhFl}} \tab gain: \eqn{-x} \tab gain: \eqn{-1/x} \cr \tab \eqn{b=C/x (Fh-Fl)/2} \tab \eqn{b=C/x (Fh-Fl)/2} \cr ------------------------- \tab ------------------------- \tab ------------------------- \cr \strong{Bilinear} \tab zero: \eqn{(2+xT)/(2-xT)} \tab pole: \eqn{(2+xT)/(2-xT)} \cr \tab pole: \eqn{-1} \tab zero: \eqn{-1} \cr \eqn{S \rightarrow \frac{2 z-1}{T z+1}} \tab gain: \eqn{(2-xT)/T} \tab gain: \eqn{(2-xT)/T} \cr ------------------------- \tab ------------------------- \tab ------------------------- \cr }} \if{html}{\preformatted{ Transform Zero at x Pole at x ---------------- ------------------------- -------------------------- Low-Pass zero: Fc x/C pole: Fc x/C S -> C S/Fc gain: C/Fc gain: Fc/C ---------------- ------------------------- -------------------------- High Pass zero: Fc C/x pole: Fc C/x S -> C Fc/S pole: 0 zero: 0 gain: -x gain: -1/x ---------------- ------------------------- -------------------------- Band Pass zero: b +- sqrt(b^2-FhFl) pole: b +- sqrt(b^2-FhFl) S^2+FhFl pole: 0 zero: 0 S -> C -------- gain: C/(Fh-Fl) gain: (Fh-Fl)/C S(Fh-Fl) b=x/C (Fh-Fl)/2 b=x/C (Fh-Fl)/2 ---------------- ------------------------- -------------------------- Band Stop zero: b +- sqrt(b^2-FhFl) pole: b +- sqrt(b^2-FhFl) S(Fh-Fl) pole: +-sqrt(-FhFl) zero: +-sqrt(-FhFl) S -> C -------- gain: -x gain: -1/x S^2+FhFl b=C/x (Fh-Fl)/2 b=C/x (Fh-Fl)/2 ---------------- ------------------------- -------------------------- Bilinear zero: (2+xT)/(2-xT) pole: (2+xT)/(2-xT) 2 z-1 pole: -1 zero: -1 S -> ----- gain: (2-xT)/T gain: (2-xT)/T T z+1 ---------------- ------------------------- -------------------------- }} where C is the cutoff frequency of the initial lowpass filter, F_c is the edge of the target low/high pass filter and [F_l,F_h] are the edges of the target band pass/stop filter. With abundant tedious algebra, you can derive the above formulae yourself by substituting the transform for S into \eqn{H(S)=S-x} for a zero at x or \eqn{H(S)=1/(S-x)} for a pole at x, and converting the result into the form: \deqn{g prod(S-Xi) / prod(S-Xj)} Please note that a pole and a zero at the same place exactly cancel. This is significant for High Pass, Band Pass and Band Stop filters which create numerous extra poles and zeros, most of which cancel. Those which do not cancel have a fill-in effect, extending the shorter of the sets to have the same number of as the longer of the sets of poles and zeros (or at least split the difference in the case of the band pass filter). There may be other opportunistic cancellations, but it does not check for them. Also note that any pole on the unit circle or beyond will result in an unstable filter. Because of cancellation, this will only happen if the number of poles is smaller than the number of zeros and the filter is high pass or band pass. The analytic design methods all yield more poles than zeros, so this will not be a problem. } \examples{ ## 6th order Bessel bandpass zpg <- besselap(6) bp <- sftrans(zpg, c(2, 3), stop = TRUE) freqs(bp, seq(0, 4, length.out = 128)) bp <- sftrans(zpg, c(0.1,0.3), stop = FALSE) freqs(bp, seq(0, 4, length.out = 128)) } \references{ Proakis & Manolakis (1992). \emph{Digital Signal Processing}. New York: Macmillan Publishing Company. } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Tom Short,\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/Zpg.Rd0000644000176200001440000000330014420222025013465 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Zpg.R \name{Zpg} \alias{Zpg} \alias{as.Zpg} \alias{as.Zpg.Arma} \alias{as.Zpg.Ma} \alias{as.Zpg.Sos} \alias{as.Zpg.Zpg} \title{Zero pole gain model} \usage{ Zpg(z, p, g) as.Zpg(x, ...) ## S3 method for class 'Arma' as.Zpg(x, ...) ## S3 method for class 'Ma' as.Zpg(x, ...) ## S3 method for class 'Sos' as.Zpg(x, ...) ## S3 method for class 'Zpg' as.Zpg(x, ...) } \arguments{ \item{z}{complex vector of the zeros of the model.} \item{p}{complex vector of the poles of the model.} \item{g}{overall gain of the model.} \item{x}{model to be converted.} \item{...}{additional arguments (ignored).} } \value{ A list of class Zpg with the following list elements: \describe{ \item{z}{complex vector of the zeros of the model} \item{p}{complex vector of the poles of the model} \item{g}{gain of the model} } } \description{ Create an zero pole gain model of an ARMA filter, or convert other forms to a Zpg model. } \details{ \code{as.Zpg} converts from other forms, including \code{Arma} and \code{Ma}. } \examples{ ## design notch filter at pi/4 radians = 0.5/4 = 0.125 * fs w = pi/4 # 2 poles, 2 zeros # zeroes at r = 1 r <- 1 z1 <- r * exp(1i * w) z2 <- r * exp(1i * -w) # poles at r = 0.9 r = 0.9 p1 <- r * exp(1i * w) p2 <- r * exp(1i * -w) zpg <- Zpg(c(z1, z2), c(p1, p2), 1) zplane(zpg) freqz(zpg) ## Sharper edges: increase distance between zeros and poles r = 0.8 p1 <- r * exp(1i * w) p2 <- r * exp(1i * -w) zpg <- Zpg(c(z1, z2), c(p1, p2), 1) zplane(zpg) freqz(zpg) } \seealso{ See also \code{\link{Arma}} } \author{ Tom Short, \email{tshort@eprisolutions.com},\cr adapted by Geert van Boxtel, \email{gjmvanboxtel@gmail.com}. } gsignal/man/kaiser.Rd0000644000176200001440000000277514420222025014222 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/kaiser.R \name{kaiser} \alias{kaiser} \title{Kaiser window} \usage{ kaiser(n, beta = 0.5) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{beta}{Shape factor, specified as a positive real scalar. The parameter \code{beta} affects the side lobe attenuation of the Fourier transform of the window. Default: 0.5} } \value{ Kaiser window, returned as a vector. } \description{ Return the filter coefficients of a kaiser window of length \code{n}. } \details{ The Kaiser, or Kaiser-Bessel, window is a simple approximation of the DPSS window using Bessel functions, discovered by James Kaiser. \if{latex}{ \deqn{w(x) = \frac{besselI(0, \beta \cdot \sqrt{(1 - (2*x/m)^{2}))}}{besselI(0, \beta)}; -m/2 <= x <= m/2} } \if{html}{\preformatted{ besselI(0, Beta * sqrt(1-(2*x/m)^2)) k(x) = -------------------------------------, -m/2 <= x <= m/2 besselO(0, Beta) }} The variable parameter \eqn{\beta} determines the trade-off between main lobe width and side lobe levels of the spectral leakage pattern. Increasing \eqn{\beta} widens the main lobe and decreases the amplitude of the side lobes (i.e., increases the attenuation). } \examples{ k <- kaiser(200, 2.5) plot (k, type = "l", xlab = "Samples", ylab =" Amplitude") } \author{ Kurt Hornik, \email{Kurt.Hornik@ci.tuwien.ac.at},\cr Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/peak2peak.Rd0000644000176200001440000000374214420222025014602 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/peak2peak.R \name{peak2peak} \alias{peak2peak} \title{Maximum-to-minimum difference} \usage{ peak2peak(x, MARGIN = 2) } \arguments{ \item{x}{the data, expected to be a vector, a matrix, an array.} \item{MARGIN}{a vector giving the subscripts which the function will be applied over. E.g., for a matrix 1 indicates rows, 2 indicates columns, c(1, 2) indicates rows and columns. Where \code{x} has named dimnames, it can be a character vector selecting dimension names. Default: 2 (columns)} } \value{ Vector or array of values containing the maximum-to-minimum differences of the specified \code{MARGIN} of \code{x}. } \description{ Compute the maximum-to-minimum difference of the input data \code{x}. } \details{ The input \code{x} can be a vector, a matrix or an array. If the input is a vector, a single value is returned representing the maximum-to-minimum difference of the vector. If the input is a matrix or an array, a vector or an array of values is returned representing the maximum-to-minimum differences of the dimensions of \code{x} indicated by the \code{MARGIN} argument. Support for complex valued input is provided. In this case, the function \code{peak2peak} identifies the maximum and minimum in complex magnitude, and then subtracts the complex number with the minimum modulus from the complex number with the maximum modulus. } \examples{ ## numeric vector x <- c(1:5) pp <- peak2peak(x) ## numeric matrix x <- matrix(c(1,2,3, 100, 150, 200, 1000, 1500, 2000), 3, 3) pp <- peak2peak(x) pp <- peak2peak(x, 1) ## numeric array x <- array(c(1, 1.5, 2, 100, 150, 200, 1000, 1500, 2000, 10000, 15000, 20000), c(2,3,2)) pp <- peak2peak(x, 1) pp <- peak2peak(x, 2) pp <- peak2peak(x, 3) ## complex input x <- c(1+1i, 2+3i, 3+5i, 4+7i, 5+9i) pp <- peak2peak(x) } \author{ Georgios Ouzounis, \email{ouzounis_georgios@hotmail.com}.\cr Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/downsample.Rd0000644000176200001440000000226614420222025015110 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/downsample.R \name{downsample} \alias{downsample} \title{Decrease sample rate} \usage{ downsample(x, n, phase = 0) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{n}{downsampling factor, specified as a positive integer.} \item{phase}{offset, specified as a positive integer from \code{0} to \code{n - 1}. Default: 0.} } \value{ Downsampled signal, returned as a vector or matrix. } \description{ Downsample a signal by an integer factor. } \details{ For most signals you will want to use \code{\link{decimate}} instead since it prefilters the high frequency components of the signal and avoids aliasing effects. } \examples{ x <- seq_len(10) xd <- downsample(x, 3) # returns 1 4 7 10 xd <- downsample(x, 3, 2) # returns 3 6 9 x <- matrix(seq_len(12), 4, 3, byrow = TRUE) xd <- downsample(x, 3) } \seealso{ \code{\link{decimate}}, \code{\link{resample}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/barthannwin.Rd0000644000176200001440000000240714420222025015247 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/barthannwin.R \name{barthannwin} \alias{barthannwin} \title{Modified Bartlett-Hann window} \usage{ barthannwin(n) } \arguments{ \item{n}{Window length, specified as a positive integer.} } \value{ Modified Bartlett-Hann window, returned as a vector. If you specify a one-point window \code{(n = 1)}, the value 1 is returned. } \description{ Return the filter coefficients of a modified Bartlett-Hann window. } \details{ Like Bartlett, Hann, and Hamming windows, the Bartlett-Hann window has a mainlobe at the origin and asymptotically decaying sidelobes on both sides. It is a linear combination of weighted Bartlett and Hann windows with near sidelobes lower than both Bartlett and Hann and with far sidelobes lower than both Bartlett and Hamming windows. The mainlobe width of the modified Bartlett-Hann window is not increased relative to either Bartlett or Hann window mainlobes. } \examples{ t <- barthannwin(64) plot (t, type = "l", xlab = "Samples", ylab =" Amplitude") } \seealso{ \code{\link{bartlett}}, \code{\link{hann}}, \code{\link{hamming}} } \author{ Andreas Weingessel, \email{Andreas.Weingessel@ci.tuwien.ac.at}. Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/czt.Rd0000644000176200001440000000545514420222025013542 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/czt.R \name{czt} \alias{czt} \title{Chirp Z-transform} \usage{ czt(x, m = NROW(x), w = exp(complex(real = 0, imaginary = -2 * pi/m)), a = 1) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{m}{transform length, specified as a positive integer scalar. Default: \code{NROW(x)}.} \item{w}{ratio between spiral contour points in each step (i.e., radius increases exponentially, and angle increases linearly), specified as a complex scalar. Default: \code{exp(0-1i * 2 * pi / m)}.} \item{a}{initial spiral contour point, specified as a complex scalar. Default: 1.} } \value{ Chirp Z-transform, returned as a vector or matrix. } \description{ Compute the Chirp Z-transform along a spiral contour on the z-plane. } \details{ The chirp Z-transform (CZT) is a generalization of the discrete Fourier transform (DFT). While the DFT samples the Z plane at uniformly-spaced points along the unit circle, the chirp Z-transform samples along spiral arcs in the Z-plane, corresponding to straight lines in the S plane. The DFT, real DFT, and zoom DFT can be calculated as special cases of the CZT[1]. For the specific case of the DFT, \code{a = 0}, \code{m = NCOL(x)}, and \code{w = 2 * pi / m}[2, p. 656]. } \examples{ fs <- 1000 # sampling frequency secs <- 10 # number of seconds t <- seq(0, secs, 1/fs) # time series x <- sin(100 * 2 * pi * t) + runif(length(t)) # 100 Hz signal + noise m <- 32 # n of points desired f0 <- 75; f1 <- 175; # desired freq range w <- exp(-1i * 2 * pi * (f1 - f0) / ((m - 1) * fs)) # freq step of f1-f0/m a <- exp(1i * 2 * pi * f0 / fs); # starting at freq f0 y <- czt(x, m, w, a) # compare DFT and FFT fs <- 1000 h <- as.numeric(fir1(100, 125/(fs / 2), type = "low")) m <- 1024 y <- stats::fft(postpad(h, m)) f1 <- 75; f2 <- 175; w <- exp(-1i * 2 * pi * (f2 - f1) / (m * fs)) a <- exp(1i * 2 * pi * f1 / fs) z <- czt(h, m, w, a) fn <- seq(0, m - 1, 1) / m fy <- fs * fn fz = (f2 - f1) * fn + f1 plot(fy, 10 * log10(abs(y)), type = "l", xlim = c(50, 200), xlab = "Frequency", ylab = "Magnitude (dB") lines(fz, 10 * log10(abs(z)), col = "red") legend("topright", legend = c("FFT", "CZT"), col=1:2, lty = 1) } \references{ [1] \url{https://en.wikipedia.org/wiki/Chirp_Z-transform}\cr [2]Oppenheim, A.V., Schafer, R.W., and Buck, J.R. (1999). Discrete-Time Signal Processing, 2nd edition. Prentice-Hall. } \author{ Daniel Gunyan.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/rectwin.Rd0000644000176200001440000000143614420222025014410 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rectwin.R \name{rectwin} \alias{rectwin} \title{Rectangular window} \usage{ rectwin(n) } \arguments{ \item{n}{Window length, specified as a positive integer.} } \value{ rectangular window, returned as a vector. } \description{ Return the filter coefficients of a rectangular window of length \code{n}. } \details{ The output of the rectwin function with input \code{n} can also be created using the \code{rep} function: w <- rep(1L, n) } \examples{ r <- rectwin(64) plot (r, type = "l", xlab = "Samples", ylab =" Amplitude", ylim = c(0, 1)) } \seealso{ \code{\link{boxcar}} } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/residuez.Rd0000644000176200001440000000225514420222025014567 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/residuez.R \name{residuez} \alias{residuez} \title{Z-transform partial fraction expansion} \usage{ residuez(b, a) } \arguments{ \item{b}{coefficients of numerator polynomial} \item{a}{coefficients of denominator polynomial} } \value{ A list containing \describe{ \item{r}{vector of filter pole residues of the partial fraction} \item{p}{vector of partial fraction poles} \item{k}{vector containing FIR part, if any (empty if \code{length(b) < length(a)})} } } \description{ Finds the residues, poles, and direct term of a Partial Fraction Expansion of the ratio of two polynomials. } \details{ \code{residuez} converts a discrete time system, expressed as the ratio of two polynomials, to partial fraction expansion, or residue, form. } \examples{ b0 <- 0.05634 b1 <- c(1, 1) b2 <- c(1, -1.0166, 1) a1 <- c(1, -0.683) a2 <- c(1, -1.4461, 0.7957) b <- b0 * conv(b1, b2) a <- conv(a1, a2) res <- residuez(b, a) } \seealso{ \code{\link{residue}}, \code{\link{residued}} } \author{ Julius O. Smith III, \email{jos@ccrma.stanford.edu}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com} } gsignal/man/cl2bp.Rd0000644000176200001440000000362314420222025013737 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cl2bp.R \name{cl2bp} \alias{cl2bp} \title{Constrained L2 bandpass FIR filter design} \usage{ cl2bp(m = 30, w1, w2, up, lo, L = 2048) } \arguments{ \item{m}{degree of cosine polynomial, resulting in a filter of length \code{2 * m + 1}. Must be an even number. Default: 30.} \item{w1, w2}{bandpass filter cutoffs in the range \code{0 <= w1 < w2 <= pi}, where pi is the Nyquist frequency.} \item{up}{vector of 3 upper bounds for c(stopband1, passband, stopband2).} \item{lo}{vector of 3 lower bounds for c(stopband1, passband, stopband2).} \item{L}{search grid size; larger values may improve accuracy, but greatly increase calculation time. Default: 2048, maximum: 1e6.} } \value{ The FIR filter coefficients, a vector of length \code{2 * m + 1}, of class \code{Ma}. } \description{ Constrained least square band-pass FIR filter design without specified transition bands. } \details{ This is a fast implementation of the algorithm cited below. Compared to \code{remez}, it offers implicit specification of transition bands, a higher likelihood of convergence, and an error criterion combining features of both L2 and Chebyshev approaches } \examples{ w1 <- 0.3 * pi w2 <- 0.6 * pi up <- c(0.02, 1.02, 0.02) lo <- c(-0.02, 0.98, -0.02) h <- cl2bp(30, w1, w2, up, lo, 2^11) freqz(h) } \references{ Selesnick, I.W., Lang, M., and Burrus, C.S. (1998) A modified algorithm for constrained least square design of multiband FIR filters without specified transition bands. IEEE Trans. on Signal Processing, 46(2), 497-501. \cr \url{https://www.ece.rice.edu/dsp/software/cl2.shtml} } \seealso{ \code{\link{Ma}}, \code{\link{filter}}, \code{\link{remez}} } \author{ Ivan Selesnick, Rice University, 1995, downloaded from \url{https://www.ece.rice.edu/dsp/software/cl2.shtml}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/findpeaks.Rd0000644000176200001440000001053414420222025014700 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/findpeaks.R \name{findpeaks} \alias{findpeaks} \title{Find local extrema} \usage{ findpeaks( data, MinPeakHeight = .Machine$double.eps, MinPeakDistance = 1, MinPeakWidth = 1, MaxPeakWidth = Inf, DoubleSided = FALSE ) } \arguments{ \item{data}{the data, expected to be a vector or one-dimensional array.} \item{MinPeakHeight}{Minimum peak height (non-negative scalar). Only peaks that exceed this value will be returned. For data taking positive and negative values use the option \code{DoubleSided}. Default: \code{.Machine$double.eps}.} \item{MinPeakDistance}{Minimum separation between peaks (positive integer). Peaks separated by less than this distance are considered a single peak. This distance is also used to fit a second order polynomial to the peaks to estimate their width, therefore it acts as a smoothing parameter. The neighborhood size is equal to the value of \code{MinPeakDistance}. Default: 1.} \item{MinPeakWidth}{Minimum width of peaks (positive integer). The width of the peaks is estimated using a parabola fitted to the neighborhood of each peak. The width is calculated with the formula \eqn{a * (width - x0)^{2} = 1}, where a is the the concavity of the parabola and x0 its vertex. Default: 1.} \item{MaxPeakWidth}{Maximum width of peaks (positive integer). Default: \code{Inf}.} \item{DoubleSided}{Tells the function that data takes positive and negative values. The baseline for the peaks is taken as the mean value of the function. This is equivalent as passing the absolute value of the data after removing the mean. Default: FALSE} } \value{ A list containing the following elements: \describe{ \item{pks}{The value of data at the peaks.} \item{loc}{The index indicating the position of the peaks.} \item{parabol}{A list containing the parabola fitted to each returned peak. The list has two fields, \code{x} and \code{pp}. The field \code{pp} contains the coefficients of the 2nd degree polynomial and \code{x} the extrema of the interval where it was fitted.} \item{height}{The estimated height of the returned peaks (in units of data).} \item{baseline}{The height at which the roots of the returned peaks were calculated (in units of data).} \item{roots}{The abscissa values (in index units) at which the parabola fitted to each of the returned peaks realizes its width as defined below.} } } \description{ Return peak values and their locations of the vector \code{data}. } \details{ Peaks of a positive array of \code{data} are defined as local maxima. For double-sided data, they are maxima of the positive part and minima of the negative part. \code{data} is expected to be a one-dimensional vector. } \examples{ ### demo 1 t <- 2 * pi * seq(0, 1,length = 1024) y <- sin(3.14 * t) + 0.5 * cos(6.09 * t) + 0.1 * sin(10.11 * t + 1 / 6) + 0.1 * sin(15.3 * t + 1 / 3) data1 <- abs(y) # Positive values peaks1 <- findpeaks(data1) data2 <- y # Double-sided peaks2 <- findpeaks(data2, DoubleSided = TRUE) peaks3 <- findpeaks (data2, DoubleSided = TRUE, MinPeakHeight = 0.5) op <- par(mfrow=c(1,2)) plot(t, data1, type="l", xlab="", ylab="") points(t[peaks1$loc], peaks1$pks, col = "red", pch = 1) plot(t, data2, type = "l", xlab = "", ylab = "") points(t[peaks2$loc], peaks2$pks, col = "red", pch = 1) points(t[peaks3$loc], peaks3$pks, col = "red", pch = 4) legend ("topleft", "0: >2*sd, x: >0.5", bty = "n", text.col = "red") par (op) title("Finding the peaks of smooth data is not a big deal") ## demo 2 t <- 2 * pi * seq(0, 1, length = 1024) y <- sin(3.14 * t) + 0.5 * cos(6.09 * t) + 0.1 * sin(10.11 * t + 1 / 6) + 0.1 * sin(15.3 * t + 1 / 3) data <- abs(y + 0.1*rnorm(length(y),1)) # Positive values + noise peaks1 <- findpeaks(data, MinPeakHeight=1) dt <- t[2]-t[1] peaks2 <- findpeaks(data, MinPeakHeight=1, MinPeakDistance=round(0.5/dt)) op <- par(mfrow=c(1,2)) plot(t, data, type="l", xlab="", ylab="") points (t[peaks1$loc],peaks1$pks,col="red", pch=1) plot(t, data, type="l", xlab="", ylab="") points (t[peaks2$loc],peaks2$pks,col="red", pch=1) par (op) title(paste("Noisy data may need tuning of the parameters.\n", "In the 2nd example, MinPeakDistance is used\n", "as a smoother of the peaks")) } \author{ Juan Pablo Carbajal, \email{carbajal@ifi.uzh.ch}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/gauspuls.Rd0000644000176200001440000000263214420222025014577 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gauspuls.R \name{gauspuls} \alias{gauspuls} \title{Gaussian-modulated sinusoidal RF pulse} \usage{ gauspuls(t, fc = 1000, bw = 0.5) } \arguments{ \item{t}{Vector of time values at which the unit-amplitude Gaussian RF pulse is calculated.} \item{fc}{Center frequency of the Gaussian-modulated sinusoidal pulses, specified as a real positive scalar expressed in Hz. Default: 1000} \item{bw}{Fractional bandwidth of the Gaussian-modulated sinusoidal pulses, specified as a real positive scalar.} } \value{ Inphase Gaussian-modulated sinusoidal pulse, returned as a vector of unit amplitude at the times indicated by the time vector t. } \description{ Generate a Gaussian modulated sinusoidal pulse sampled at times \code{t}. } \examples{ fs <- 11025 # arbitrary sample rate t <- seq(-10, 10, 1/fs) yi1 <- gauspuls(t, 0.1, 1) yi2 <- gauspuls(t, 0.1, 2) plot(t, yi1, type="l", xlab = "Time", ylab = "Amplitude") lines(t, yi2, col = "red") fs <- 11025 # arbitrary sample rate f0 <- 100 # pulse train sample rate x <- pulstran (seq(0, 4/f0, 1/fs), seq(0, 4/f0, 1/f0), "gauspuls") plot (0:(length(x)-1) * 1000/fs, x, type="l", xlab = "Time (ms)", ylab = "Amplitude", main = "Gaussian pulse train at 10 ms intervals") } \author{ Sylvain Pelissier, Mike Miller.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/morlet.Rd0000644000176200001440000000216214420222025014234 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/morlet.R \name{morlet} \alias{morlet} \title{Morlet Wavelet} \usage{ morlet(lb = -4, ub = 4, n = 1000) } \arguments{ \item{lb, ub}{Lower and upper bounds of the interval to evaluate the wavelet on. Default: -4 to 4.} \item{n}{Number of points on the grid between \code{lb} and \code{ub} (length of the wavelet). Default: 1000.} } \value{ A list containing 2 variables; \code{x}, the grid on which the Morlet wavelet was evaluated, and \code{psi} (\eqn{\Psi}), the evaluated wavelet on the grid \code{x}. } \description{ Compute the Morlet wavelet on a regular grid. } \details{ The code \code{m <- morlet(lb, ub, n)} returns values of the Morlet wavelet on an \code{n}-point regular grid in the interval \code{c(lb, ub)}. The Morlet waveform is defined as \deqn{\psi(x) = e^{-x^{2}/2} cos (5x)} } \examples{ m <- morlet(-4, 4, 1000) plot(m$x, m$psi, type="l", main = "Morlet Wavelet", xlab = "", ylab = "") } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/pwelch.Rd0000644000176200001440000002147714420222025014226 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pwelch.R \name{pwelch} \alias{pwelch} \alias{plot.pwelch} \alias{print.pwelch} \title{Welch’s power spectral density estimate} \usage{ pwelch( x, window = nextpow2(sqrt(NROW(x))), overlap = 0.5, nfft = if (isScalar(window)) window else length(window), fs = 1, detrend = c("long-mean", "short-mean", "long-linear", "short-linear", "none"), range = if (is.numeric(x)) "half" else "whole" ) \method{plot}{pwelch}( x, xlab = NULL, ylab = NULL, main = NULL, plot.type = c("spectrum", "cross-spectrum", "phase", "coherence", "transfer"), yscale = c("linear", "log", "dB"), ... ) \method{print}{pwelch}( x, plot.type = c("spectrum", "cross-spectrum", "phase", "coherence", "transfer"), yscale = c("linear", "log", "dB"), xlab = NULL, ylab = NULL, main = NULL, ... ) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{window}{If \code{window} is a vector, each segment has the same length as \code{window} and is multiplied by \code{window} before (optional) zero-padding and calculation of its periodogram. If \code{window} is a scalar, each segment has a length of \code{window} and a Hamming window is used. Default: \code{nextpow2(sqrt(length(x)))} (the square root of the length of \code{x} rounded up to the next power of two). The window length must be larger than 3.} \item{overlap}{segment overlap, specified as a numeric value expressed as a multiple of window or segment length. 0 <= overlap < 1. Default: 0.5.} \item{nfft}{Length of FFT, specified as an integer scalar. The default is the length of the \code{window} vector or has the same value as the scalar \code{window} argument. If \code{nfft} is larger than the segment length, (seg_len), the data segment is padded \code{nfft - seg_len} zeros. The default is no padding. Nfft values smaller than the length of the data segment (or window) are ignored. Note that the use of padding to increase the frequency resolution of the spectral estimate is controversial.} \item{fs}{sampling frequency (Hertz), specified as a positive scalar. Default: 1.} \item{detrend}{character string specifying detrending option; one of: \describe{ \item{\code{long-mean}}{remove the mean from the data before splitting into segments (default)} \item{\code{short-mean}}{remove the mean value of each segment} \item{\code{long-linear}}{remove linear trend from the data before splitting into segments} \item{\code{short-linear}}{remove linear trend from each segment} \item{\code{none}}{no detrending} }} \item{range}{character string. one of: \describe{ \item{\code{"half"} or \code{"onesided"}}{frequency range of the spectrum is from zero up to but not including \code{fs / 2}. Power from negative frequencies is added to the positive side of the spectrum.} \item{\code{"whole"} or \code{"twosided"}}{frequency range of the spectrum is \code{-fs / 2} to \code{fs / 2}, with negative frequencies stored in "wrap around order" after the positive frequencies; e.g. frequencies for a 10-point \code{"twosided"} spectrum are 0 0.1 0.2 0.3 0.4 0.5 -0.4 -0.3 -0.2. -0.1.} \item{\code{"shift"} or \code{"centerdc"}}{same as \code{"whole"} but with the first half of the spectrum swapped with second half to put the zero-frequency value in the middle.} } Default: If \code{x} are real, the default range is \code{"half"}, otherwise the default range is \code{"whole"}.} \item{xlab, ylab, main}{labels passed to plotting function. Default: NULL} \item{plot.type}{character string specifying which plot to produce; one of \code{"spectrum"}, \code{"cross-spectrum"}, \code{"phase"}, \code{"coherence"}, \code{"transfer"}} \item{yscale}{character string specifying scaling of Y-axis; one of \code{"linear"}, \code{"log"}, \code{"dB"}} \item{...}{additional arguments passed to functions} } \value{ An object of class \code{"pwelch"}, which is a list containing the following elements: \describe{ \item{\code{freq}}{vector of frequencies at which the spectral variables are estimated. If \code{x} is numeric, power from negative frequencies is added to the positive side of the spectrum, but not at zero or Nyquist (fs/2) frequencies. This keeps power equal in time and spectral domains. If \code{x} is complex, then the whole frequency range is returned.} \item{\code{spec}}{Vector (for univariate series) or matrix (for multivariate series) of estimates of the spectral density at frequencies corresponding to freq.} \item{\code{cross}}{NULL for univariate series. For multivariateseries, a matrix containing the cross-spectral density estimates between different series. Column \eqn{i + (j - 1) * (j - 2)/2 } of contains the cross-spectral estimates between columns \eqn{i} and \eqn{j} of \eqn{x}, where \eqn{i < j}.} \item{\code{phase}}{NULL for univariate series. For multivariate series, a matrix containing the cross-spectrum phase between different series. The format is the same as \code{cross}.} \item{\code{coh}}{NULL for univariate series. For multivariate series, a matrix containing the squared coherence between different series. The format is the same as \code{cross}.} \item{\code{trans}}{NULL for univariate series. For multivariate series, a matrix containing estimates of the transfer function between different series. The format is the same as \code{cross}.} \item{\code{x_len}}{The length of the input series.} \item{\code{seg_len}}{The length of each segment making up the averages.} \item{\code{psd_len}}{The number of frequencies. See \code{freq}} \item{\code{nseries}}{The number of series} \item{\code{series}}{The name of the series} \item{\code{snames}}{For multivariate input, the names of the individual series} \item{\code{window}}{The window used to compute the modified periodogram} \item{\code{fs}}{The sampling frequency} \item{\code{detrend}}{Character string specifying detrending option} } } \description{ Compute power spectral density (PSD) using Welch's method. } \details{ The Welch method [1] reduces the variance of the periodogram estimate to the PSD by splitting the signal into (usually) overlapping segments and windowing each segment, for instance by a Hamming window. The periodogram is then computed for each segment, and the squared magnitude is computed, which is then averaged for all segments. See also [2]. The spectral density is the mean of the modified periodograms, scaled so that area under the spectrum is the same as the mean square of the data. This equivalence is supposed to be exact, but in practice there is a mismatch of up to 0.5% when comparing area under a periodogram with the mean square of the data. In case of multivariate signals, Cross-spectral density, phase, and coherence are also returned. The input data can be demeaned or detrended, overall or for each segment separately. } \note{ Unlike the 'Octave' function 'pwelch', the current implementation does not compute confidence intervals because they can be inaccurate in case of overlapping segments. } \examples{ fs <- 256 secs <- 10 freq <- 30 ampl <- 1 t <- seq(0, secs, length.out = fs * secs) x <- ampl * cos(freq * 2 * pi * t) + runif(length(t)) Pxx <- pwelch(x, fs = fs) # no plot pwelch(x, fs = fs) # plot # 90 degrees phase shift with with respect to x y <- ampl * sin(freq * 2 * pi * t) + runif(length(t)) Pxy <- pwelch(cbind(x, y), fs = fs) plot(Pxy, yscale = "dB") plot(Pxy, plot.type = "phase") # note the phase shift around 30 Hz is pi/2 plot(Pxy, plot.type = "coherence") # Transfer function estimate example fs <- 1000 # Sampling frequency t <- (0:fs) / fs # One second worth of samples A <- c(1, 2) # Sinusoid amplitudes f <- c(150, 140) # Sinusoid frequencies xn <- A[1] * sin(2 * pi * f[1] * t) + A[2] * sin(2 * pi * f[2] * t) + 0.1 * runif(length(t)) h <- Ma(rep(1L, 10) / 10) # Moving average filter yn <- filter(h, xn) atfm <- freqz(h, fs = fs) etfm <- pwelch(cbind(xn, yn), fs = fs) op <- par(mfrow = c(2, 1)) xl <- "Frequency (Hz)"; yl <- "Magnitude" plot(atfm$w, abs(atfm$h), type = "l", main = "Actual", xlab = xl, ylab = yl) plot(etfm$freq, abs(etfm$trans), type = "l", main = "Estimated", xlab = xl, ylab = yl) par(op) } \references{ [1] Welch, P.D. (1967). The use of Fast Fourier Transform for the estimation of power spectra: A method based on time averaging over short, modified periodograms. IEEE Transactions on Audio and Electroacoustics, AU-15 (2): 70–73.\cr [2] \url{https://en.wikipedia.org/wiki/Welch\%27s_method} } \author{ Peter V. Lanspeary \email{pvl@mecheng.adelaide.edu.au}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/peak2rms.Rd0000644000176200001440000000342014420222025014454 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/peak2rms.R \name{peak2rms} \alias{peak2rms} \title{Peak-magnitude-to-RMS ratio} \usage{ peak2rms(x, MARGIN = 2) } \arguments{ \item{x}{the data, expected to be a vector, a matrix, an array.} \item{MARGIN}{a vector giving the subscripts which the function will be applied over. E.g., for a matrix 1 indicates rows, 2 indicates columns, c(1, 2) indicates rows and columns. Where \code{x} has named dimnames, it can be a character vector selecting dimension names. Default: 2 (usually columns)} } \value{ Vector or array of values containing the peak-magnitude-to-RMS ratios of the specified \code{MARGIN} of \code{x}. } \description{ Compute the ratio of the largest absolute value to the root-mean-square (RMS) value of the object \code{x}. } \details{ The input \code{x} can be a vector, a matrix or an array. If the input is a vector, a single value is returned representing the peak-magnitude-to-RMS ratio of the vector. If the input is a matrix or an array, a vector or an array of values is returned representing the peak-magnitude-to-RMS ratios of the dimensions of \code{x} indicated by the \code{MARGIN} argument. Support for complex valued input is provided. } \examples{ ## numeric vector x <- c(1:5) p <- peak2rms(x) ## numeric matrix x <- matrix(c(1,2,3, 100, 150, 200, 1000, 1500, 2000), 3, 3) p <- peak2rms(x) p <- peak2rms(x, 1) ## numeric array x <- array(c(1, 1.5, 2, 100, 150, 200, 1000, 1500, 2000, 10000, 15000, 20000), c(2,3,2)) p <- peak2rms(x, 1) p <- peak2rms(x, 2) p <- peak2rms(x, 3) ## complex input x <- c(1+1i, 2+3i, 3+5i, 4+7i, 5+9i) p <- peak2rms(x) } \author{ Andreas Weber, \email{octave@tech-chat.de}.\cr Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/xcorr.Rd0000644000176200001440000001067314420222025014075 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/xcorr.R \name{xcorr} \alias{xcorr} \title{Cross-correlation} \usage{ xcorr( x, y = NULL, maxlag = if (is.matrix(x)) nrow(x) - 1 else max(length(x), length(y)) - 1, scale = c("none", "biased", "unbiased", "coeff") ) } \arguments{ \item{x}{Input, numeric or complex vector or matrix. Must not be missing.} \item{y}{Input, numeric or complex vector data. If \code{x} is a matrix (not a vector), \code{y} must be omitted. \code{y} may be omitted if \code{x} is a vector; in this case \code{xcorr} estimates the autocorrelation of \code{x}.} \item{maxlag}{Integer scalar. Maximum correlation lag. If omitted, the default value is \code{N-1}, where \code{N} is the greater of the lengths of \code{x} and \code{y} or, if \code{x} is a matrix, the number of rows in \code{x}.} \item{scale}{Character string. Specifies the type of scaling applied to the correlation vector (or matrix). matched to one of: \describe{ \item{"none"}{return the unscaled correlation, R} \item{"biased"}{return the biased average, R / N} \item{"unbiased"}{return the unbiased average, R(k) / (N - |k|)} \item{"coeff"}{return the correlation coefficient, R / (rms(x) . rms(y))}, where \code{k} is the lag, and \code{N} is the length of \code{x} } If omitted, the default value is \code{"none"}. If \code{y} is supplied but does not have the same length as \code{x}, scale must be \code{"none"}.} } \value{ A list containing the following variables: \describe{ \item{R}{array of correlation estimates} \item{lags}{vector of correlation lags \code{[-maxlag:maxlag]}} } The array of correlation estimates has one of the following forms: \enumerate{ \item Cross-correlation estimate if X and Y are vectors. \item Autocorrelation estimate if is a vector and Y is omitted. \item If \code{x} is a matrix, \code{R} is a matrix containing the cross-correlation estimate of each column with every other column. Lag varies with the first index so that \code{R} has \code{2 * maxlag + 1} rows and \eqn{P^2} columns where \code{P} is the number of columns in \code{x}. } } \description{ Estimate the cross-correlation between two sequences or the autocorrelation of a single sequence } \details{ Estimate the cross correlation R_xy(k) of vector arguments \code{x} and \code{y} or, if \code{y} is omitted, estimate autocorrelation R_xx(k) of vector \code{x}, for a range of lags \code{k} specified by the argument \code{maxlag}. If \code{x} is a matrix, each column of \code{x} is correlated with itself and every other column. The cross-correlation estimate between vectors \code{x} and \code{y} (of length \code{N}) for lag \code{k} is given by \if{latex}{ \deqn{R_{xy}(k) = \sum_{i=1}^{N} x_{i+k} Conj(y_i)} } \if{html}{\preformatted{ N Rxy = SUM x(i+k) . Conj(y(i)) i=1 }} where data not provided (for example \code{x[-1], y[N+1]}) is zero. Note the definition of cross-correlation given above. To compute a cross-correlation consistent with the field of statistics, see xcov. The cross-correlation estimate is calculated by a "spectral" method in which the FFT of the first vector is multiplied element-by-element with the FFT of second vector. The computational effort depends on the length N of the vectors and is independent of the number of lags requested. If you only need a few lags, the "direct sum" method may be faster. } \examples{ ## Create a vector x and a vector y that is equal to x shifted by 5 ## elements to the right. Compute and plot the estimated cross-correlation ## of x and y. The largest spike occurs at the lag value when the elements ## of x and y match exactly (-5). n <- 0:15 x <- 0.84^n y <- pracma::circshift(x, 5) rl <- xcorr(x, y) plot(rl$lag, rl$R, type="h") ## Compute and plot the estimated autocorrelation of a vector x. ## The largest spike occurs at zero lag, when x matches itself exactly. n <- 0:15 x <- 0.84^n rl <- xcorr(x) plot(rl$lag, rl$R, type="h") ## Compute and plot the normalized cross-correlation of vectors ## x and y with unity peak, and specify a maximum lag of 10. n <- 0:15 x <- 0.84^n y <- pracma::circshift(x, 5) rl <- xcorr(x, y, 10, 'coeff') plot(rl$lag, rl$R, type="h") } \seealso{ \code{\link{xcov}}. } \author{ Paul Kienzle, \email{pkienzle@users.sf.net},\cr Asbjorn Sabo, \email{asbjorn.sabo@broadpark.no},\cr Peter Lanspeary. \email{peter.lanspeary@adelaide.edu.au}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/wconv.Rd0000644000176200001440000000374014420222025014071 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/wconv.R \name{wconv} \alias{wconv} \title{1-D or 2-D convolution} \usage{ wconv( type = c("1d", "2d", "row", "column"), a, b, shape = c("full", "same", "valid") ) } \arguments{ \item{type}{Numeric or character, specifies the type of convolution to perform: \describe{ \item{"1d"}{For \code{a} and \code{b} as (coerced to) vectors, perform 1-D convolution of \code{a} and \code{b};} \item{"2d}{For \code{a} and \code{b} as (coerced to) matrices, perform 2-D convolution of \code{a} and \code{b};} \item{"row"}{For \code{a} as (coerced to) a matrix, and \code{b} (coerced to) a vector, perform the 1-D convolution of the rows of \code{a} and \code{b};} \item{"column"}{For \code{a} as (coerced to) a matrix, and \code{b} (coerced to) a vector, perform the 1-D convolution of the colums of \code{a} and \code{b};} }} \item{a, b}{Input vectors or matrices, coerced to numeric.} \item{shape}{Subsection of convolution, partially matched to: \describe{ \item{"full"}{Return the full convolution (default)} \item{"same"}{Return the central part of the convolution with the same size as A. The central part of the convolution begins at the indices \code{floor(c(nrow(b), ncol(b)) / 2 + 1)}} \item{"valid"}{Return only the parts which do not include zero-padded edges. The size of the result is \code{max(c(nrow(a), ncol(b)) - c(nrow(b), ncol(b)) + 1, 0)}} }} } \value{ Convolution of input matrices, returned as a matrix or a vector. } \description{ Compute the one- or two-dimensional convolution of two vectors or matrices. } \examples{ a <- matrix(1:16, 4, 4) b <- matrix(1:9, 3,3) w <- wconv('2', a, b) w <- wconv('1', a, b, 'same') w <- wconv('r', a, b) w <- wconv('r', a, c(0,1), 'same') w <- wconv('c', a, c(0,1), 'valid') } \seealso{ \code{\link{conv}} } \author{ Lukas Reichlin, \email{lukas.reichlin@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/pulstran.Rd0000644000176200001440000001164614420222025014611 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pulstran.R \name{pulstran} \alias{pulstran} \title{Pulse train} \usage{ pulstran( t, d, func, fs = 1, method = c("linear", "nearest", "cubic", "spline"), ... ) } \arguments{ \item{t}{Time values at which \code{func} is evaluated, specified as a vector.} \item{d}{Offset removed from the values of the array \code{t}, specified as a real vector, matrix, or array. You can apply an optional gain factor to each delayed evaluation by specifying \code{d} as a two-column matrix, with offset defined in column 1 and associated gain in column 2. If you specify \code{d} as a vector, the values are interpreted as delays only.} \item{func}{Continuous function used to generate a pulse train based on its samples, specified as 'rectpuls', 'gauspuls', 'tripuls', or a function handle. If you use \code{func} as a function handle, you can pass the function parameters as follows:\cr \code{y <- pulstran(t, d, 'gauspuls', 10e3, bw = 0.5)}.\cr This creates a pulse train using a 10 kHz Gaussian pulse with 50\% bandwidth. Alternatively, \code{func} can be a prototype function, specified as a vector. The interval of the function \code{0} to \code{(length(p) - 1) / fs}, and its samples are identically zero outside this interval. By default, linear interpolation is used for generating delays.} \item{fs}{Sample rate in Hz, specified as a real scalar.} \item{method}{Interpolation method, specified as one of the following options: \describe{ \item{"linear" (default)}{Linear interpolation. The interpolated value at a query point is based on linear interpolation of the values at neighboring grid points in each respective dimension. This is the default interpolation method.} \item{"nearest"}{Nearest neighbor interpolation. The interpolated value at a query point is the value at the nearest sample grid point.} \item{"cubic"}{Shape-preserving piecewise cubic interpolation. The interpolated value at a query point is based on a shape-preserving piecewise cubic interpolation of the values at neighboring grid points.} \item{"spline"}{Spline interpolation using not-a-knot end conditions. The interpolated value at a query point is based on a cubic interpolation of the values at neighboring grid points in each respective dimension.} } Interpolation is performed by the function \code{'interp1'} function in the library \code{'pracma'}, and any interpolation method accepted by the function \code{'interp1'} can be specified here.} \item{...}{Further arguments passed to \code{func}.} } \value{ Pulse train generated by the function, returned as a vector. } \description{ Generate a train of pulses based on samples of a continuous function. } \details{ Generate the signal \code{y <- sum(func(t + d, ...))} for each \code{d}. If \code{d} is a matrix of two columns, the first column is the delay \code{d} and the second column is the amplitude \code{a}, and \code{y <- sum(a * func(t + d))} for each \code{d, a}. Clearly, \code{func} must be a function which accepts a vector of times. Any extra arguments needed for the function must be tagged on the end. If instead of a function name you supply a pulse shape sampled at frequency \code{fs} (default 1 Hz), an interpolated version of the pulse is added at each delay \code{d}. The interpolation stays within the the time range of the delayed pulse. The interpolation method defaults to linear, but it can be any interpolation method accepted by the function \code{interp1} } \examples{ ## periodic rectangular pulse t <- seq(0, 60, 1/1e3) d <- cbind(seq(0, 60, 2), sin(2 * pi * 0.05 * seq(0, 60, 2))) y <- pulstran(t, d, 'rectpuls') plot(t, y, type = "l", xlab = "Time (s)", ylab = "Waveform", main = "Periodic rectangular pulse") ## assymetric sawtooth waveform fs <- 1e3 t <- seq(0, 1, 1/fs) d <- seq(0, 1, 1/3) x <- tripuls(t, 0.2, -1) y <- pulstran(t, d, x, fs) plot(t, y, type = "l", xlab = "Time (s)", ylab = "Waveform", main = "Asymmetric sawtooth waveform") ## Periodic Gaussian waveform fs <- 1e7 tc <- 0.00025 t <- seq(-tc, tc, 1/fs) x <- gauspuls(t, 10e3, 0.5) plot(t, x, type="l", xlab = "Time (s)", ylab = "Waveform", main = "Gaussian pulse") ts <- seq(0, 0.025, 1/50e3) d <- cbind(seq(0, 0.025, 1/1e3), sin(2 * pi * 0.1 * (0:25))) y <- pulstran(ts, d, x, fs) plot(ts, y, type = "l", xlab = "Time (s)", ylab = "Waveform", main = "Gaussian pulse train") # Custom pulse trains fnx <- function(x, fn) sin(2 * pi * fn * x) * exp(-fn * abs(x)) ffs <- 1000 tp <- seq(0, 1, 1/ffs) pp <- fnx(tp, 30) plot(tp, pp, type = "l",xlab = 'Time (s)', ylab = 'Waveform', main = "Custom pulse") fs <- 2e3 t <- seq(0, 1.2, 1/fs) d <- seq(0, 1, 1/3) dd <- cbind(d, 4^-d) z <- pulstran(t, dd, pp, ffs) plot(t, z, type = "l", xlab = "Time (s)", ylab = "Waveform", main = "Custom pulse train") } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/invimpinvar.Rd0000644000176200001440000000272414420222025015300 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/invimpinvar.R \name{invimpinvar} \alias{invimpinvar} \alias{invimpinvar.Arma} \alias{invimpinvar.default} \title{Inverse impulse invariance method} \usage{ invimpinvar(b, ...) \method{invimpinvar}{Arma}(b, ...) \method{invimpinvar}{default}(b, a, fs = 1, tol = 1e-04, ...) } \arguments{ \item{b}{coefficients of numerator polynomial} \item{...}{additional arguments (not used)} \item{a}{coefficients of denominator polynomial} \item{fs}{sampling frequency (Default: 1 Hz)} \item{tol}{tolerance. Default: 0.0001} } \value{ A list of class \code{\link{Arma}} containing numerator and denominator polynomial filter coefficients of the A/D converted filter. } \description{ Convert digital filter with coefficients b and a to analog, conserving impulse response. } \details{ Because \code{invimpinvar} is generic, it can also accept input of class \code{\link{Arma}}. } \examples{ f <- 2 fs <- 10 but <- butter(6, 2 * pi * f, 'low', 's') zbut <- impinvar(but, fs) sbut <- invimpinvar(zbut, fs) all.equal(but, sbut, tolerance = 1e-7) } \references{ Thomas J. Cavicchi (1996) Impulse invariance and multiple-order poles. IEEE transactions on signal processing, Vol 40 (9): 2344--2347. } \seealso{ \code{\link{impinvar}} } \author{ R.G.H. Eschauzier, \email{reschauzier@yahoo.com},\cr Carne Draug, \email{carandraug+dev@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com} } gsignal/man/pei_tseng_notch.Rd0000644000176200001440000000261714420222025016107 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pei_tseng_notch.R \name{pei_tseng_notch} \alias{pei_tseng_notch} \title{Pei-Tseng notch filter} \usage{ pei_tseng_notch(w, bw) } \arguments{ \item{w}{vector of critical frequencies of the filter. Must be between 0 and 1 where 1 is the Nyquist frequency.} \item{bw}{vector of bandwidths. Bw should be of the same length as \code{w}.} } \value{ List of class \code{\link{Arma}} with list elements: \describe{ \item{b}{moving average (MA) polynomial coefficients} \item{a}{autoregressive (AR) polynomial coefficients} } } \description{ Compute the transfer function coefficients of an IIR narrow-band notch filter. } \details{ The filter construction is based on an all-pass which performs a reversal of phase at the filter frequencies. Thus, the mean of the phase-distorted and the original signal has the respective frequencies removed. } \examples{ ## 50 Hz notch filter fs <- 256 nyq <- fs / 2 notch <- pei_tseng_notch(50 / nyq, 2 / nyq) freqz(notch, fs = fs) } \references{ Pei, Soo-Chang, and Tseng, Chien-Cheng "IIR Multiple Notch Filter Design Based on Allpass Filter"; 1996 IEEE Tencon, doi: \doi{10.1109/TENCON.1996.608814} } \seealso{ \code{\link{Arma}}, \code{\link{filter}} } \author{ Alexander Klein, \email{alexander.klein@math.uni-giessen.de}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/ifft.Rd0000644000176200001440000000357714420222025013675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ifft.R \name{ifft} \alias{ifft} \alias{imvfft} \title{Inverse Fast Fourier Transform} \usage{ ifft(x) imvfft(x) } \arguments{ \item{x}{Real or complex vector, array, or matrix.} } \value{ When \code{x} is a vector, the value computed and returned by \code{ifft} is the univariate inverse discrete Fourier transform of the sequence of values in \code{x}. Specifically, \code{y <- ifft(x)} is defined as \code{stats::fft(x, inverse = TRUE) / length(x)}. The \code{stats::fft} function called with \code{inverse = TRUE} replaces \code{exp(-2 * pi...)} with \code{exp(2 * pi)} in the definition of the discrete Fourier transform (see \code{\link[stats]{fft}}). When \code{x} contains an array, \code{ifft} computes and returns the normalized inverse multivariate (spatial) transform. By contrast, \code{imvfft} takes a real or complex matrix as argument, and returns a similar shaped matrix, but with each column replaced by its normalized inverse discrete Fourier transform. This is useful for analyzing vector-valued series. } \description{ Compute the inverse Fast Fourier Transform compatible with 'Matlab' and 'Octave'. } \details{ The \code{'fft'} function in the \code{'stats'} package can compute the inverse FFT by specifying \code{inverse = TRUE}. However, that function does \emph{not} divide the result by \code{length(x)}, nor does it return real values when appropriate. The present function does both, and is this compatible with 'Matlab' and 'Octave' (and differs from the \code{'ifft'} function in the \code{'signal'} package, which does not return real values). } \examples{ res <- ifft(stats::fft(1:5)) res <- ifft(stats::fft(c(1+5i, 2+3i, 3+2i, 4+6i, 5+2i))) res <- imvfft(stats::mvfft(matrix(1:20, 4, 5))) } \seealso{ \code{\link[stats]{fft}} } \author{ Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/grpdelay.Rd0000644000176200001440000000602714420222025014545 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/grpdelay.R \name{grpdelay} \alias{grpdelay} \alias{print.grpdelay} \alias{plot.grpdelay} \alias{grpdelay.default} \alias{grpdelay.Arma} \alias{grpdelay.Ma} \alias{grpdelay.Sos} \alias{grpdelay.Zpg} \title{Group delay} \usage{ grpdelay(filt, ...) \method{print}{grpdelay}(x, ...) \method{plot}{grpdelay}( x, xlab = if (x$HzFlag) "Frequency (Hz)" else "Frequency (rad/sample)", ylab = "Group delay (samples)", type = "l", ... ) \method{grpdelay}{default}(filt, a = 1, n = 512, whole = FALSE, fs = NULL, ...) \method{grpdelay}{Arma}(filt, ...) \method{grpdelay}{Ma}(filt, ...) \method{grpdelay}{Sos}(filt, ...) \method{grpdelay}{Zpg}(filt, ...) } \arguments{ \item{filt}{for the default case, the moving-average coefficients of an ARMA model or filter. Generically, filt specifies an arbitrary model or filter operation.} \item{...}{for methods of grpdelay, arguments are passed to the default method. For plot.grpdelay, additional arguments are passed through to plot.} \item{x}{object to be plotted.} \item{xlab, ylab, type}{as in plot, but with more sensible defaults.} \item{a}{the autoregressive (recursive) coefficients of an ARMA filter.} \item{n}{number of points at which to evaluate the frequency response. If \code{n} is a vector with a length greater than 1, then evaluate the frequency response at these points. For fastest computation, \code{n} should factor into a small number of small primes. Default: 512.} \item{whole}{FALSE (the default) to evaluate around the upper half of the unit circle or TRUE to evaluate around the entire unit circle.} \item{fs}{sampling frequency in Hz. If not specified, the frequencies are in radians.} } \value{ A list of class \code{grpdelay} with items: \describe{ \item{gd}{the group delay, in units of samples. It can be converted to seconds by multiplying by the sampling period (or dividing by the sampling rate fs).} \item{w}{frequencies at which the group delay was calculated.} \item{ns}{number of points at which the group delay was calculated.} \item{Hzflag}{TRUE for frequencies in Hz, FALSE for frequencies in radians.} } } \description{ Compute the average delay of a filter (group delay). } \details{ If the denominator of the computation becomes too small, the group delay is set to zero. (The group delay approaches infinity when there are poles or zeros very close to the unit circle in the z plane.) } \examples{ # Two Zeros and Two Poles b <- poly(c(1 / 0.9 * exp(1i * pi * 0.2), 0.9 * exp(1i * pi * 0.6))) a <- poly(c(0.9 * exp(-1i * pi * 0.6), 1 / 0.9 * exp(-1i * pi * 0.2))) gpd <- grpdelay(b, a, 512, whole = TRUE, fs = 1) print(gpd) plot(gpd) } \references{ \url{https://ccrma.stanford.edu/~jos/filters/Numerical_Computation_Group_Delay.html}\cr \url{https://en.wikipedia.org/wiki/Group_delay} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net},\cr Julius O. Smith III, \email{jos@ccrma.stanford.edu}.\cr Conversion to R by Tom Short,\cr adapted by Geert van Boxtel, \email{gjmvanboxtel@gmail.com} } gsignal/man/shiftdata.Rd0000644000176200001440000000401214420222025014675 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/shiftdata.R \name{shiftdata} \alias{shiftdata} \title{Shift data to operate on specified dimension} \usage{ shiftdata(x, dimx) } \arguments{ \item{x}{The data to be shifted. Can be of any type.} \item{dimx}{Dimension of \code{x} to be shifted to the first column. Named "dimx" instead of "dim" to avoid confusion with R's dim() function. Default: NULL (shift the first nonsingleton dimension)} } \value{ A list containing 3 variables; \code{x}, the shifted data, \code{perm}, the permutation vector, and \code{nshifts}, the number of shifts } \description{ Shift data in to permute the dimension \code{dimx} to the first column. } \details{ \code{shiftdata(x, dimx)} shifts data \code{x} to permute dimension \code{dimx} to the first column using the same permutation as the built-in \code{filter} function. The vector \code{perm} in the output list returns the permutation vector that is used. If \code{dimx} is missing or empty, then the first nonsingleton dimension is shifted to the first column, and the number of shifts is returned in \code{nshifts}. \code{shiftdata} is meant to be used in tandem with \code{unshiftdata}, which shifts the data back to its original shape. These functions are useful for creating functions that work along a certain dimension, like \code{\link{filter}}, \code{\link{sgolayfilt}}, and \code{\link{sosfilt}}. } \examples{ ## create a 3x3 magic square x <- pracma::magic(3) ## Shift the matrix x to work along the second dimension. ## The permutation vector, perm, and the number of shifts, nshifts, ## are returned along with the shifted matrix. sd <- shiftdata(x, 2) ## Shift the matrix back to its original shape. y <- unshiftdata(sd) ## Rearrange Array to Operate on First nonsingleton Dimension x <- 1:5 sd <- shiftdata(x) y <- unshiftdata(sd) } \seealso{ \code{\link{unshiftdata}} } \author{ Georgios Ouzounis, \email{ouzounis_georgios@hotmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/pyulear.Rd0000644000176200001440000000551414420222025014417 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pyulear.R \name{pyulear} \alias{pyulear} \title{Autoregressive PSD estimate - Yule-Walker method} \usage{ pyulear( x, p, freq = 256, fs = 1, range = NULL, method = if (length(freq) == 1 && bitwAnd(freq, freq - 1) == 0) "fft" else "poly" ) } \arguments{ \item{x}{input data, specified as a numeric or complex vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{p}{model order; number of poles in the AR model or limit to the number of poles if a valid criterion is provided. Must be < length(x) - 2.} \item{freq}{vector of frequencies at which power spectral density is calculated, or a scalar indicating the number of uniformly distributed frequency values at which spectral density is calculated. Default: 256.} \item{fs}{sampling frequency (Hz). Default: 1} \item{range}{character string. one of: \describe{ \item{\code{"half"} or \code{"onesided"}}{frequency range of the spectrum is from zero up to but not including \code{fs / 2}. Power from negative frequencies is added to the positive side of the spectrum.} \item{\code{"whole"} or \code{"twosided"}}{frequency range of the spectrum is \code{-fs / 2} to \code{fs / 2}, with negative frequencies stored in "wrap around order" after the positive frequencies; e.g. frequencies for a 10-point \code{'twosided'} spectrum are 0 0.1 0.2 0.3 0.4 0.5 -0.4 -0.3 -0.2. -0.1.} \item{\code{"shift"} or \code{"centerdc"}}{same as \code{"whole"} but with the first half of the spectrum swapped with second half to put the zero-frequency value in the middle. If \code{freq} is vector, \code{"shift"} is ignored.} } Default: If model coefficients \code{a} are real, the default range is \code{"half"}, otherwise the default range is \code{"whole"}.} \item{method}{method used to calculate the power spectral density, either \code{"fft"} (use the Fast Fourier Transform) or \code{"poly"} (calculate the power spectrum as a polynomial). This argument is ignored if the \code{freq} argument is a vector. The default is \code{"poly"} unless the \code{freq} argument is an integer power of 2.} } \value{ An object of class "ar_psd" , which is a list containing two elements, \code{freq} and \code{psd} containing the frequency values and the estimates of power-spectral density, respectively. } \description{ Calculate Yule-Walker autoregressive power spectral density. } \note{ This function is a wrapper for \code{arburg} and \code{ar_psd}. } \examples{ A <- Arma(1, c(1, -2.7607, 3.8106, -2.6535, 0.9238)) y <- filter(A, 0.2 * rnorm(1024)) py <- pyulear(y, 4) } \seealso{ \code{\link{ar_psd}}, \code{\link{arburg}} } \author{ Peter V. Lanspeary, \email{pvl@mecheng.adelaide.edu.au}.\cr Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@gmail.com} } gsignal/man/levinson.Rd0000644000176200001440000000535414420222025014575 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/levinson.R \name{levinson} \alias{levinson} \title{Durbin-Levinson Recursion} \usage{ levinson(acf, p = NROW(acf)) } \arguments{ \item{acf}{autocorrelation function for lags 0 to \code{p}, specified as a vector or matrix. If r is a matrix, the function finds the coefficients for each column of \code{acf} and returns them in the rows of \code{a}.} \item{p}{model order, specified as a positive integer. Default: \code{NROW(acf) - 1}.} } \value{ A \code{list} containing the following elements: \describe{ \item{a}{vector or matrix containing \code{(p+1)} autoregression coefficients. If \code{x} is a matrix, then each row of a corresponds to a column of \code{x}. \code{a} has \code{p + 1} columns.} \item{e}{white noise input variance, returned as a vector. If \code{x} is a matrix, then each element of e corresponds to a column of \code{x}.} \item{k}{Reflection coefficients defining the lattice-filter embodiment of the model returned as vector or a matrix. If \code{x} is a matrix, then each column of \code{k} corresponds to a column of \code{x}. \code{k} has \code{p} rows.} } } \description{ Use the Durbin-Levinson algorithm to compute the coefficients of an autoregressive linear process. } \details{ \code{levinson} uses the Durbin-Levinson algorithm to solve: \deqn{toeplitz(acf(1:p)) * x = -acf(2:p+1)} The solution \code{c(1, x)} is the denominator of an all pole filter approximation to the signal \code{x} which generated the autocorrelation function acf. From ref [2]: Levinson recursion or Levinson–Durbin recursion is a procedure in linear algebra to recursively calculate the solution to an equation involving a Toeplitz matrix. Other methods to process data include Schur decomposition and Cholesky decomposition. In comparison to these, Levinson recursion (particularly split Levinson recursion) tends to be faster computationally, but more sensitive to computational inaccuracies like round-off errors. } \examples{ ## Estimate the coefficients of an autoregressive process given by ## x(n) = 0.1x(n-1) - 0.8x(n-2) - 0.27x(n-3) + w(n). a <- c(1, 0.1, -0.8, -0.27) v <- 0.4 w <- sqrt(v) * rnorm(15000) x <- filter(1, a, w) xc <- xcorr(x, scale = 'biased') acf <- xc$R[-which(xc$lags < 0)] lev <- levinson(acf, length(a) - 1) } \references{ [1] Steven M. Kay and Stanley Lawrence Marple Jr. (1981). Spectrum analysis – a modern perspective. Proceedings of the IEEE, Vol 69, 1380-1419.\cr [2] \url{https://en.wikipedia.org/wiki/Levinson_recursion} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net},\cr Peter V. Lanspeary, \email{pvl@mecheng.adelaide.edu.au}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/sgolayfilt.Rd0000644000176200001440000000466114420222025015115 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sgolayfilt.R \name{filter.sgolayFilter} \alias{filter.sgolayFilter} \alias{sgolayfilt} \title{Savitzky-Golay filtering} \usage{ \method{filter}{sgolayFilter}(filt, x, ...) sgolayfilt(x, p = 3, n = p + 3 - p\%\%2, m = 0, ts = 1) } \arguments{ \item{filt}{Filter characteristics, usually the result of a call to \code{sgolay}} \item{x}{the input signal to be filtered, specified as a vector or as a matrix. If \code{x} is a matrix, each column is filtered.} \item{...}{Additional arguments (ignored)} \item{p}{Polynomial filter order; must be smaller than \code{n}.} \item{n}{Filter length; must a an odd positive integer.} \item{m}{Return the m-th derivative of the filter coefficients. Default: 0} \item{ts}{Scaling factor. Default: 1} } \value{ The filtered signal, of the same dimensions as the input signal. } \description{ Filter a signal with a Savitzky-Golay FIR filter. } \details{ Savitzky-Golay smoothing filters are typically used to "smooth out" a noisy signal whose frequency span (without noise) is large. They are also called digital smoothing polynomial filters or least-squares smoothing filters. Savitzky-Golay filters perform better in some applications than standard averaging FIR filters, which tend to filter high-frequency content along with the noise. Savitzky-Golay filters are more effective at preserving high frequency signal components but less successful at rejecting noise. Savitzky-Golay filters are optimal in the sense that they minimize the least-squares error in fitting a polynomial to frames of noisy data. } \examples{ # Compare a 5 sample averager, an order-5 butterworth lowpass # filter (cutoff 1/3) and sgolayfilt(x, 3, 5), the best cubic # estimated from 5 points. bf <- butter(5, 1/3) x <- c(rep(0, 15), rep(10, 10), rep(0, 15)) sg <- sgolayfilt(x) plot(sg, type="l", xlab = "", ylab = "") lines(filtfilt(rep(1, 5) / 5, 1, x), col = "red") # averaging filter lines(filtfilt(bf, x), col = "blue") # butterworth points(x, pch = "x") # original data legend("topleft", c("sgolay (3,5)", "5 sample average", "order 5 Butterworth", "original data"), lty=c(1, 1, 1, NA), pch = c(NA, NA, NA, "x"), col = c(1, "red", "blue", 1)) } \seealso{ \code{\link{sgolay}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R Tom Short,\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/zp2tf.Rd0000644000176200001440000000146614420222025014005 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/zp2tf.R \name{zp2tf} \alias{zp2tf} \title{Zero-pole-gain to transfer function} \usage{ zp2tf(z, p, g = 1) } \arguments{ \item{z}{complex vector of the zeros of the model} \item{p}{complex vector of the poles of the model} \item{g}{overall gain. Default: 1.} } \value{ A list of class "Arma" with the following list elements: \describe{ \item{b}{moving average (MA) polynomial coefficients} \item{a}{autoregressive (AR) polynomial coefficients} } } \description{ Convert digital filter zero-pole-gain data to transfer function form } \examples{ g <- 1 z <- c(0, 0) p <- pracma::roots(c(1, 0.01, 1)) ba <- zp2tf(z, p, g) } \seealso{ \code{\link{as.Arma}}, \code{\link{filter}} } \author{ Geert van Boxtel, \email{gjmvanboxtel@gmail.com} } gsignal/man/ellip.Rd0000644000176200001440000000677014420222025014050 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ellip.R \name{ellip} \alias{ellip} \alias{ellip.FilterSpecs} \alias{ellip.default} \title{Elliptic filter design} \usage{ ellip(n, ...) \method{ellip}{FilterSpecs}(n, Rp = n$Rp, Rs = n$Rs, w = n$Wc, type = n$type, plane = n$plane, ...) \method{ellip}{default}( n, Rp, Rs, w, type = c("low", "high", "stop", "pass"), plane = c("z", "s"), output = c("Arma", "Zpg", "Sos"), ... ) } \arguments{ \item{n}{filter order.} \item{...}{additional arguments passed to ellip, overriding those given by \code{n} of class \code{FilterSpecs}.} \item{Rp}{dB of passband ripple.} \item{Rs}{dB of stopband ripple.} \item{w}{critical frequencies of the filter. \code{w} must be a scalar for low-pass and high-pass filters, and \code{w} must be a two-element vector \code{c(low, high)} specifying the lower and upper bands in radians/second. For digital filters, w must be between 0 and 1 where 1 is the Nyquist frequency.} \item{type}{filter type, one of \code{"low"}, \code{"high"}, \code{"stop"}, or \code{"pass"}.} \item{plane}{"z" for a digital filter or "s" for an analog filter.} \item{output}{Type of output, one of: \describe{ \item{"Arma"}{Autoregressive-Moving average (aka numerator/denominator, aka b/a)} \item{"Zpg"}{Zero-pole-gain format} \item{"Sos"}{Second-order sections} } Default is \code{"Arma"} for compatibility with the 'signal' package and the 'Matlab' and 'Octave' equivalents, but \code{"Sos"} should be preferred for general-purpose filtering because of numeric stability.} } \value{ Depending on the value of the \code{output} parameter, a list of class \code{\link{Arma}}, \code{\link{Zpg}}, or \code{\link{Sos}} containing the filter coefficients } \description{ Compute the transfer function coefficients of an elliptic filter. } \details{ An elliptic filter is a filter with equalized ripple (equiripple) behavior in both the passband and the stopband. The amount of ripple in each band is independently adjustable, and no other filter of equal order can have a faster transition in gain between the passband and the stopband, for the given values of ripple. As the ripple in the stopband approaches zero, the filter becomes a type I Chebyshev filter. As the ripple in the passband approaches zero, the filter becomes a type II Chebyshev filter and finally, as both ripple values approach zero, the filter becomes a Butterworth filter. Because \code{ellip} is generic, it can be extended to accept other inputs, using \code{ellipord} to generate filter criteria for example. } \examples{ ## compare the frequency responses of 5th-order Butterworth ## and elliptic filters. bf <- butter(5, 0.1) ef <- ellip(5, 3, 40, 0.1) bfr <- freqz(bf) efr <- freqz(ef) plot(bfr$w, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-80, 0), xlab = "Frequency (Rad)", ylab = c("dB"), lwd = 2, main = paste("Elliptic versus Butterworth filter", "low-pass -3 dB cutoff at 0.1 rad", sep = "\n")) lines(efr$w, 20 * log10(abs(efr$h)), col = "red", lwd = 2) legend ("topright", legend = c("Butterworh", "Elliptic"), lty = 1, lwd = 2, col = 1:2) } \references{ \url{https://en.wikipedia.org/wiki/Elliptic_filter} } \seealso{ \code{\link{Arma}}, \code{\link{filter}}, \code{\link{butter}}, \code{\link{cheby1}}, \code{\link{ellipord}} } \author{ Paulo Neis, \email{p_neis@yahoo.com.br},\cr adapted by Doug Stewart, \email{dastew@sympatico.ca}.\cr Conversion to R Tom Short,\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/cceps.Rd0000644000176200001440000000442114420222025014027 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cceps.R \name{cceps} \alias{cceps} \title{Complex cepstral analysis} \usage{ cceps(x) } \arguments{ \item{x}{input data, specified as a real vector.} } \value{ Complex cepstrum, returned as a vector. } \description{ Return the complex cepstrum of the input vector. } \details{ Cepstral analysis is a nonlinear signal processing technique that is applied most commonly in speech and image processing, or as a tool to investigate periodic structures within frequency spectra, for instance resulting from echos/reflections in the signal or to the occurrence of harmonic frequencies (partials, overtones). The cepstrum is used in many variants. Most important are the power cepstrum, the complex cepstrum, and real cepstrum. The function \code{cceps} implements the complex cepstrum by computing the inverse of the log-transformed FFT, i.e., \deqn{cceps(x) <- ifft(log(fft(x)))} However, because taking the logarithm of a complex number can lead to unexpected results, the phase of \code{fft(x)} needs to be unwrapped before taking the log. } \note{ This function returns slightly different results in comparison with the 'Matlab' and 'Octave' equivalents. The 'Octave' version does not apply phase unwrapping, but has an optional correction procedure in case of zero phase at \eqn{\pi} radians. The present implementation does apply phase unwrapping so that the correction procedure is unnecessary. The 'Matlab' implementation also applies phase unwrapping, and a circular shift if necessary to avoid zero phase at \eqn{\pi} radians. The circular shift is not done here. In addition, the 'Octave' version shifts the zero frequency to the center of the series, which neither the 'Matlab' nor the present implementation do. } \examples{ ## Generate a sine of frequency 45 Hz, sampled at 100 Hz. fs <- 100 t <- seq(0, 1.27, 1/fs) s1 <- sin(2 * pi * 45 * t) ## Add an echo with half the amplitude and 0.2 s later. s2 <- s1 + 0.5 * c(rep(0L, 20), s1[1:108]) ## Compute the complex cepstrum of the signal. Notice the echo at 0.2 s. cep <- cceps(s2) plot(t, cep, type="l") } \references{ \url{https://en.wikipedia.org/wiki/Cepstrum} } \seealso{ \code{\link{rceps}} } \author{ Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/sinewave.Rd0000644000176200001440000000126514420222025014556 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sinewave.R \name{sinewave} \alias{sinewave} \title{Sine wave} \usage{ sinewave(m, n = m, d = 0) } \arguments{ \item{m}{desired length of the generated series, specified as a positive integer.} \item{n}{rate, of the generated series, specified as a positive integer. Default: \code{m}.} \item{d}{delay, specified as a positive integer. Default: 0.} } \value{ Sine wave, returned as a vector of length \code{m}. } \description{ Generate a discrete sine wave. } \examples{ plot(sinewave(100, 10), type = "l") } \author{ Friedrich Leisch.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/cheb.Rd0000644000176200001440000000205014420222025013627 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cheb.R \name{cheb} \alias{cheb} \title{Chebyshev polynomials} \usage{ cheb(n, x) } \arguments{ \item{n}{Order of the polynomial, specified as a positive integer.} \item{x}{Point or points at which to calculate the Chebyshev polynomial} } \value{ Polynomial of order \code{x}, evaluated at point(s) \code{x}. } \description{ Return the value of the Chebyshev polynomial at specific points. } \details{ The Chebyshev polynomials are defined by the equations: \if{latex}{ \deqn{Tn(x) = cos(n \cdot acos(x), |x|<= 1} \deqn{Tn(x) = cosh(n \cdot acosh(x), |x|> 1} } \if{html}{\preformatted{ Tn(x) = cos(n . acos(x), |x|<= 1 Tn(x) = cosh(n . acosh(x), |x|> 1 }} If \code{x} is a vector, the output is a vector of the same size, where each element is calculated as \eqn{y(i) = Tn(x(i))}. } \examples{ cp <- cheb(5, 1) cp <- cheb(5, c(2,3)) } \author{ André Carezia, \email{acarezia@uol.com.br}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/bohmanwin.Rd0000644000176200001440000000166214420222025014720 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bohmanwin.R \name{bohmanwin} \alias{bohmanwin} \title{Bohman window} \usage{ bohmanwin(n) } \arguments{ \item{n}{Window length, specified as a positive integer.} } \value{ Bohman window, returned as a vector. If you specify a one-point window \code{(n = 1)}, the value 1 is returned. } \description{ Return the filter coefficients of a Bohman window. } \details{ A Bohman window is the convolution of two half-duration cosine lobes. In the time domain, it is the product of a triangular window and a single cycle of a cosine with a term added to set the first derivative to zero at the boundary. } \examples{ b <- bohmanwin(64) plot (b, type = "l", xlab = "Samples", ylab =" Amplitude") } \seealso{ \code{\link{triang}} } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/specgram.Rd0000644000176200001440000001421314420222025014533 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/specgram.R \name{specgram} \alias{specgram} \alias{plot.specgram} \alias{print.specgram} \title{Spectrogram} \usage{ specgram( x, n = min(256, length(x)), fs = 2, window = hanning(n), overlap = ceiling(n/2) ) \method{plot}{specgram}( x, col = grDevices::gray(0:512/512), xlab = "Time", ylab = "Frequency", ... ) \method{print}{specgram}( x, col = grDevices::gray(0:512/512), xlab = "Time", ylab = "Frequency", ... ) } \arguments{ \item{x}{Input signal, specified as a vector.} \item{n}{Size of the FFT window. Default: 256 (or less if \code{x} is shorter).} \item{fs}{Sample rate in Hz. Default: 2} \item{window}{Either an integer indicating the length of a Hanning window, or a vector of values representing the shape of the FFT tapering window. Default: hanning(n)} \item{overlap}{Overlap with previous window. Default: half the window length} \item{col}{Colormap to use for plotting. Default: \code{grDevices::gray(0:512 / 512)}} \item{xlab}{Label for x-axis of plot. Default: \code{"Time"}} \item{ylab}{Label for y-axis of plot. Default: \code{"Frequency"}} \item{...}{Additional arguments passed to the \code{image} plotting function} } \value{ A list of class \code{specgram} consisting of the following elements: \describe{ \item{S}{the complex output of the FFT, one row per slice} \item{f}{the frequency indices corresponding to the rows of S} \item{t}{the time indices corresponding to the columns of S} } } \description{ Spectrogram using short-time Fourier transform. } \details{ Generate a spectrogram for the signal \code{x}. The signal is chopped into overlapping segments of length \code{n}, and each segment is windowed and transformed into the frequency domain using the FFT. The default segment size is 256. If \code{fs} is given, it specifies the sampling rate of the input signal. The argument \code{window} specifies an alternate window to apply rather than the default of \code{hanning(n)}. The argument overlap specifies the number of samples overlap between successive segments of the input signal. The default overlap is \code{length (window)/2}. When results of \code{specgram} are printed, a spectrogram will be plotted. As with \code{lattice} plots, automatic printing does not work inside loops and function calls, so explicit calls to \code{print} or \code{plot} are needed there. The choice of window defines the time-frequency resolution. In speech for example, a wide window shows more harmonic detail while a narrow window averages over the harmonic detail and shows more formant structure. The shape of the window is not so critical so long as it goes gradually to zero on the ends. Step size (which is window length minus overlap) controls the horizontal scale of the spectrogram. Decrease it to stretch, or increase it to compress. Increasing step size will reduce time resolution, but decreasing it will not improve it much beyond the limits imposed by the window size (you do gain a little bit, depending on the shape of your window, as the peak of the window slides over peaks in the signal energy). The range 1-5 msec is good for speech. FFT length controls the vertical scale. Selecting an FFT length greater than the window length does not add any information to the spectrum, but it is a good way to interpolate between frequency points which can make for prettier spectrograms. AFTER you have generated the spectral slices, there are a number of decisions for displaying them. First the phase information is discarded and the energy normalized: \code{S <- abs(S); S <- S / max(S)} Then the dynamic range of the signal is chosen. Since information in speech is well above the noise floor, it makes sense to eliminate any dynamic range at the bottom end. This is done by taking the max of the magnitude and some minimum energy such as minE = -40dB. Similarly, there is not much information in the very top of the range, so clipping to a maximum energy such as maxE = -3dB makes sense: \code{S <- max(S, 10^(minE / 10)); S <- min(S, 10^(maxE / 10))} The frequency range of the FFT is from 0 to the Nyquist frequency of one half the sampling rate. If the signal of interest is band limited, you do not need to display the entire frequency range. In speech for example, most of the signal is below 4 kHz, so there is no reason to display up to the Nyquist frequency of 10 kHz for a 20 kHz sampling rate. In this case you will want to keep only the first 40% of the rows of the returned \code{S} and \code{f}. More generally, to display the frequency range from minF to maxF, you could use the following row index: \code{idx <- (f >= minF & f <= maxF)} Then there is the choice of colormap. A brightness varying colormap such as copper or bone gives good shape to the ridges and valleys. A hue varying colormap such as jet or hsv gives an indication of the steepness of the slopes. In the field that I am working in (neuroscience / electrophysiology) rainbow color palettes such as jet are very often used. This is an unfortunate choice mainly because (a) colors do not have a natural order, and (b) rainbow palettes are not perceptually linear. It would be better to use a grayscale palette or the 'cool-to-warm' scheme. The examples show how to do this in R. The final spectrogram is displayed in log energy scale and by convention has low frequencies on the bottom of the image. } \examples{ sp <- specgram(chirp(seq(-2, 15, by = 0.001), 400, 10, 100, 'quadratic')) specgram(chirp(seq(0, 5, by = 1/8000), 200, 2, 500, "logarithmic"), fs = 8000) # use other color palettes than grayscale jet <- grDevices::colorRampPalette( c("#00007F", "blue", "#007FFF", "cyan", "#7FFF7F", "yellow", "#FF7F00", "red", "#7F0000")) plot(specgram(chirp(seq(0, 5, by = 1/8000), 200, 2, 500, "logarithmic"), fs = 8000), col = jet(20)) c2w <- grDevices::colorRampPalette(colors = c("red", "white", "blue")) plot(specgram(chirp(seq(0, 5, by = 1/8000), 200, 2, 500, "logarithmic"), fs = 8000), col = c2w(50)) } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Tom Short\cr This conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/resample.Rd0000644000176200001440000000430114420222025014537 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/resample.R \name{resample} \alias{resample} \title{Change sampling rate} \usage{ resample(x, p, q, h) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{p, q}{resampling factors, specified as positive integers. \code{p / q} is the resampling factor.} \item{h}{Impulse response of the FIR filter specified as a numeric vector or matrix. If it is a vector, then it represents one FIR filter to may be applied to multiple signals in \code{x}; if it is a matrix, then each column is a separate FIR impulse response. If not specified, a FIR filter based on a Kaiser window is designed.} } \value{ output signal, returned as a vector or matrix. Each column has length \code{ceiling(((length(x) - 1) * p + length(h)) / q)}.. } \description{ Resample using a polyphase algorithm. } \details{ If \code{h} is not specified, this function will design an optimal FIR filter using a Kaiser-Bessel window. The filter length and the parameter \eqn{\beta} are computed based on ref [2], Chapter 7, Eq. 7.63 (p. 476), and Eq. 7.62 (p. 474), respectively. } \examples{ lx <- 60 tx <- seq(0, 360, length.out = lx) x <- sin(2 * pi * tx / 120) # upsample p <- 3; q <- 2 ty <- seq(0, 360, length.out = lx * p / q) y <- resample(x, p, q) # downsample p <- 2; q <- 3 tz <- seq(0, 360, length.out = lx * p / q) z <- resample(x, p, q) # plot plot(tx, x, type = "b", col = 1, pch = 1, xlab = "", ylab = "") points(ty, y, col = 2, pch = 2) points(tz, z, col = 3, pch = 3) legend("bottomleft", legend = c("original", "upsampled", "downsampled"), lty = 1, pch = 1:3, col = 1:3) } \references{ [1] Proakis, J.G., and Manolakis, D.G. (2007). Digital Signal Processing: Principles, Algorithms, and Applications, 4th ed., Prentice Hall, Chap. 6.\cr [2] Oppenheim, A.V., Schafer, R.W., and Buck, J.R. (1999). Discrete-time signal processing, Signal processing series, Prentice-Hall. } \seealso{ \code{\link{kaiser}} } \author{ Eric Chassande-Mottin, \email{ecm@apc.univ-paris7.fr}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/square.Rd0000644000176200001440000000323614420222025014235 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/square.R \name{square} \alias{square} \title{Square wave} \usage{ square(t, duty = 50) } \arguments{ \item{t}{Time array, specified as a vector.} \item{duty}{Duty cycle, specified as a real scalar from 0 to 100. Default: 50.} } \value{ Square wave, returned as a vector. } \description{ Generate a square wave of period \eqn{2\pi} with limits +1 and -1. } \details{ \code{y <- square(t)} generates a square wave with period \eqn{2\pi} for the elements of the time array \code{t}. \code{square} is similar to the sine function but creates a square wave with values of –1 and 1. \code{y <- square(t, duty)} generates a square wave with specified duty cycle \code{duty}. The duty cycle is the percent of the signal period in which the square wave is positive. \if{latex}{ \deqn{duty cycle = \frac{ontime * 100}{ontime + offtime}} } \if{html}{\preformatted{ ontime * 100 duty cycle = ---------------- ontime + offtime }} } \examples{ ## Create a vector of 100 equally spaced numbers from 0 to 3pi. ## Generate a square wave with a period of 2pi. t <- seq(0, 3*pi, length.out = 100) y <- square(t) plot(t/pi, y, type="l", xlab = expression(t/pi), ylab = "") lines (t/pi, sin(t), col = "red") ## Generate a 30 Hz square wave sampled at 1 kHz for 70 ms. ## Specify a duty cycle of 37\%. ## Add white Gaussian noise with a variance of 1/100. t <- seq(0, 0.07, 1/1e3) y <- square(2 * pi * 30 * t, 37) + rnorm(length(t)) / 10 plot(t, y, type="l", xlab = "", ylab = "") } \author{ Paul Kienzle.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/rectpuls.Rd0000644000176200001440000000303514420222025014573 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rectpuls.R \name{rectpuls} \alias{rectpuls} \title{Rectangular pulse} \usage{ rectpuls(t, w = 1) } \arguments{ \item{t}{Sample times of unit rectangular pulse, specified by a vector.} \item{w}{Rectangle width, specified by a positive number. Default: 1} } \value{ Rectangular pulse of unit amplitude, returned as a vector. } \description{ Return samples of the unit-amplitude rectangular pulse at the times indicated by \code{t}. } \details{ \code{y <- rectpuls(t)} returns a continuous, aperiodic, unit-height rectangular pulse at the sample times indicated in array t, centered about t = 0. \code{y <- rectpuls(t, w)} generates a rectangular pulse over the interval from \code{-w/2} to \code{w/2}, sampled at times \code{t}. This is useful with the function \code{pulstran} for generating a series of pulses. } \examples{ fs <- 10e3 t <- seq(-0.1, 0.1, 1/fs) w <- 20e-3 y <- rectpuls(t, w) plot(t, y, type="l", xlab = "Time", ylab = "Amplitude") fs <- 11025 # arbitrary sample rate f0 <- 100 # pulse train sample rate w <- 0.3/f0 # pulse width 1/10th the distance between pulses y <- pulstran (seq(0, 4/f0, 1/fs), seq(0, 4/f0, 1/f0), 'rectpuls', w = w) plot (seq(0, length(y)-1) * 1000/fs, y, type ="l", xlab = "Time (ms)", ylab = "Amplitude", main = "Rectangular pulse train of 3 ms pulses at 10 ms intervals") } \seealso{ \code{\link{pulstran}} } \author{ Paul Kienzle, Mike Miller.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/zplane.Rd0000644000176200001440000000307114420222025014223 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/zplane.R \name{zplane} \alias{zplane} \alias{zplane.Arma} \alias{zplane.Ma} \alias{zplane.Sos} \alias{zplane.Zpg} \alias{zplane.default} \title{Zero-pole plot} \usage{ zplane(filt, ...) \method{zplane}{Arma}(filt, ...) \method{zplane}{Ma}(filt, ...) \method{zplane}{Sos}(filt, ...) \method{zplane}{Zpg}(filt, ...) \method{zplane}{default}(filt, a, ...) } \arguments{ \item{filt}{for the default case, the moving-average coefficients of an ARMA model or filter. Generically, \code{filt} specifies an arbitrary model or filter operation.} \item{...}{additional arguments are passed through to plot.} \item{a}{the autoregressive (recursive) coefficients of an ARMA filter.} } \value{ No value is returned. } \description{ Plot the poles and zeros of a filter or model on the complex Z-plane } \details{ Poles are marked with an \code{x}, and zeros are marked with an \code{o}. } \note{ When results of \code{zplane} are printed, \code{plot} will be called. As with lattice plots, automatic printing does not work inside loops and function calls, so explicit calls to print or plot are needed there. } \examples{ ## elliptic low-pass filter elp <- ellip(4, 0.5, 20, 0.4) zplane(elp) } \references{ \url{https://en.wikipedia.org/wiki/Pole-zero_plot} } \seealso{ \code{\link{freqz}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net},\cr Stefan van der Walt \email{stefan@sun.ac.za},\cr Mike Miller.\cr Conversion to R by Tom Short,\cr adapted by Geert van Boxtel, \email{gjmvanboxtel@gmail.com} } gsignal/man/dct.Rd0000644000176200001440000000345314420222025013510 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dct.R \name{dct} \alias{dct} \title{Discrete Cosine Transform} \usage{ dct(x, n = NROW(x)) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{n}{transform length, specified as a positive integer scalar. Default: \code{NROW(x)}.} } \value{ Discrete cosine transform, returned as a vector or matrix. } \description{ Compute the unitary discrete cosine transform of a signal. } \details{ The discrete cosine transform (DCT) is closely related to the discrete Fourier transform. You can often reconstruct a sequence very accurately from only a few DCT coefficients. This property is useful for applications requiring data reduction. The DCT has four standard variants. This function implements the DCT-II according to the definition in [1], which is the most common variant, and the original variant first proposed for image processing. } \note{ The transform is faster if \code{x} is real-valued and has even length. } \examples{ x <- matrix(seq_len(100) + 50 * cos(seq_len(100) * 2 * pi / 40)) X <- dct(x) # Find which cosine coefficients are significant (approx.) # zero the rest nsig <- which(abs(X) < 1) N <- length(X) - length(nsig) + 1 X[nsig] <- 0 # Reconstruct the signal and compare it to the original signal. xx <- idct(X) plot(x, type = "l") lines(xx, col = "red") legend("bottomright", legend = c("Original", paste("Reconstructed, N =", N)), lty = 1, col = 1:2) } \references{ [1] \url{https://en.wikipedia.org/wiki/Discrete_cosine_transform} } \seealso{ \code{\link{idct}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/impinvar.Rd0000644000176200001440000000244714420222025014565 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/impinvar.R \name{impinvar} \alias{impinvar} \alias{impinvar.Arma} \alias{impinvar.default} \title{Impulse invariance method for A/D filter conversion} \usage{ impinvar(b, ...) \method{impinvar}{Arma}(b, ...) \method{impinvar}{default}(b, a, fs = 1, tol = 1e-04, ...) } \arguments{ \item{b}{coefficients of numerator polynomial} \item{...}{additional arguments (not used)} \item{a}{coefficients of denominator polynomial} \item{fs}{sampling frequency (Default: 1 Hz)} \item{tol}{tolerance. Default: 0.0001} } \value{ A list of class \code{\link{Arma}} containing numerator and denominator polynomial filter coefficients of the A/D converted filter. } \description{ Convert analog filter with coefficients b and a to digital, conserving impulse response. } \details{ Because \code{impinvar} is generic, it can also accept input of class \code{\link{Arma}}. } \examples{ f <- 2 fs <- 10 but <- butter(6, 2 * pi * f, 'low', 's') zbut <- impinvar(but, fs) freqz(zbut, n = 1024, fs = fs) } \seealso{ \code{\link{invimpinvar}} } \author{ Tony Richardson, \email{arichard@stark.cc.oh.us},\cr Ben Abbott, \email{bpabbott@mac.com},\cr adapted by John W. Eaton.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com} } gsignal/man/hamming.Rd0000644000176200001440000000264014420222025014353 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hamming.R \name{hamming} \alias{hamming} \title{Hamming window} \usage{ hamming(n, method = c("symmetric", "periodic")) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{method}{Character string. Window sampling method, specified as: \describe{ \item{"symmetric"}{(Default). Use this option when using windows for filter design.} \item{"periodic"}{This option is useful for spectral analysis because it enables a windowed signal to have the perfect periodic extension implicit in the discrete Fourier transform. When \code{"periodic"} is specified, the function computes a window of length \code{n + 1} and returns the first \code{n} points.} }} } \value{ Hamming window, returned as a vector. If you specify a one-point window \code{(n = 1)}, the value 1 is returned. } \description{ Return the filter coefficients of a Hamming window of length \code{n}. } \details{ The Hamming window is a member of the family of cosine sum windows. } \examples{ h <- hamming(64) plot (h, type = "l", xlab = "Samples", ylab =" Amplitude") hs = hamming(64,'symmetric') hp = hamming(63,'periodic') plot (hs, type = "l", xlab = "Samples", ylab =" Amplitude") lines(hp, col="red") } \author{ Andreas Weingessel, \email{Andreas.Weingessel@ci.tuwien.ac.at}.\cr Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/ultrwin.Rd0000644000176200001440000000467114420222025014445 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ultrwin.R \name{ultrwin} \alias{ultrwin} \title{Ultraspherical window} \usage{ ultrwin(n, mu = 3, xmu = 1) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{mu}{parameter that controls the side-lobe roll-off ratio. Default: 3.} \item{xmu}{parameters that provides a trade-off between the ripple ratio and a width characteristic. Default: 1} } \value{ ultraspherical window, returned as a vector. } \description{ Return the coefficients of an ultraspherical window } \note{ The Dolph-Chebyshev and Saramaki windows are special cases of the Ultraspherical window, with mu set to 0 and 1, respectively. } \examples{ w <- ultrwin(101, 3, 1) plot (w, type = "l", xlab = "Samples", ylab =" Amplitude") freqz(w) w2 <- ultrwin(101, 2, 1) f2 <- freqz(w2) w3 <- ultrwin(101, 3, 1) f3 <- freqz(w3) w4 <- ultrwin(101, 4, 1) f4 <- freqz(w4) op <- par(mfrow = c(2, 1)) plot(w2, type = "l", col = "black", xlab = "", ylab = "") lines(w3, col = "red") lines(w4, col = "blue") legend("topright", legend = 2:4, col = c("black", "red", "blue"), lty = 1) plot (f2$w, 20 * log10(abs(f2$h)), type = "l", col = "black", xlab = "", ylab = "", ylim = c(-100, 50)) lines(f3$w, 20 * log10(abs(f3$h)), col = "red") lines(f4$w, 20 * log10(abs(f4$h)), col = "blue") legend("topright", legend = 2:4, col = c("black", "red", "blue"), lty = 1) par(op) title(main = "Effect of increasing the values of mu (xmu = 1)") w1 <- ultrwin(101, 2, 1) f1 <- freqz(w1) w2 <- ultrwin(101, 2, 1.001) f2 <- freqz(w2) w3 <- ultrwin(101, 2, 1.002) f3 <- freqz(w3) op <- par(mfrow = c(2, 1)) plot(w1, type = "l", col = "black", xlab = "", ylab = "") lines(w2, col = "red") lines(w3, col = "blue") legend("topright", legend = 2:4, col = c("black", "red", "blue"), lty = 1) plot (f1$w, 20 * log10(abs(f1$h)), type = "l", col = "black", xlab = "", ylab = "", ylim = c(-100, 50)) lines(f2$w, 20 * log10(abs(f2$h)), col = "red") lines(f3$w, 20 * log10(abs(f3$h)), col = "blue") legend("topright", legend = c(1, 1.001, 1.002), col = c("black", "red", "blue"), lty = 1) par(op) title(main = "Effect of increasing the values of xmu (mu = 2)") } \references{ [1] Bergen, S.W.A., and Antoniou, A. Design of Ultraspherical Window Functions with Prescribed Spectral Characteristics. EURASIP Journal on Applied Signal Processing 2004:13, 2053–2065. } \author{ Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/cconv.Rd0000644000176200001440000000334614420222025014047 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cconv.R \name{cconv} \alias{cconv} \title{Circular convolution} \usage{ cconv(a, b, n = length(a) + length(b) - 1) } \arguments{ \item{a, b}{Input, coerced to vectors, can be different lengths or data types.} \item{n}{Convolution length, specified as a positive integer. Default: \code{length(a) + length(b) - 1}.} } \value{ Circular convolution of input vectors, returned as a vector. } \description{ Compute the modulo-n circular convolution. } \details{ Linear and circular convolution are fundamentally different operations. Linear convolution of an n-point vector x, and an l-point vector y, has length n + l - 1, and can be computed by the function \code{\link{conv}}, which uses \code{\link{filter}}. The circular convolution, by contrast, is equal to the inverse discrete Fourier transform (DFT) of the product of the vectors' DFTs. For the circular convolution of \code{x} and \code{y} to be equivalent to their linear convolution, the vectors must be padded with zeros to length at least \code{n + l - 1} before taking the DFT. After inverting the product of the DFTs, only the first \code{n + l - 1} elements should be retained. For long sequences circular convolution may be more efficient than linear convolution. You can also use \code{cconv} to compute the circular cross-correlation of two sequences. } \examples{ a <- c(1, 2, -1, 1) b <- c(1, 1, 2, 1, 2, 2, 1, 1) c <- cconv(a, b) # Circular convolution cref = conv(a, b) # Linear convolution all.equal(max(c - cref), 0) cconv(a, b, 6) } \seealso{ \code{\link{conv}}, \code{\link[stats]{convolve}} } \author{ Leonardo Araujo.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/kaiserord.Rd0000644000176200001440000001011014420222025014705 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/kaiserord.R \name{kaiserord} \alias{kaiserord} \title{Kaiser filter order and cutoff frequency} \usage{ kaiserord(f, m, dev, fs = 2) } \arguments{ \item{f}{frequency bands, given as pairs, with the first half of the first pair assumed to start at 0 and the last half of the last pair assumed to end at 1. It is important to separate the band edges, since narrow transition regions require large order filters.} \item{m}{magnitude within each band. Should be non-zero for pass band and zero for stop band. All passbands must have the same magnitude, or you will get the error that pass and stop bands must be strictly alternating.} \item{dev}{deviation within each band. Since all bands in the resulting filter have the same deviation, only the minimum deviation is used. In this version, a single scalar will work just as well.} \item{fs}{sampling rate. Used to convert the frequency specification into the c(0, 1) range, where 1 corresponds to the Nyquist frequency, \code{fs / 2}.} } \value{ A list of class \code{\link{FilterSpecs}} with the following list elements: \describe{ \item{n}{filter order} \item{Wc}{cutoff frequency} \item{type}{filter type, one of "low", "high", "stop", "pass", "DC-0", or "DC-1".} \item{beta}{shape parameter} } } \description{ Return the parameters needed to produce a FIR filter of the desired specification from a Kaiser window. } \details{ Given a set of specifications in the frequency domain, \code{kaiserord} estimates the minimum FIR filter order that will approximately meet the specifications. \code{kaiserord} converts the given filter specifications into passband and stopband ripples and converts cutoff frequencies into the form needed for windowed FIR filter design. \code{kaiserord} uses empirically derived formulas for estimating the orders of lowpass filters, as well as differentiators and Hilbert transformers. Estimates for multiband filters (such as band-pass filters) are derived from the low-pass design formulas. The design formulas that underlie the Kaiser window and its application to FIR filter design are \deqn{\beta =} \deqn{0.1102(\alpha - 8.7), \alpha > 50} \deqn{0.5842(\alpha -21)^{0.4} + 0.07886(\alpha - 21), 21 \le \alpha \le 50} \deqn{0, \alpha < 21} where \eqn{\alpha = -20log_{10}(\delta)} is the stopband attenuation expressed in decibels, \eqn{n=(\alpha - 8) / 2.285(\Delta\omega)}, where \eqn{n} is the filter order and \eqn{\Delta\omega} is the width of the smallest transition region. } \examples{ fs <- 11025 op <- par(mfrow = c(2, 2), mar = c(3, 3, 1, 1)) for (i in 1:4) { if (i == 1) { bands <- c(1200, 1500) mag <- c(1, 0) dev <- c(0.1, 0.1) } if (i == 2) { bands <- c(1000, 1500) mag <- c(0, 1) dev <- c(0.1, 0.1) } if (i == 3) { bands <- c(1000, 1200, 3000, 3500) mag <- c(0, 1, 0) dev <- 0.1 } if (i == 4) { bands <- 100 * c(10, 13, 15, 20, 30, 33, 35, 40) mag <- c(1, 0, 1, 0, 1) dev <- 0.05 } kaisprm <- kaiserord(bands, mag, dev, fs) d <- max(1, trunc(kaisprm$n / 10)) if (mag[length(mag)] == 1 && (d \%\% 2) == 1) { d <- d + 1 } f1 <- freqz(fir1(kaisprm$n, kaisprm$Wc, kaisprm$type, kaiser(kaisprm$n + 1, kaisprm$beta), scale = FALSE), fs = fs) f2 <- freqz(fir1(kaisprm$n - d, kaisprm$Wc, kaisprm$type, kaiser(kaisprm$n - d + 1, kaisprm$beta), scale = FALSE), fs = fs) plot(f1$w, abs(f1$h), col = "blue", type = "l", xlab = "", ylab = "") lines(f2$w, abs(f2$h), col = "red") legend("right", paste("order", c(kaisprm$n-d, kaisprm$n)), col = c("red", "blue"), lty = 1, bty = "n") b <- c(0, bands, fs/2) for (i in seq(2, length(b), by=2)) { hi <- mag[i/2] + dev[1] lo <- max(mag[i/2] - dev[1], 0) lines(c(b[i-1], b[i], b[i], b[i-1], b[i-1]), c(hi, hi, lo, lo, hi)) } } par(op) } \seealso{ \code{\link{hamming}}, \code{\link{kaiser}} } \author{ Paul Kienzle.\cr Conversion to R by Tom Short,\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/uencode.Rd0000644000176200001440000000566314420222025014365 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/uencode.R \name{uencode} \alias{uencode} \title{Uniform encoder} \usage{ uencode(u, n, v = 1, signed = FALSE) } \arguments{ \item{u}{Input, a multidimensional array of numbers, real or complex, single or double precision.} \item{n}{Number of levels used in \eqn{2^{n}}-level quantization. \code{n} must be between 2 and 32} \item{v}{Limit on the range of \code{u} to the range from \code{-v} to \code{v} before saturating them. Default 1.} \item{signed}{Logical indicating signed or unsigned output. See Details. Default: FALSE.} } \value{ Multidimensional array of the same size as \code{u} containing signed or unsigned integers. } \description{ Quantize and encode floating-point inputs to integer outputs. } \details{ \code{y <- uencode(u, n)} quantizes the entries in a multidimensional array of floating-point numbers \code{u} and encodes them as integers using \eqn{2^{n}}-level quantization. \code{n} must be an integer between 2 and 32 (inclusive). Inputs can be real or complex, double- or single-precision. The output \code{y} and the input \code{u} are arrays of the same size. The elements of the output \code{y} are unsigned integers with magnitudes in the range 0 to \eqn{2^{n} - 1}. Elements of the input \code{u} outside of the range -1 to 1 are treated as overflows and are saturated. \itemize{ \item For entries in the input u that are less than -1, the value of the output of uencode is 0. \item For entries in the input u that are greater than 1, the value of the output of uencode is \eqn{2^{n}-1}. } \code{y <- uencode(u, n, v)} allows the input \code{u} to have entries with floating-point values in the range \code{-v} to \code{v} before saturating them (the default value for \code{v} is 1). Elements of the input \code{u} outside of the range \code{-v} to \code{v} are treated as overflows and are saturated: \itemize{ \item For input entries less than \code{-v}, the value of the output of uencode is 0. \item For input entries greater than \code{v}, the value of the output of uencode is \eqn{2^{n} - 1}. } \code{y <- uencode(u, n, v, signed)} maps entries in a multidimensional array of floating-point numbers \code{u} whose entries have values in the range \code{-v} to \code{v} to an integer output \code{y}. Input entries outside this range are saturated. The integer type of the output depends on the number of quantization levels \eqn{2^{n}} and the value of \code{signed}, which can be one of the following: \itemize{ \item TRUE: Outputs are signed integers with magnitudes in the range \eqn{-2^{n} / 2} to \eqn{(2^{n} / 2) - 1}. \item FALSE (default): Outputs are unsigned integers with magnitudes in the range 0 to \eqn{2^{n} - 1}. } } \examples{ u <- seq(-1, 1, 0.01) y <- uencode(u, 3) plot(u, y) } \author{ Georgios Ouzounis, \email{ouzounis_georgios@hotmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/primitive.Rd0000644000176200001440000000213414420222025014741 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/primitive.R \name{primitive} \alias{primitive} \title{Primitive} \usage{ primitive(FUN, t, C = 0) } \arguments{ \item{FUN}{the function to calculate the primitive of.} \item{t}{points at which the function \code{FUN} is evaluated, specified as a vector of ascending values} \item{C}{constant of integration. Default: 0} } \value{ Vector of integrated function values. } \description{ Calculate the indefinitive integral of a function. } \details{ This function is a fancy way of calculating the cumulative sum. } \examples{ f <- function(t) sin(2 * pi * 3 * t) t <- c(0, sort(runif(100))) F <- primitive (f, t, 0) t_true <- seq(0, 1, length.out = 1e3) F_true <- (1 - cos(2 * pi * 3 * t_true)) / (2 * pi * 3) plot (t, F, xlab = "", ylab = "") lines (t_true, F_true, col = "red") legend("topright", legend = c("Numerical primitive", "True primitive"), lty = c(0, 1), pch = c(1, NA), col = 1:2) } \seealso{ \code{\link{cumsum}} } \author{ Juan Pablo Carbajal.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com} } gsignal/man/Arma.Rd0000644000176200001440000000460514420222025013616 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/Arma.R \name{Arma} \alias{Arma} \alias{as.Arma} \alias{as.Arma.Arma} \alias{as.Arma.Ma} \alias{as.Arma.Sos} \alias{as.Arma.Zpg} \title{Autoregressive moving average (ARMA) model} \usage{ Arma(b, a) as.Arma(x, ...) ## S3 method for class 'Arma' as.Arma(x, ...) ## S3 method for class 'Ma' as.Arma(x, ...) ## S3 method for class 'Sos' as.Arma(x, ...) ## S3 method for class 'Zpg' as.Arma(x, ...) } \arguments{ \item{b}{moving average (MA) polynomial coefficients.} \item{a}{autoregressive (AR) polynomial coefficients.} \item{x}{model or filter to be converted to an ARMA representation.} \item{...}{additional arguments (ignored).} } \value{ A list of class \code{'Arma'} with the following list elements: \describe{ \item{b}{moving average (MA) polynomial coefficients} \item{a}{autoregressive (AR) polynomial coefficients} } } \description{ Create an ARMA model representing a filter or system model, or convert other forms to an ARMA model. } \details{ The ARMA model is defined by: \deqn{a(L)y(t) = b(L)x(t)} The ARMA model can define an analog or digital model. The AR and MA polynomial coefficients follow the convention in 'Matlab' and 'Octave' where the coefficients are in decreasing order of the polynomial (the opposite of the definitions for \code{\link[stats]{filter}}filter and \code{\link[base]{polyroot}}). For an analog model, \if{latex}{ \deqn{H(s) = (b_1 s^{(m-1)} + b_2 s^{(m-2)} + \ldots + b_m) / (a_1 s^{(n-1)} + a_2 s^{(n-2)} + \ldots + a_n)} } \if{html}{\preformatted{ H(s) = (b[1]*s^(m-1) + b[2]*s^(m-2) + ... + b[m]) / (a[1]*s^(n-1) + a[2]*s^(n-2) + ... + a[n]) }} For a z-plane digital model, \if{latex}{ \deqn{H(z) = (b_1 + b_2 z^{-1} + \ldots + b_m z^{(-m+1)}) / (a_1 + a_2 z^{-1} + \ldots + a_n z^{(-n+1)})} } \if{html}{\preformatted{ H(z) = (b[1] + b[2]*z^(-1) + … + b[m]*z^(-m+1)) / (a[1] + a[2]*z^(-1) + … + a[n]*z^(-n+1)) }} \code{as.Arma} converts from other forms, including \code{Zpg} and \code{Ma}. } \examples{ filt <- Arma(b = c(1, 2, 1)/3, a = c(1, 1)) zplane(filt) } \seealso{ See also \code{\link{Zpg}}, \code{\link{Ma}}, \code{\link{filter}}, and various filter-generation functions like \code{\link{butter}} and \code{\link{cheby1}} that return Arma models. } \author{ Tom Short, \email{tshort@eprisolutions.com},\cr adapted by Geert van Boxtel, \email{gjmvanboxtel@gmail.com}. } gsignal/man/filter.Rd0000644000176200001440000000752114663323315014240 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/filter.R \name{filter} \alias{filter} \alias{filter.default} \alias{filter.Arma} \alias{filter.Ma} \alias{filter.Sos} \alias{filter.Zpg} \title{Filter a signal} \usage{ filter(filt, ...) \method{filter}{default}(filt, a, x, zi = NULL, ...) \method{filter}{Arma}(filt, x, ...) \method{filter}{Ma}(filt, x, ...) \method{filter}{Sos}(filt, x, ...) \method{filter}{Zpg}(filt, x, ...) } \arguments{ \item{filt}{For the default case, the moving-average coefficients of an ARMA filter (normally called \code{b}), specified as a numeric or complex vector. Generically, \code{filt} specifies an arbitrary filter operation.} \item{...}{additional arguments (ignored).} \item{a}{the autoregressive (recursive) coefficients of an ARMA filter, specified as a numeric or complex vector. If \code{a[1]} is not equal to 1, then filter normalizes the filter coefficients by \code{a[1]}. Therefore, \code{a[1]} must be nonzero.} \item{x}{the input signal to be filtered, specified as a numeric or complex vector or matrix. If \code{x} is a matrix, each column is filtered.} \item{zi}{If \code{zi} is provided, it is taken as the initial state of the system and the final state is returned as zf. The state vector is a vector or a matrix (depending on \code{x}) whose length or number of rows is equal to the length of the longest coefficient vector \code{b} or \code{a} minus one. If \code{zi} is not supplied (NULL), the initial state vector is set to all zeros. Alternatively, \code{zi} may be the character string \code{"zf"}, which specifies to return the final state vector even though the initial state vector is set to all zeros. Default: NULL.} } \value{ The filtered signal, of the same dimensions as the input signal. In case the \code{zi} input argument was specified, a list with two elements is returned containing the variables \code{y}, which represents the output signal, and \code{zf}, which contains the final state vector or matrix. } \description{ Apply a 1-D digital filter compatible with 'Matlab' and 'Octave'. } \details{ The filter is a direct form II transposed implementation of the standard linear time-invariant difference equation: \if{latex}{ \deqn{\sum_{k=0}^{N} a(k+1) y(n-k) + \sum_{k=0}^{M} b(k+1) x(n-k) = 0; 1 \le n \le length(x)} } \if{html}{\preformatted{ N M SUM a(k+1)y(n-k) + SUM b(k+1)x(n-k) = 0; 1 <= n <= length(x) k=0 k=0 }} where \code{N = length(a) - 1} and \code{M = length(b) - 1}. The initial and final conditions for filter delays can be used to filter data in sections, especially if memory limitations are a consideration. See the examples. } \examples{ bf <- butter(3, 0.1) # 10 Hz low-pass filter t <- seq(0, 1, len = 100) # 1 second sample x <- sin(2* pi * t * 2.3) + 0.25 * rnorm(length(t)) # 2.3 Hz sinusoid+noise z <- filter(bf, x) # apply filter plot(t, x, type = "l") lines(t, z, col = "red") ## specify initial conditions ## from Python scipy.signal.lfilter() documentation t <- seq(-1, 1, length.out = 201) x <- (sin(2 * pi * 0.75 * t * (1 - t) + 2.1) + 0.1 * sin(2 * pi * 1.25 * t + 1) + 0.18 * cos(2 * pi * 3.85 * t)) h <- butter(3, 0.05) lab <- max(length(h$b), length(h$a)) - 1 zi <- filtic(h$b, h$a, rep(1, lab), rep(1, lab)) z1 <- filter(h, x) z2 <- filter(h, x, zi * x[1]) plot(t, x, type = "l") lines(t, z1, col = "red") lines(t, z2$y, col = "green") legend("bottomright", legend = c("Original signal", "Filtered without initial conditions", "Filtered with initial conditions"), lty = 1, col = c("black", "red", "green")) } \seealso{ \code{\link{filter_zi}}, \code{\link{sosfilt}} (preferred because it avoids numerical problems). } \author{ Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/chirp.Rd0000644000176200001440000000562314420222025014044 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/chirp.R \name{chirp} \alias{chirp} \title{Chirp signal} \usage{ chirp( t, f0, t1 = 1, f1 = 100, shape = c("linear", "quadratic", "logarithmic"), phase = 0 ) } \arguments{ \item{t}{Time array, specified as a vector.} \item{f0}{Initial instantaneous frequency at time 0, specified as a positive scalar expressed in Hz. Default: 0 Hz for linear and quadratic shapes; 1e-6 for logarithmic shape.} \item{t1}{Reference time, specified as a positive scalar expressed in seconds. Default: 1 sec.} \item{f1}{Instantaneous frequency at time t1, specified as a positive scalar expressed in Hz. Default: 100 Hz.} \item{shape}{Sweep method, specified as \code{"linear"}, \code{"quadratic"}, or \code{"logarithmic"} (see Details). Default: \code{"linear"}.} \item{phase}{Initial phase, specified as a positive scalar expressed in degrees. Default: 0.} } \value{ Chirp signal, returned as an array of the same length as \code{t}. } \description{ Evaluate a chirp signal (frequency swept cosine wave). } \details{ A chirp is a signal in which the frequency changes with time, commonly used in sonar, radar, and laser. The name is a reference to the chirping sound made by birds. The chirp can have one of three shapes: \describe{ \item{"linear"}{Specifies an instantaneous frequency sweep \eqn{f_i(t)} given by \eqn{f_i(t) = f_0 + \beta t}, where \eqn{\beta = (f_1 - f_0) / t_1} and the default value for \eqn{f_0} is 0. The coefficient \eqn{\beta} ensures that the desired frequency breakpoint \eqn{f_1} at time \eqn{t_1} is maintained.} \item{"quadratic"}{Specifies an instantaneous frequency sweep \eqn{f_i(t)} given by \eqn{f_i(t) = f_0 + \beta t^2}, where \eqn{\beta = (f_1 - f_0) / t_1^2} and the default value for \eqn{f_0} is 0. If \eqn{f_0 > f_1} (downsweep), the default shape is convex. If \eqn{f_0 < f_1} (upsweep), the default shape is concave.} \item{"logarithmic"}{Specifies an instantaneous frequency sweep \eqn{f_i(t)} given by \eqn{f_i(t) = f_0 \times \beta t}, where \eqn{\beta = \left( \frac {f_1}{f_0} \right) ^ \frac{1}{t1}} and the default value for \eqn{f_0} is \eqn{10^{-6}}.} } } \examples{ # Shows linear sweep of 100 Hz/sec starting at zero for 5 sec # since the sample rate is 1000 Hz, this should be a diagonal # from bottom left to top right. t <- seq(0, 5, 0.001) y <- chirp (t) specgram (y, 256, 1000) # Shows a quadratic chirp of 400 Hz at t=0 and 100 Hz at t=10 # Time goes from -2 to 15 seconds. specgram(chirp(seq(-2, 15, by = 0.001), 400, 10, 100, "quadratic")) # Shows a logarithmic chirp of 200 Hz at t = 0 and 500 Hz at t = 2 # Time goes from 0 to 5 seconds at 8000 Hz. specgram(chirp(seq(0, 5, by = 1/8000), 200, 2, 500, "logarithmic"), fs = 8000) } \author{ Paul Kienzle, \email{pkienzle@users.sf.net},\cr Mike Miller.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/rceps.Rd0000644000176200001440000000756214420222025014057 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rceps.R \name{rceps} \alias{rceps} \title{Real cepstrum} \usage{ rceps(x, minphase = FALSE) } \arguments{ \item{x}{input data, specified as a real vector.} \item{minphase}{logical (default: \code{FALSE}) indication whether to compute minimum-phase reconstructed signal} } \value{ If \code{minphase} equals \code{FALSE}, the real cepstrum is returned as a vector. If \code{minphase} equals \code{TRUE}, a list is returned containing two vectors; \code{y} containing the real cepstrum, and \code{ym} containing the minimum-phase reconstructed signal } \description{ Return the real cepstrum and minimum-phase reconstruction of a signal } \details{ Cepstral analysis is a nonlinear signal processing technique that is applied most commonly in speech and image processing, or as a tool to investigate periodic structures within frequency spectra, for instance resulting from echos/reflections in the signal or to the occurrence of harmonic frequencies (partials, overtones). The cepstrum is used in many variants. Most important are the power cepstrum, the complex cepstrum, and real cepstrum. The function \code{rceps} implements the real cepstrum by computing the inverse of the log-transformed FFT while discarding phase, i.e., \deqn{rceps(x) <- ifft(log(Mag(fft(x))))} The real cepstrum is related to the power spectrum by the relation \eqn{pceps = 4 * rceps^2}. The function \code{rceps()} can also return a minimum-phase reconstruction of the original signal. The concept of minimum phase originates from filtering theory, and denotes a filter transfer function with all of its poles and zeroes in the Z-transform domain lie inside the unit circle on the complex plane. Such a transfer function represents a stable filter. A minimum-phase signal is a signal that has its energy concentrated near the front of the signal (near time 0). Such signals have many applications, e.g. in seismology and speech analysis. } \examples{ ## Simulate a speech signal with a 70 Hz glottal wave f0 <- 70; fs = 10000 # 100 Hz fundamental, 10 kHz sampling rate a <- Re(poly(0.985 * exp(1i * pi * c(0.1, -0.1, 0.3, -0.3)))) s <- 0.05 * runif(1024) s[floor(seq(1, length(s), fs / f0))] <- 1 x <- filter(1, a, s) ## compute real cepstrum and min-phase of x cep <- rceps(x, TRUE) hx <- freqz(x, fs = fs) hxm <- freqz (cep$ym, fs = fs) len <- 1000 * trunc(min(length(x), length(cep$ym)) / 1000) time <- 0:(len-1) * 1000 / fs op <- par(mfcol = c(2, 2)) plot(time, x[1:len], type = "l", ylim = c(-10, 10), xlab = "Time (ms)", ylab = "Amplitude", main = "Original and reconstructed signals") lines(time, cep$ym[1:len], col = "red") legend("topright", legend = c("original", "reconstructed"), lty = 1, col = c(1, 2)) plot(time, cep$y[1:len], type = "l", xlab = "Quefrency (ms)", ylab = "Amplitude", main = "Real cepstrum") plot (hx$w, log(abs(hx$h)), type = "l", xlab = "Frequency (Hz)", ylab = "Magnitude", main = "Magnitudes are identical") lines(hxm$w, log(abs(hxm$h)), col = "red") legend("topright", legend = c("original", "reconstructed"), lty = 1, col = c(1, 2)) phx <- unwrap(Arg(hx$h)) phym <- unwrap(Arg(hxm$h)) range <- c(round(min(phx, phym)), round(max(phx, phym))) plot (hx$w, phx, type = "l", ylim = range, xlab = "Frequency (Hz)", ylab = "Phase", main = "Unwrapped phase") lines(hxm$w, phym, col = "red") legend("bottomright", legend = c("original", "reconstructed"), lty = 1, col = c(1, 2)) par(op) ## confirm the magnitude spectrum is identical in the signal ## and the reconstruction and that there are peaks in the ## cepstrum at 14 ms intervals corresponding to an F0 of 70 Hz. } \references{ \url{https://en.wikipedia.org/wiki/Minimum_phase} } \seealso{ \code{\link{cceps}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net},\cr Mike Miller.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/clustersegment.Rd0000644000176200001440000000264514420222025016004 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/clustersegment.R \name{clustersegment} \alias{clustersegment} \title{Cluster Segments} \usage{ clustersegment(x) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix, coerced to contain only 0's and 1's, i.e., every nonzero element in \code{x} will be replaced by 1.} } \value{ A list of size \code{nr}, where \code{nr} is the number of rows in \code{x}. Each element of the list contains a matrix with two rows. The first row is the initial index of a sequence of 1’s and the second row is the end index of that sequence. } \description{ Calculate boundary indexes of clusters of 1’s. } \details{ The function calculates the initial index and end index of sequences of 1s rising and falling phases of the signal in \code{x}. The clusters are sought in the rows of the array \code{x}. The function works by finding the indexes of jumps between consecutive values in the rows of \code{x}. } \examples{ (x <- c(0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, 1, 1)) (ranges <- clustersegment(x)) # The first sequence of 1's in x lies in the interval (r <- ranges[1,1]:ranges[2,1]) x <- matrix(as.numeric(runif(30) > 0.4), 3, 10) ranges <- clustersegment(x) x <- c(0, 1.2, 3, -8, 0) ranges <- clustersegment(x) } \author{ Juan Pablo Carbajal, \email{carbajal@ifi.uzh.ch}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/tf2zp.Rd0000644000176200001440000000204714420222025014001 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tf2zp.R \name{tf2zp} \alias{tf2zp} \title{Transfer function to zero-pole-gain form} \usage{ tf2zp(b, a) } \arguments{ \item{b}{moving average (MA) polynomial coefficients, specified as a numeric vector or matrix. In case of a matrix, then each row corresponds to an output of the system. The number of columns of \code{b} must be less than or equal to the length of \code{a}.} \item{a}{autoregressive (AR) polynomial coefficients, specified as a vector.} } \value{ A list of class Zpg with the following list elements: \describe{ \item{z}{complex vector of the zeros of the model (roots of \code{B(z)})} \item{p}{complex vector of the poles of the model (roots of \code{A(z)})} \item{g}{overall gain (\code{B(Inf)})} } } \description{ Convert digital filter transfer function parameters to zero-pole-gain form. } \examples{ b <- c(2, 3) a <- c(1, 1/sqrt(2), 1/4) zpk <- tf2zp(b, a) } \seealso{ \code{\link{filter}} } \author{ Geert van Boxtel, \email{gjmvanboxtel@gmail.com} } gsignal/man/ncauer.Rd0000644000176200001440000000346314420222025014214 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ncauer.R \name{ncauer} \alias{ncauer} \title{ncauer analog filter design} \usage{ ncauer(Rp, Rs, n) } \arguments{ \item{Rp}{dB of passband ripple.} \item{Rs}{dB of stopband ripple.} \item{n}{filter order.} } \value{ A list of class Zpg with the following list elements: \describe{ \item{zero}{complex vector of the zeros of the model} \item{pole}{complex vector of the poles of the model} \item{gain}{gain of the model} } } \description{ Compute the transfer function coefficients of a Cauer analog filter. } \details{ Cauer filters have equal maximum ripple in the passband and the stopband. The Cauer filter has a faster transition from the passband to the stopband than any other class of network synthesis filter. The term Cauer filter can be used interchangeably with elliptical filter, but the general case of elliptical filters can have unequal ripples in the passband and stopband. An elliptical filter in the limit of zero ripple in the passband is identical to a Chebyshev Type 2 filter. An elliptical filter in the limit of zero ripple in the stopband is identical to a Chebyshev Type 1 filter. An elliptical filter in the limit of zero ripple in both passbands is identical to a Butterworth filter. The filter is named after Wilhelm Cauer and the transfer function is based on elliptic rational functions.Cauer-type filters use generalized continued fractions.[1] } \examples{ zpg <- ncauer(1, 40, 5) freqz(zpg) zplane(zpg) } \references{ [1] \url{https://en.wikipedia.org/wiki/Network_synthesis_filters#Cauer_filter} } \seealso{ \code{\link{Zpg}}, \code{\link{filter}}, \code{\link{ellip}} } \author{ Paulo Neis, \email{p_neis@yahoo.com.br}.\cr Conversion to R Tom Short,\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/pad.Rd0000644000176200001440000000414714420222025013503 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pad.R \name{pad} \alias{pad} \alias{prepad} \alias{postpad} \title{Pad data} \usage{ pad(x, l, c = 0, MARGIN = 2, direction = c("both", "pre", "post")) prepad(x, l, c = 0, MARGIN = 2) postpad(x, l, c = 0, MARGIN = 2) } \arguments{ \item{x}{Vector or matrix to be padded} \item{l}{Length of output data along the padding dimension. If \code{length (x) > l}, elements from the beginning (\code{dimension = "pre"}) or the end (\code{direction = "post"}) of \code{x} are removed until a vector of length \code{l} is obtained. If \code{direction = "both"}, values are removed from both ends, and in case of an uneven length the smallest number of elements is removed from the beginning of vector.} \item{c}{Value to be used for the padding (scalar). Must be of the same type as the elements in \code{x}. Default: 0} \item{MARGIN}{A vector giving the subscripts which the function will be applied over. E.g., for a matrix 1 indicates rows, 2 indicates columns, c(1, 2) indicates rows and columns. Where \code{x} has named dimnames, it can be a character vector selecting dimension names. If \code{MARGIN} is larger than the dimensions of \code{x}, the result will have \code{MARGIN} dimensions. Default: 2 (columns).} \item{direction}{Where to pad the array along each dimension. One of the following: \describe{ \item{"pre"}{Before the first element} \item{"post"}{After the last element} \item{"both"}{(default) Before the first and after the last element} }} } \value{ Padded data, returned as a vector or matrix. } \description{ Pre- or postpad the data object \code{x} with the value \code{c} until it is of length \code{l}. } \examples{ v <- 1:24 res <- postpad(v, 30) res <- postpad(v, 20) res <- prepad(v, 30) res <- prepad(v, 20) m <- matrix(1:24, 4, 6) res <- postpad(m, 8, 100) res <- postpad(m, 8, 100, MARGIN = 1) res <- prepad(m, 8, 100) res <- prepad(m, 8, 100, MARGIN = 1) res <- postpad(m, 2) res <- postpad(m, 2, MARGIN = 1) res <- prepad(m, 2) res <- prepad(m, 2, MARGIN = 1) } \author{ Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/tfestimate.Rd0000644000176200001440000001036414420222025015102 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tfestimate.R \name{tfestimate} \alias{tfestimate} \alias{tfe} \title{Transfer Function Estimate} \usage{ tfestimate( x, window = nextpow2(sqrt(NROW(x))), overlap = 0.5, nfft = ifelse(isScalar(window), window, length(window)), fs = 1, detrend = c("long-mean", "short-mean", "long-linear", "short-linear", "none") ) tfe( x, window = nextpow2(sqrt(NROW(x))), overlap = 0.5, nfft = ifelse(isScalar(window), window, length(window)), fs = 1, detrend = c("long-mean", "short-mean", "long-linear", "short-linear", "none") ) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{window}{If \code{window} is a vector, each segment has the same length as \code{window} and is multiplied by \code{window} before (optional) zero-padding and calculation of its periodogram. If \code{window} is a scalar, each segment has a length of \code{window} and a Hamming window is used. Default: \code{nextpow2(sqrt(length(x)))} (the square root of the length of \code{x} rounded up to the next power of two). The window length must be larger than 3.} \item{overlap}{segment overlap, specified as a numeric value expressed as a multiple of window or segment length. 0 <= overlap < 1. Default: 0.5.} \item{nfft}{Length of FFT, specified as an integer scalar. The default is the length of the \code{window} vector or has the same value as the scalar \code{window} argument. If \code{nfft} is larger than the segment length, (seg_len), the data segment is padded \code{nfft - seg_len} zeros. The default is no padding. Nfft values smaller than the length of the data segment (or window) are ignored. Note that the use of padding to increase the frequency resolution of the spectral estimate is controversial.} \item{fs}{sampling frequency (Hertz), specified as a positive scalar. Default: 1.} \item{detrend}{character string specifying detrending option; one of: \describe{ \item{\code{"long-mean"}}{remove the mean from the data before splitting into segments (default)} \item{\code{"short-mean"}}{remove the mean value of each segment} \item{\code{"long-linear"}}{remove linear trend from the data before splitting into segments} \item{\code{"short-linear"}}{remove linear trend from each segment} \item{\code{"none"}}{no detrending} }} } \value{ A list containing the following elements: \describe{ \item{\code{freq}}{vector of frequencies at which the spectral variables are estimated. If \code{x} is numeric, power from negative frequencies is added to the positive side of the spectrum, but not at zero or Nyquist (fs/2) frequencies. This keeps power equal in time and spectral domains. If \code{x} is complex, then the whole frequency range is returned.} \item{\code{trans}}{NULL for univariate series. For multivariate series, a matrix containing the transfer function estimates between different series. Column \eqn{i + (j - 1) * (j - 2)/2 } of \code{coh} contains the cross-spectral estimates between columns \eqn{i} and \eqn{j} of \eqn{x}, where \eqn{i < j}.} } } \description{ Finds a transfer function estimate for signals. } \details{ \code{tfestimate} uses Welch's averaged periodogram method. } \note{ The function \code{tfestimate} (and its deprecated alias \code{tfe}) is a wrapper for the function \code{pwelch}, which is more complete and more flexible. } \examples{ fs <- 1000 f <- 250 t <- seq(0, 1 - 1/fs, 1/fs) s1 <- sin(2 * pi * f * t) + runif(length(t)) s2 <- sin(2 * pi * f * t - pi / 3) + runif(length(t)) rv <- tfestimate(cbind(s1, s2), fs = fs) plot(rv$freq, 10*log10(abs(rv$trans)), type="l", xlab = "Frequency", ylab = "Tranfer Function Estimate (dB)", main = colnames((rv$trans))) h <- fir1(30, 0.2, window = rectwin(31)) x <- rnorm(16384) y <- filter(h, x) tfe <- tfestimate(cbind(x, y), 1024, fs = 500) plot(tfe$freq, 10*log10(abs(tfe$trans)), type="l", xlab = "Frequency", ylab = "Tranfer Function Estimate (dB)", main = colnames((tfe$trans))) } \seealso{ \code{\link{pwelch}} } \author{ Peter V. Lanspeary, \email{pvl@mecheng.adelaide.edu.au}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/remez.Rd0000644000176200001440000000465014420222025014060 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/remez.R \name{remez} \alias{remez} \title{Parks-McClellan optimal FIR filter design} \usage{ remez( n, f, a, w = rep(1, length(f)/2), ftype = c("bandpass", "differentiator", "hilbert"), density = 16 ) } \arguments{ \item{n}{filter order (1 less than the length of the filter).} \item{f}{normalized frequency points, strictly increasing vector in the range [0, 1], where 1 is the Nyquist frequency. The number of elements in the vector is always a multiple of 2.} \item{a}{vector of desired amplitudes at the points specified in \code{f}. \code{f} and \code{a} must be the same length. The length must be an even number.} \item{w}{vector of weights used to adjust the fit in each frequency band. The length of \code{w} is half the length of \code{f} and \code{a}, so there is exactly one weight per band. Default: 1.} \item{ftype}{filter type, matched to one of \code{"bandpass"} (default), \code{"differentiatior"}, or \code{"hilbert"}.} \item{density}{determines how accurately the filter will be constructed. The minimum value is 16 (default), but higher numbers are slower to compute.} } \value{ The FIR filter coefficients, a vector of length \code{n + 1}, of class \code{Ma} } \description{ Parks-McClellan optimal FIR filter design using the Remez exchange algorithm. } \examples{ ## low pass filter f1 <- remez(15, c(0, 0.3, 0.4, 1), c(1, 1, 0, 0)) freqz(f1) ## band pass f <- c(0, 0.3, 0.4, 0.6, 0.7, 1) a <- c(0, 0, 1, 1, 0, 0) b <- remez(17, f, a) hw <- freqz(b, 512) plot(f, a, type = "l", xlab = "Radian Frequency (w / pi)", ylab = "Magnitude") lines(hw$w/pi, abs(hw$h), col = "red") legend("topright", legend = c("Ideal", "Remez"), lty = 1, col = c("black", "red")) } \references{ \url{https://en.wikipedia.org/wiki/Fir_filter} Rabiner, L.R., McClellan, J.H., and Parks, T.W. (1975). FIR Digital Filter Design Techniques Using Weighted Chebyshev Approximations, IEEE Proceedings, vol. 63, pp. 595 - 610.\cr \url{https://en.wikipedia.org/wiki/Parks-McClellan_filter_design_algorithm} } \seealso{ \code{\link{Ma}}, \code{\link{filter}}, \code{\link{fftfilt}}, \code{\link{fir1}} } \author{ Jake Janovetz, \email{janovetz@uiuc.edu},\cr Paul Kienzle, \email{pkienzle@users.sf.net},\cr Kai Habel, \email{kahacjde@linux.zrz.tu-berlin.de}.\cr Conversion to R Tom Short\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/cplxpair.Rd0000644000176200001440000000310614420222025014553 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cplxpair.R \name{cplxpair} \alias{cplxpair} \title{Complex conjugate pairs} \usage{ cplxpair(z, tol = 100 * .Machine$double.eps, MARGIN = 2) } \arguments{ \item{z}{Vector, matrix, or array of complex numbers.} \item{tol}{Weighting factor \code{0 < tol < 1}, which determines the tolerance of matching. Default: \code{100 * .Machine$double.eps}. (This definition differs from the 'Octave' usage).} \item{MARGIN}{Vector giving the subscripts which the function will be applied over. E.g., for a matrix 1 indicates rows, 2 indicates columns, c(1, 2) indicates rows and columns. Where X has named dimnames, it can be a character vector selecting dimension names. Default: 2 (columns).} } \value{ Vector, matrix or array containing ordered complex conjugate pairs by increasing real parts. } \description{ Sort complex numbers into complex conjugate pairs ordered by increasing real part. } \details{ The negative imaginary complex numbers are placed first within each pair. All real numbers (those with \code{abs(Im (z) / z) < tol)} are placed after the complex pairs. An error is signaled if some complex numbers could not be paired and if all complex numbers are not exact conjugates (to within \code{tol}). } \note{ There is no defined order for pairs with identical real parts but differing imaginary parts. } \examples{ r <- rbind(t(cplxpair(exp(2i * pi * 0:4 / 5))), t(exp(2i * pi *c(3, 2, 4, 1, 0) / 5))) } \seealso{ \code{\link{cplxreal}} } \author{ Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/triang.Rd0000644000176200001440000000166414420222025014224 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/triang.R \name{triang} \alias{triang} \title{Triangular window} \usage{ triang(n) } \arguments{ \item{n}{Window length, specified as a positive integer.} } \value{ triangular window, returned as a vector. If you specify a one-point window \code{(n = 1)}, the value 1 is returned. } \description{ Return the filter coefficients of a triangular window of length \code{n}. } \details{ Unlike the Bartlett window, \code{triang} does not go to zero at the edges of the window. For odd \code{n}, \code{triang(n)} is equal to \code{bartlett(m + 2)} except for the zeros at the edges of the window. } \examples{ t <- triang(64) plot (t, type = "l", xlab = "Samples", ylab =" Amplitude") } \seealso{ \code{\link{bartlett}} } \author{ Andreas Weingessel, \email{Andreas.Weingessel@ci.tuwien.ac.at}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/fir1.Rd0000644000176200001440000000360114420222025013572 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fir1.R \name{fir1} \alias{fir1} \title{Window-based FIR filter design} \usage{ fir1( n, w, type = c("low", "high", "stop", "pass", "DC-0", "DC-1"), window = hamming(n + 1), scale = TRUE ) } \arguments{ \item{n}{filter order (1 less than the length of the filter).} \item{w}{band edges, strictly increasing vector in the range c(0, 1), where 1 is the Nyquist frequency. A scalar for highpass or lowpass filters, a vector pair for bandpass or bandstop, or a vector for an alternating pass/stop filter.} \item{type}{character specifying filter type, one of \code{"low"} for a low-pass filter, \code{"high"} for a high-pass filter, \code{"stop"} for a stop-band (band-reject) filter, \code{"pass"} for a pass-band filter, \code{"DC-0"} for a bandpass as the first band of a multiband filter, or \code{"DC-1"} for a bandstop as the first band of a multiband filter. Default: \code{"low"}.} \item{window}{smoothing window. The returned filter is the same shape as the smoothing window. Default: \code{hamming(n + 1)}.} \item{scale}{whether to normalize or not. Use \code{TRUE} (default) or \code{"scale"} to set the magnitude of the center of the first passband to 1, and \code{FALSE} or \code{"noscale"} to not normalize.} } \value{ The FIR filter coefficients, a vector of length \code{n + 1}, of class \code{Ma}. } \description{ FIR filter coefficients for a filter with the given order and frequency cutoff. } \examples{ freqz(fir1(40, 0.3)) freqz(fir1(10, c(0.3, 0.5), "stop")) freqz(fir1(10, c(0.3, 0.5), "pass")) } \references{ \url{https://en.wikipedia.org/wiki/Fir_filter} } \seealso{ \code{\link{Ma}}, \code{\link{filter}}, \code{\link{fftfilt}}, \code{\link{fir2}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}, Conversion to R Tom Short,\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/udecode.Rd0000644000176200001440000000714614420222025014351 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/udecode.R \name{udecode} \alias{udecode} \title{Uniform decoder} \usage{ udecode(u, n, v = 1, saturate = TRUE) } \arguments{ \item{u}{Input, a multidimensional array of integer numbers (can be complex).} \item{n}{Number of levels used in \eqn{2^{n}}-level quantization. \code{n} must be between 2 and 32} \item{v}{Limit on the range of \code{u} to the range from \code{-v} to \code{v} before saturating them. Default 1.} \item{saturate}{Logical indicating to saturate (TRUE, default) or to wrap (FALSE) overflows. See Details.} } \value{ Multidimensional array of the same size as \code{u} containing floating point numbers. } \description{ Decode \eqn{2^n}-level quantized integer inputs to floating-point outputs. } \details{ \code{y <- udecode(u, n)} inverts the operation of \code{uencode} and reconstructs quantized floating-point values from an encoded multidimensional array of integers \code{u}. The input argument \code{n} must be an integer between 2 and 32. The integer \code{n} specifies that there are \eqn{2^{n}} quantization levels for the inputs, so that entries in \code{u} must be either: \itemize{ \item Signed integers in the range \eqn{-2^{n}/2} to \eqn{(2^{n}/2) - 1} \item Unsigned integers in the range 0 to \eqn{2^{n} - 1} } Inputs can be real or complex values of any integer data type. Overflows (entries in u outside of the ranges specified above) are saturated to the endpoints of the range interval. The output has the same dimensions as the input \code{u}. Its entries have values in the range -1 to 1. \code{y <- udecode(u, n, v)} decodes \code{u} such that the output has values in the range \code{-v} to \code{v}, where the default value for \code{v} is 1. \code{y <- udecode(u, n, v, saturate)} decodes \code{u} and treats input overflows (entries in \code{u} outside of the range \code{-v} to \code{v} according to \code{saturate}, which can be set to one of the following: \itemize{ \item TRUE (default). Saturate overflows. \itemize{ \item Entries in signed inputs \code{u} whose values are outside of the range \eqn{-2^{n}/2} to \eqn{(2^{n}/2) – 1} are assigned the value determined by the closest endpoint of this interval. \item Entries in unsigned inputs \code{u} whose values are outside of the range 0 to \eqn{2^{n}-1} are assigned the value determined by the closest endpoint of this interval. } \item FALSE Wrap all overflows according to the following: \itemize{ \item Entries in signed inputs \code{u} whose values are outside of the range \eqn{-2^{n}/2} to \eqn{(2^{n}/2) – 1} are wrapped back into that range using modulo \eqn{2^{n}} arithmetic (calculated using \eqn{u = mod(u+2^{n}/2, 2^{n})-(2^{n}/2))}. \item Entries in unsigned inputs \code{u} whose values are outside of the range 0 to \eqn{2^{n}-1} are wrapped back into the required range before decoding using modulo \eqn{2^{n}} arithmetic (calculated using \eqn{u = mod(u,2^{n}))}. } } } \note{ The real and imaginary components of complex inputs are decoded independently. } \examples{ u <- c(-1, 1, 2, -5) ysat <- udecode(u, 3) # Notice the last entry in u saturates to 1, the default peak input # magnitude. Change the peak input magnitude to 6. ysatv <- udecode(u, 3, 6) # The last input entry still saturates. Wrap the overflows. ywrap = udecode(u, 3, 6, FALSE) # Add more quantization levels. yprec <- udecode(u, 5) } \author{ Georgios Ouzounis, \email{ouzounis_georgios@hotmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/diric.Rd0000644000176200001440000000315414661623627014052 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/diric.R \name{diric} \alias{diric} \title{Dirichlet function} \usage{ diric(x, n) } \arguments{ \item{x}{Input array, specified as a real scalar, vector, matrix, or multidimensional array. When \code{x} is non-scalar, \code{diric} is an element-wise operation.} \item{n}{Function degree, specified as a positive integer scalar.} } \value{ Output array, returned as a real-valued scalar, vector, matrix, or multidimensional array of the same size as x. } \description{ Compute the Dirichlet or periodic sinc function. } \details{ \code{y <- diric(x, n)} returns the Dirichlet Function of degree \code{n} evaluated at the elements of the input array \code{x}. The Dirichlet function, or periodic sinc function, has period \eqn{2 \pi} for odd \eqn{N} and period \eqn{4 \pi} for even \eqn{N}. Its maximum value is 1 for all N, and its minimum value is -1 for even N. The magnitude of the function is 1 / N times the magnitude of the discrete-time Fourier transform of the N-point rectangular window. } \examples{ ## Compute and plot the Dirichlet function between -2pi and 2pi for N = 7 ## and N = 8. The function has a period of 2pi for odd N and 4pi for even N. x <- seq(-2*pi, 2*pi, len = 301) d7 <- diric(x, 7) d8 <- diric(x, 8) op <- par(mfrow = c(2,1)) plot(x/pi, d7, type="l", main = "Dirichlet function", xlab = "", ylab = "N = 7") plot(x/pi, d8, type="l", ylab = "N = 8", xlab = expression(x / pi)) par(op) } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/sinetone.Rd0000644000176200001440000000260214420222025014555 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sinetone.R \name{sinetone} \alias{sinetone} \title{Sine tone} \usage{ sinetone(freq, rate = 8000, sec = 1, ampl = 64) } \arguments{ \item{freq}{frequency of the tone, specified as a vector of positive numeric values. The length of \code{freq} should equal the length of the \code{ampl} vector; the shorter of the two is recycled to the longer vector.} \item{rate}{sampling frequency, specified as a positive scalar. Default: 8000.} \item{sec}{length of the generated tone in seconds. Default: 1} \item{ampl}{amplitude of the tone, specified as a vector of positive numeric values. The length of \code{ampl} should equal the length of the \code{freq} vector; the shorter of the two is recycled to the longer vector. Default: 64.} } \value{ Sine tone, returned as a vector of length \code{rate * sec}, or as a matrix with \code{rate * sec} columns and \code{max(length(freq), length(ampl))} columns. } \description{ Generate discrete sine tone. } \examples{ fs <- 1000 sec <- 2 y <- sinetone(10, fs, sec, 1) plot(seq(0, sec, length.out = sec * fs), y, type = "l", xlab = "", ylab = "") y <- sinetone(c(10, 15), fs, sec, c(1, 2)) matplot(seq(0, sec, length.out = sec * fs), y, type = "l", xlab = "", ylab = "") } \author{ Friedrich Leisch.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/gaussian.Rd0000644000176200001440000000237214420222025014547 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gaussian.R \name{gaussian} \alias{gaussian} \title{Gaussian convolution window} \usage{ gaussian(n, a = 1) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{a}{Width factor, specified as a positive real scalar. \code{a} is inversely proportional to the width of the window. Default: 1.} } \value{ Gaussian convolution window, returned as a vector. } \description{ Return a Gaussian convolution window of length \code{n}. } \details{ The width of the window is inversely proportional to the parameter \code{a}. Use larger \code{a} for a narrower window. Use larger \code{m} for longer tails. \deqn{w = e^{(-(a*x)^{2}/2 )}} for \code{x <- seq(-(n - 1) / 2, (n - 1) / 2, by = n)}. Width a is measured in frequency units (sample rate/num samples). It should be f when multiplying in the time domain, but 1/f when multiplying in the frequency domain (for use in convolutions). } \examples{ g1 <- gaussian(128, 1) g2 <- gaussian(128, 0.5) plot (g1, type = "l", xlab = "Samples", ylab =" Amplitude", ylim = c(0, 1)) lines(g2, col = "red") } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/fwhm.Rd0000644000176200001440000000273614420222025013702 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fwhm.R \name{fwhm} \alias{fwhm} \title{Full width at half maximum} \usage{ fwhm( x = seq_len(length(y)), y, ref = c("max", "zero", "middle", "min", "absolute"), level = 0.5 ) } \arguments{ \item{x}{samples at which \code{y} is measured, specified as a vector. I.e., \code{y} is sampled as \code{y[x]}. Default: \code{seq_len(length(y))}.} \item{y}{signal to find the width of. If \code{y} is a matrix, widths of all columns are computed.} \item{ref}{reference. Compute the width with reference to: \describe{ \item{\code{"max" | "zero"}}{\code{max(y)}} \item{\code{"middle" | "min"}}{\code{min(y) + max(y)}} \item{\code{"absolute"}}{an absolute level of \code{y}} }} \item{level}{the level at which to compute the width. Default: 0.5.} } \value{ Full width at half maximum, returned as a vector with a length equal to the number of columns in \code{y}, or 1 in case of a vector. } \description{ Compute peak full-width at half maximum or at another level of peak maximum for a vector or matrix. } \examples{ x <- seq(-pi, pi, 0.001) y <- cos(x) w <- fwhm(x, y) m <- x[which.max(y)] f <- m - w/2 t <- m + w/2 plot(x, y, type="l", panel.first = { usr <- par('usr') rect(f, usr[3], t, usr[4], col = rgb(0, 1, 0, 0.4), border = NA) }) abline(h = max(y) / 2, lty = 2, col = "gray") } \author{ Petr Mikulik.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/sawtooth.Rd0000644000176200001440000000336614420222025014611 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sawtooth.R \name{sawtooth} \alias{sawtooth} \title{Sawtooth or triangle wave} \usage{ sawtooth(t, width = 1) } \arguments{ \item{t}{Sample times of unit sawtooth wave specified by a vector.} \item{width}{Real number between 0 and 1 which specifies the point between 0 and \eqn{2 \pi} where the maximum is. The function increases linearly from -1 to 1 in the interval from 0 to \eqn{ 2 * \pi * width}, and decreases linearly from 1 to -1 in the interval from \eqn{2 * \pi * width} to \eqn{2 * \pi}. Default: 1 (standard sawtooth).} } \value{ Sawtooth wave, returned as a vector. } \description{ Returns samples of the sawtooth function at the times indicated by \code{t}. } \details{ The code \code{y <- sawtooth(t)} generates a sawtooth wave with period \eqn{2\pi} for the elements of the time array \code{t}. \code{sawtooth()} is similar to the sine function but creates a sawtooth wave with peaks of –1 and 1. The sawtooth wave is defined to be –1 at multiples of \eqn{2\pi} and to increase linearly with time with a slope of \eqn{1/\pi} at all other times. \code{y <- sawtooth(t, width)} generates a modified triangle wave with the maximum location at each period controlled by \code{width}. Set \code{width} to 0.5 to generate a standard triangle wave. } \examples{ T <- 10 * (1 / 50) fs <- 1000 t <- seq(0, T-1/fs, 1/fs) y <- sawtooth(2 * pi * 50 *t) plot(t, y, type="l", xlab = "", ylab = "", main = "50 Hz sawtooth wave") T <- 10 * (1 / 50) fs <- 1000 t <- seq(0, T-1/fs, 1/fs) y <- sawtooth(2 * pi * 50 * t, 1/2) plot(t, y, type="l", xlab = "", ylab = "", main = "50 Hz triangle wave") } \author{ Juan Aguado.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/cmorwavf.Rd0000644000176200001440000001121514420222025014555 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cmorwavf.R \name{cmorwavf} \alias{cmorwavf} \title{Complex Morlet Wavelet} \usage{ cmorwavf(lb = -8, ub = 8, n = 1000, fb = 5, fc = 1) } \arguments{ \item{lb, ub}{Lower and upper bounds of the interval to evaluate the complex Morlet waveform on. Default: -8 to 8.} \item{n}{Number of points on the grid between \code{lb} and \code{ub} (length of the wavelet). Default: 1000.} \item{fb}{Time-decay parameter of the wavelet (bandwidth in the frequency domain). Must be a positive scalar. Default: 5.} \item{fc}{Center frequency of the wavelet. Must be a positive scalar. Default: 1.} } \value{ A list containing 2 variables; \code{x}, the grid on which the complex Morlet wavelet was evaluated, and \code{psi} (\eqn{\Psi}), the evaluated wavelet on the grid \code{x}. } \description{ Compute the complex Morlet wavelet on a grid. } \details{ The Morlet (or Gabor) wavelet is a wavelet composed of a complex exponential (carrier) multiplied by a Gaussian window (envelope). The wavelet exists as a complex version or a purely real-valued version. Some distinguish between the "real Morlet" versus the "complex Morlet". Others consider the complex version to be the "Gabor wavelet", while the real-valued version is the "Morlet wavelet". This function returns the complex Morlet wavelet, with time-decay parameter \code{fb}, and center frequency \code{fc}. The general expression for the complex Morlet wavelet is \if{latex}{ \deqn{\Psi(x) = ((\pi fb)^{-0.5}) \cdot e^{(2 \pi i fc x)} \cdot e^{-(x^2) / fb}} } \if{html}{\preformatted{ Psi(x) = ((pi * fb)^-0.5) * exp(2 * pi * i * fc * x) * exp(-(x^2) / fb) }} \code{x} is evaluated on an \code{n}-point regular grid in the interval (lb, ub). \code{fb} controls the decay in the time domain and the corresponding energy spread (bandwidth) in the frequency domain. \code{fb} is the inverse of the variance in the frequency domain. Increasing \code{fb} makes the wavelet energy more concentrated around the center frequency and results in slower decay of the wavelet in the time domain. Decreasing \code{fb} results in faster decay of the wavelet in the time domain and less energy spread in the frequency domain. The value of \code{fb} does not affect the center frequency. When converting from scale to frequency, only the center frequency affects the frequency values. The energy spread or bandwidth parameter affects how localized the wavelet is in the frequency domain. See the examples. } \examples{ ## Construct a complex-valued Morlet wavelet with a bandwidth parameter ## of 1.5 and a center frequency of 1. Set the effective support to [-8,8] ## and the length of the wavelet to 1000. cmw <- cmorwavf(-8, 8, 1000, 1.5, 1) # Plot the real and imaginary parts of the wavelet. op <- par(mfrow = c(2, 1)) plot(cmw$x, Re(cmw$psi), type = "l", main = "Real Part") plot(cmw$x, Im(cmw$psi), type = "l", main = "Imaginary Part") par(op) ## This example shows how the complex Morlet wavelet shape in the frequency ## domain is affected by the value of the bandwidth parameter (fb). Both ## wavelets have a center frequency of 1. One wavelet has an fb value of ## 0.5 and the other wavelet has a value of 8. op <- par(mfrow = c(2,1)) cmw1 <- cmorwavf(fb = 0.5) cmw2 <- cmorwavf(fb = 8) # time domain plot plot(cmw1$x, Re(cmw1$psi), type = "l", xlab = "Time", ylab = "", main = "Time domain, Real part") lines(cmw2$x, Re(cmw2$psi), col = "red") legend("topright", legend = c("fb = 0.5", "fb = 8"), lty= 1, col = c(1,2)) # frequency domain plot f <- seq(-5, 5, .01) Fc <- 1 Fb1 <- 0.5 Fb2 <- 8 PSI1 <- exp(-pi^2 * Fb1 * (f-Fc)^2) PSI2 <- exp(-pi^2 * Fb2 * (f-Fc)^2) plot(f, PSI1, type="l", xlab = "Frequency", ylab = "", main = "Frequency domain") lines(f, PSI2, col = "red") legend("topright", legend = c("fb = 0.5", "fb = 8"), lty= 1, col = c(1,2)) par(op) ## The fb bandwidth parameter for the complex Morlet wavelet is the ## inverse of the variance in frequency. Therefore, increasing Fb results ## in a narrower concentration of energy around the center frequency. ## alternative to the above frequency plot: fs <- length(cmw1$x) / sum(abs(range(cmw1$x))) hz <- seq(0, fs/2, len=floor(length(cmw1$psi)/2)+1) PSI1 <- fft(cmw1$psi) / length(cmw1$psi) PSI2 <- fft(cmw2$psi) / length(cmw2$psi) plot(hz, 2 * abs(PSI1)[1:length(hz)], type="l", xlab = "Frequency", ylab = "", main = "Frequency domain", xlim=c(0,5)) lines(hz, 2 * abs(PSI2)[1:length(hz)], col = 2) legend("topright", legend = c("fb = 0.5", "fb = 8"), lty= 1, col = c(1,2)) } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/dwt.Rd0000644000176200001440000000742214420222025013534 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dwt.R \name{dwt} \alias{dwt} \alias{wfilters} \title{1-D Discrete Wavelet Transform} \usage{ dwt(x, wname = "d8", lo = NULL, hi = NULL) wfilters(wname) } \arguments{ \item{x}{input data, specified as a numeric vector.} \item{wname}{analyzing wavelet, specified as a character string consisting of a class name followed by the wavelet length Only two classes of wavelets are supported; Daubechies (denoted by the prefix \code{'d'} of even lengths 2 - 20, and Coiflet (denoted by the prefix '\code{'c'} of lengths 6, 12, 18, 24, and 30. The wavelet name \code{'haar'} is the equivalent of \code{'d2'}. Default: d8.} \item{lo}{scaling (low-pass) filter, specified as an even-length numeric vector. \code{lo} must be the same length as \code{hi}. Ignored when \code{wname != NULL}.} \item{hi}{wavelet (high-pass) filter, specified as an even-length numeric vector. \code{hi} must be the same length as \code{lo}, Ignored when \code{wname != NULL}.} } \value{ A list containing two numeric vectors: \describe{ \item{a}{approximation (average) coefficients, obtained from convolving \code{x} with the scaling (low-pass) filter \code{lo}, and then downsampled (keep the even-indexed elements).} \item{d}{detail (difference) coefficients, obtained from convolving \code{x} with the wavelet (high-pass) filter \code{hi}, and then downsampled (keep the even-indexed elements).} } } \description{ Compute the single-level discrete wavelet transform of a signal } \details{ This function is only included because of compatibility with the 'Octave' 'signal' package. Specialized packages exist in R to perform the discrete wavelet transform, e.g., the \code{wavelets} package [1]. this function recognizes only a few wavelet names, namely those for which scale coefficients are available (Daubechies [2] and Coiflet [3]). The wavelet and scaling coefficients are returned by the function \code{wfilters}, which returns the coefficients for reconstruction filters associated with the wavelet \code{wname}. Decomposition filters are the time reverse of the reconstruction filters (see examples). } \note{ The notations \code{g} and \code{h} are often used to denote low-pass (scaling) and high-pass (wavelet) coefficients, respectively, but inconsistently. Ref [4] uses it, as does the R \code{wavelets} package. 'Octave' uses the reverse notation. To avoid confusion, more neutral terms are used here. There are two naming schemes for wavelet names in use. For instance for Daubechies wavelets (d), dN using the length or number of taps, and dbA referring to the number of vanishing moments. So d4 and db2 are the same wavelet transform. This function uses the formed (dN) notation; 'Matlab' uses the latter (dbA). } \examples{ # get Coiflet 30 coefficients wv <- wfilters('c30') lo <- rev(wv$lo) hi <- rev(wv$hi) # general time-varying signal time <- 1 fs <- 1000 x <- seq(0,time, length.out=time*fs) y <- c(cos(2*pi*100*x)[1:300], cos(2*pi*50*x)[1:300], cos(2*pi*25*x)[1:200], cos(2*pi*10*x)[1:200]) op <- par(mfrow = c(3,1)) plot(x, y, type = "l", xlab = "Time", ylab = "Amplitude", main = "Original signal") wt <- dwt(y, wname = NULL, lo, hi) x2 <- seq(1, length(x) - length(hi) + 1, 2) plot(x2, wt$a, type = "h", xlab = "Time", ylab = "", main = "Approximation coefficients") plot(x2, wt$d, type = "h", xlab = "Time", ylab = "", main = "Detail coefficients") par (op) } \references{ [1] \url{https://CRAN.R-project.org/package=wavelets} [2] \url{https://en.wikipedia.org/wiki/Daubechies_wavelet} [3] \url{https://en.wikipedia.org/wiki/Coiflet} [4] \url{https://en.wikipedia.org/wiki/Discrete_wavelet_transform} } \author{ Lukas F. Reichlin.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/nuttallwin.Rd0000644000176200001440000000302114420222025015126 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/nuttallwin.R \name{nuttallwin} \alias{nuttallwin} \title{Nuttall-defined minimum 4-term Blackman-Harris window} \usage{ nuttallwin(n, method = c("symmetric", "periodic")) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{method}{Character string. Window sampling method, specified as: \describe{ \item{"symmetric"}{(Default). Use this option when using windows for filter design.} \item{"periodic"}{This option is useful for spectral analysis because it enables a windowed signal to have the perfect periodic extension implicit in the discrete Fourier transform. When \code{periodic} is specified, the function computes a window of length \code{n + 1} and returns the first \code{n} points.} }} } \value{ Nuttall-defined Blackman-Harris window, returned as a vector. } \description{ Return the filter coefficients of a Blackman-Harris window defined by Nuttall of length \code{n}. } \details{ The window is minimum in the sense that its maximum sidelobes are minimized. The coefficients for this window differ from the Blackman-Harris window coefficients computed with \code{blackmanharris} and produce slightly lower sidelobes. } \examples{ n <- nuttallwin(64) plot (n, type = "l", xlab = "Samples", ylab =" Amplitude") } \seealso{ \code{\link{blackman}}, \code{\link{blackmanharris}} } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/freqz.Rd0000644000176200001440000000736014420222025014066 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/freqz.R \name{freqz} \alias{freqz} \alias{freqz.default} \alias{freqz.Arma} \alias{freqz.Ma} \alias{freqz.Sos} \alias{freqz.Zpg} \alias{print.freqz} \alias{summary.freqz} \alias{print.summary.freqz} \alias{freqz_plot} \title{Frequency response of digital filter} \usage{ freqz(filt, ...) \method{freqz}{default}( filt, a = 1, n = 512, whole = ifelse((is.numeric(filt) && is.numeric(a)), FALSE, TRUE), fs = 2 * pi, ... ) \method{freqz}{Arma}( filt, n = 512, whole = ifelse((is.numeric(filt$b) && is.numeric(filt$a)), FALSE, TRUE), fs = 2 * pi, ... ) \method{freqz}{Ma}( filt, n = 512, whole = ifelse(is.numeric(filt), FALSE, TRUE), fs = 2 * pi, ... ) \method{freqz}{Sos}(filt, n = 512, whole = FALSE, fs = 2 * pi, ...) \method{freqz}{Zpg}(filt, n = 512, whole = FALSE, fs = 2 * pi, ...) \method{print}{freqz}(x, ...) \method{summary}{freqz}(object, ...) \method{print}{summary.freqz}(x, ...) freqz_plot(w, h, ...) } \arguments{ \item{filt}{for the default case, the moving-average coefficients of an ARMA model or filter. Generically, \code{filt} specifies an arbitrary model or filter operation.} \item{...}{for methods of \code{freqz}, arguments are passed to the default method. For \code{freqz_plot}, additional arguments are passed through to plot.} \item{a}{the autoregressive (recursive) coefficients of an ARMA filter.} \item{n}{number of points at which to evaluate the frequency response. If \code{n} is a vector with a length greater than 1, then evaluate the frequency response at these points. For fastest computation, \code{n} should factor into a small number of small primes. Default: 512.} \item{whole}{FALSE (the default) to evaluate around the upper half of the unit circle or TRUE to evaluate around the entire unit circle.} \item{fs}{sampling frequency in Hz. If not specified (default = 2 * pi), the frequencies are in radians.} \item{x}{object to be printed or plotted.} \item{object}{object of class \code{"freqz"} for \code{summary}} \item{w}{vector of frequencies} \item{h}{complex frequency response \eqn{H(e^{j\omega})}, specified as a vector.} } \value{ For \code{freqz}, a list of class \code{'freqz'} with items: \describe{ \item{h}{complex array of frequency responses at frequencies \code{f}.} \item{w}{array of frequencies.} \item{u}{units of (angular) frequency; either rad/s or Hz.} } } \description{ Compute the z-plane frequency response of an ARMA model or rational IIR filter. } \details{ The frequency response of a digital filter can be interpreted as the transfer function evaluated at \eqn{z = e^{j\omega}}. The 'Matlab' and 'Octave' versions of \code{freqz} produce magnitude and phase plots. The \code{freqz} version in the 'signal' package produces separate plots of magnitude in the pass band (max - 3 dB to max) and stop (total) bands, as well as a phase plot. The current version produces slightly different plots. The magnitude plots are separate for stop and pass bands, but the pass band plot has an absolute lower limit of -3 dB instead of max - 3 dB. In addition a \code{summary} method was added that prints out the most important information about the frequency response of the filter. } \note{ When results of \code{freqz} are printed, \code{freqz_plot} will be called to display frequency plots of magnitude and phase. As with lattice plots, automatic printing does not work inside loops and function calls, so explicit calls to print or plot are needed there. } \examples{ b <- c(1, 0, -1) a <- c(1, 0, 0, 0, 0.25) freqz(b, a) hw <- freqz(b, a) summary(hw) } \author{ John W. Eaton, Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Port to R by Tom Short,\cr adapted by Geert van Boxtel, \email{gjmvanboxtel@gmail.com} } gsignal/man/welchwin.Rd0000644000176200001440000000371614420222025014560 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/welchwin.R \name{welchwin} \alias{welchwin} \title{Welch window} \usage{ welchwin(n, method = c("symmetric", "periodic")) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{method}{Character string. Window sampling method, specified as: \describe{ \item{"symmetric"}{(Default). Use this option when using windows for filter design.} \item{"periodic"}{This option is useful for spectral analysis because it enables a windowed signal to have the perfect periodic extension implicit in the discrete Fourier transform. When 'periodic' is specified, the function computes a window of length \code{n + 1} and returns the first \code{n} points.} }} } \value{ Welch window, returned as a vector. } \description{ Return the filter coefficients of a Welch window of length \code{n}. } \details{ The Welch window is a polynomial window consisting of a single parabolic section: \deqn{w(k) = 1 - (k / N - 1)^2, n=0,1, ... n-1}. The optional argument specifies a "symmetric" window (the default) or a "periodic" window. A symmetric window has zero at each end and maximum in the middle, and the length must be an integer greater than 2. The variable \code{N} in the formula above is \code{(n-1)/2}. A periodic window wraps around the cyclic interval \code{0,1, ... m-1}, and is intended for use with the DFT. The length must be an integer greater than 1. The variable \code{N} in the formula above is \code{n/2}. } \examples{ w <- welchwin(64) plot (w, type = "l", xlab = "Samples", ylab =" Amplitude") ws = welchwin(64,'symmetric') wp = welchwin(63,'periodic') plot (ws, type = "l", xlab = "Samples", ylab =" Amplitude") lines(wp, col="red") } \author{ Muthiah Annamalai, \email{muthiah.annamalai@uta.edu},\cr Mike Gross, \email{mike@appl-tech.com},\cr Peter V. Lanspeary, \email{pvl@mecheng.adelaide.edu.au}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/buffer.Rd0000644000176200001440000002244514420222025014211 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/buffer.R \name{buffer} \alias{buffer} \title{Buffer signal vector into matrix of data segments} \usage{ buffer(x, n, p = 0, opt, zopt = FALSE) } \arguments{ \item{x}{The data to be buffered.} \item{n}{The number of rows in the produced data buffer. This is an positive integer value and must be supplied.} \item{p}{An integer less than \code{n} that specifies the under- or overlap between column in the data frame. Default 0.} \item{opt}{In the case of an overlap, \code{opt} can be either a vector of length \code{p} or the string \code{'nodelay'}. If \code{opt} is a vector, then the first \code{p} entries in \code{y} will be filled with these values. If \code{opt} is the string \code{'nodelay'}, then the first value of \code{y} corresponds to the first value of \code{x}. In the case of an underlap, \code{opt} must be an integer between 0 and \code{-p}. The represents the initial underlap of the first \code{y}. The default value for \code{opt} the vector \code{matrix (0L, 1, p)} in the case of an overlap, or 0 otherwise.} \item{zopt}{Logical. If TRUE, return values for \code{z} and \code{opt} in addition to \code{y}. Default is FALSE (return only \code{y}).} } \value{ If \code{zopt} equals FALSE (the default), this function returns a single numerical array containing the buffered data (\code{y}). If \code{zopt} equals TRUE, then a \code{list} containing 3 variables is returned: \code{y}: the buffered data, \code{z}: the over or underlap (if any), \code{opt}: the over- or underlap that might be used for a future call to \code{buffer} to allow continuous buffering. } \description{ Partition a signal vector into nonoverlapping, overlapping, or underlapping data segments. } \details{ \code{y <- buffer(x, n)} partitions a signal vector \code{x} of length \code{L} into nonoverlapping data segments of length \code{n}. Each data segment occupies one column of matrix output \code{y}, which has \code{n} rows and \code{ceil(L / n)} columns. If \code{L} is not evenly divisible by \code{n}, the last column is zero-padded to length \code{n}. \code{y <- buffer(x, n, p)} overlaps or underlaps successive frames in the output matrix by \code{p} samples. \itemize{ \item {For \code{0 < p < n} (overlap), buffer repeats the final \code{p} samples of each segment at the beginning of the following segment. See the example where \code{x = 1:30}, \code{n = 7}, and an overlap of \code{p = 3}. In this case, the first segment starts with \code{p} zeros (the default initial condition), and the number of columns in \code{y} is \code{ceil(L / (n - p))}.} \item {For \code{p < 0} (underlap), buffer skips \code{p} samples between consecutive segments. See the example where \code{x = 1:30}, \code{n = 7}, and \code{p = -3}. The number of columns in \code{y} is \code{ceil(L / (n - p))}.} } In \code{y <- buffer(x, n, p, opt)}, \code{opt} specifies a vector of samples to precede \code{x[1]} in an overlapping buffer, or the number of initial samples to skip in an underlapping buffer. \itemize{ \item {For \code{0 < p < n} (overlap), \code{opt} specifies a vector of length \code{p} to insert before \code{x[1]} in the buffer. This vector can be considered an initial condition, which is needed when the current buffering operation is one in a sequence of consecutive buffering operations. To maintain the desired segment overlap from one buffer to the next, \code{opt} should contain the final \code{p} samples of the previous buffer in the sequence. Set \code{opt} to \code{"nodelay"} to skip the initial condition and begin filling the buffer immediately with \code{x[1]}. In this case, \code{L} must be \code{length(p)} or longer. See the example where \code{x = 1:30}, \code{n = 7}, \code{p = 3}, and \code{opt = "nodelay"}.} \item {For \code{p < 0} (underlap), \code{opt} is an integer value in the range \code{0 : -p} specifying the number of initial input samples, \code{x[1:opt]}, to skip before adding samples to the buffer. The first value in the buffer is therefore \code{x[opt + 1]}.} } The \code{opt} option is especially useful when the current buffering operation is one in a sequence of consecutive buffering operations. To maintain the desired frame underlap from one buffer to the next, \code{opt} should equal the difference between the total number of points to skip between frames (\code{p}) and the number of points that were available to be skipped in the previous input to buffer. If the previous input had fewer than p points that could be skipped after filling the final frame of that buffer, the remaining opt points need to be removed from the first frame of the current buffer. See Continuous Buffering for an example of how this works in practice. \code{buf <- buffer(..., zopt = TRUE)} returns the last \code{p} samples of a overlapping buffer in output \code{buf$opt}. In an underlapping buffer, \code{buf$opt} is the difference between the total number of points to skip between frames (\code{-p}) and the number of points in \code{x} that were available to be skipped after filling the last frame: \itemize{ \item {For \code{0 < p < n} (overlap), \code{buf$opt} contains the final \code{p} samples in the last frame of the buffer. This vector can be used as the initial condition for a subsequent buffering operation in a sequence of consecutive buffering operations. This allows the desired frame overlap to be maintained from one buffer to the next. See Continuous Buffering below.} \item {For \code{p < 0} (underlap), \code{buf$opt} is the difference between the total number of points to skip between frames \code{(-p)} and the number of points in \code{x} that were available to be skipped after filling the last frame: \code{buf$opt = m*(n-p) + opt - L} where \code{opt} on the right is the input argument to buffer, and \code{buf$opt} on the left is the output argument. Note that for an underlapping buffer output \code{buf$opt} is always zero when output \code{buf$z} contains data.\cr The opt output for an underlapping buffer is especially useful when the current buffering operation is one in a sequence of consecutive buffering operations. The \code{buf$opt} output from each buffering operation specifies the number of samples that need to be skipped at the start of the next buffering operation to maintain the desired frame underlap from one buffer to the next. If fewer than \code{p} points were available to be skipped after filling the final frame of the current buffer, the remaining opt points need to be removed from the first frame of the next buffer.} } In a sequence of buffering operations, the \code{buf$opt} output from each operation should be used as the \code{opt} input to the subsequent buffering operation. This ensures that the desired frame overlap or underlap is maintained from buffer to buffer, as well as from frame to frame within the same buffer. See Continuous Buffering below for an example of how this works in practice. \cr \strong{Continuous Buffering}\cr\cr In a continuous buffering operation, the vector input to the buffer function represents one frame in a sequence of frames that make up a discrete signal. These signal frames can originate in a frame-based data acquisition process, or within a frame-based algorithm like the FFT.\cr As an example, you might acquire data from an A/D card in frames of 64 samples. In the simplest case, you could rebuffer the data into frames of 16 samples; \code{buffer} with \code{n = 16} creates a buffer of four frames from each 64-element input frame. The result is that the signal of frame size 64 has been converted to a signal of frame size 16; no samples were added or removed.\cr In the general case where the original signal frame size, \code{L}, is not equally divisible by the new frame size, \code{n}, the overflow from the last frame needs to be captured and recycled into the following buffer. You can do this by iteratively calling buffer on input x with the \code{zopt} parameter set to \code{TRUE}. This simply captures any buffer overflow in \code{buf$z}, and prepends the data to the subsequent input in the next call to buffer.\cr Note that continuous buffering cannot be done without the \code{zopt} parameter being set to \code{TRUE}, because the last frame of y (\code{buf$y} in this case) is zero padded, which adds new samples to the signal.\cr Continuous buffering in the presence of overlap and underlap is handled with the \code{opt} parameter, which is used as both an input (\code{opt} and output (\code{buf$opt}) to buffer. The two examples on this page demonstrate how the \code{opt} parameter should be used. } \examples{ ## Examples without continuous buffering y <- buffer(1:10, 5) y <- buffer(1:10, 4) y <- buffer(1:30, 7, 3) y <- buffer(1:30, 7, -3) y <- buffer(1:30, 7, 3, 'nodelay') ## Continuous buffering examples # with overlap: data <- buffer(1:1100, 11) n <- 4 p <- 1 buf <- list(y = NULL, z = NULL, opt = -5) for (i in 1:ncol(data)) { x <- data[,i] buf <- buffer(x = c(buf$z,x), n, p, opt=buf$opt, zopt = TRUE) } # with underlap: data <- buffer(1:1100, 11) n <- 4 p <- -2 buf <- list(y = NULL, z = NULL, opt = 1) for (i in 1:ncol(data)) { x <- data[,i] buf <- buffer(x = c(buf$z,x), n, p, opt=buf$opt, zopt = TRUE) } } \author{ David Bateman, \email{adb014@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com} } gsignal/man/iirlp2mb.Rd0000644000176200001440000000642214420222025014455 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/iirlp2mb.R \name{iirlp2mb} \alias{iirlp2mb} \alias{iirlp2mb.Arma} \alias{iirlp2mb.Zpg} \alias{iirlp2mb.Sos} \alias{iirlp2mb.default} \title{IIR lowpass filter to IIR multiband} \usage{ iirlp2mb(b, ...) \method{iirlp2mb}{Arma}(b, Wo, Wt, type, ...) \method{iirlp2mb}{Zpg}(b, Wo, Wt, type, ...) \method{iirlp2mb}{Sos}(b, Wo, Wt, type, ...) \method{iirlp2mb}{default}(b, a, Wo, Wt, type = c("pass", "stop"), ...) } \arguments{ \item{b}{numerator polynomial of prototype low pass filter} \item{...}{additional arguments (not used)} \item{Wo}{(normalized angular frequency)/pi to be transformed} \item{Wt}{vector of (norm. angular frequency)/pi transform targets} \item{type}{one of "pass" or "stop". Specifies to filter to produce: bandpass (default) or bandstop.} \item{a}{denominator polynomial of prototype low pass filter} } \value{ List of class \code{\link{Arma}} numerator and denominator polynomials of the resulting filter. } \description{ Transform an IIR lowpass filter prototype to an IIR multiband filter. } \details{ The utility of a prototype filter comes from the property that all other filters can be derived from it by applying a scaling factor to the components of the prototype. The filter design need thus only be carried out once in full, with other filters being obtained by simply applying a scaling factor. Especially useful is the ability to transform from one bandform to another. In this case, the transform is more than a simple scale factor. Bandform here is meant to indicate the category of passband that the filter possesses. The usual bandforms are lowpass, highpass, bandpass and bandstop, but others are possible. In particular, it is possible for a filter to have multiple passbands. In fact, in some treatments, the bandstop filter is considered to be a type of multiple passband filter having two passbands. Most commonly, the prototype filter is expressed as a lowpass filter, but other techniques are possible[1]. Filters with multiple passbands may be obtained by applying the general transformation described in [2]. Because \code{iirlp2mb} is generic, it can be extended to accept other inputs. } \examples{ ## Design a prototype real IIR lowpass elliptic filter with a gain of about ## –3 dB at 0.5pi rad/sample. el <- ellip(3, 0.1, 30, 0.409) ## Create a real multiband filter with two passbands. mb1 <- iirlp2mb(el, 0.5, c(.2, .4, .6, .8), 'pass') ## Create a real multiband filter with two stopbands. mb2 <- iirlp2mb(el, 0.5, c(.2, .4, .6, .8), 'stop') ## Compare the magnitude responses of the filters. hfl <- freqz(el) hf1 <- freqz(mb1) hf2 <- freqz(mb2) plot(hfl$w, 20 * log10(abs(hfl$h)), type = "l", xlab = "Normalized frequency (* pi rad/sample)", ylab = "Magnitude (dB)") lines(hf1$w, 20 * log10(abs(hf1$h)), col="red") lines(hf2$w, 20 * log10(abs(hf2$h)), col="blue") legend('bottomleft', legend = c('Prototype', 'Two passbands', 'Two Stopbands'), col=c("black", "red", "blue"), lty = 1) } \references{ [1] \url{https://en.wikipedia.org/wiki/Prototype_filter}\cr [2] \url{https://en.wikipedia.org/wiki/Prototype_filter#Lowpass_to_multi-band} } \author{ Alan J. Greenberger, \email{alanjg@ptd.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/cheb2ord.Rd0000644000176200001440000000331114420222025014417 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cheb2ord.R \name{cheb2ord} \alias{cheb2ord} \title{Chebyshev Type II filter order} \usage{ cheb2ord(Wp, Ws, Rp, Rs, plane = c("z", "s")) } \arguments{ \item{Wp, Ws}{pass-band and stop-band edges. For a low-pass or high-pass filter, \code{Wp} and \code{Ws} are scalars. For a band-pass or band-rejection filter, both are vectors of length 2. For a low-pass filter, \code{Wp < Ws}. For a high-pass filter, \code{Ws > Wp}. For a band-pass \code{(Ws[1] < Wp[1] < Wp[2] < Ws[2])} or band-reject \code{(Wp[1] < Ws[1] < Ws[2] < Wp[2])} filter design, \code{Wp} gives the edges of the pass band, and \code{Ws} gives the edges of the stop band. For digital filters, frequencies are normalized to [0, 1], corresponding to the range [0, fs / 2]. In case of an analog filter, all frequencies are specified in radians per second.} \item{Rp}{allowable decibels of ripple in the pass band.} \item{Rs}{minimum attenuation in the stop band in dB.} \item{plane}{"z" for a digital filter or "s" for an analog filter.} } \value{ A list of class \code{'FilterSpecs'} with the following list elements: \describe{ \item{n}{filter order} \item{Wc}{cutoff frequency} \item{type}{filter type, normally one of \code{"low"}, \code{"high"}, \code{"stop"}, or \code{"pass"}.} } } \description{ Compute Chebyshev type-II filter order and cutoff for the desired response characteristics. } \examples{ ## low-pass 30 Hz filter fs <- 128 spec <- cheb2ord(30/(fs/2), 40/(fs/2), 0.5, 40) cf <- cheby2(spec) freqz(cf, fs = fs) } \seealso{ \code{\link{cheby1}} } \author{ Paul Kienzle, Charles Praplan.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/figures/0000755000176200001440000000000014420222025014106 5ustar liggesusersgsignal/man/figures/gsignal_logo.png0000644000176200001440000015520214420222025017265 0ustar liggesusersPNG  IHDRX.' pHYs.#.#x?v IDATxy=ΰ ((`\Q,.ۛMcTqI1DMIDh$ɋ\q aXeߗafs<@Tݺ]9B!t!C pu HF;F!!@7~/@b| )#!BRy\-vA` 0C3!BR'YS'(t !bT (~6YD!" pI o#BO p 'fJ!8A)O )ӿB!'4Z$ 1 B:< p5<1!B:$|S5Y &QgB!F 0耞oZ Z3}!v=*@<*[Ef90aeB! ޾wO:I$DKش@-LKB!$,++EOimW6nT⠱%ǕB)"DDwv^]cM -mLgB!$4ǏYο + Cަ‡|%ǜB:D1ZmFѣE~;1A`g^eq(*2)ty3}!@xߨ 2EŌ(bhg|B!AJIrPE3/̛'rѦF!B҆%7:'lY&eʹ@x]c3}!"D y ;w+K sL7B!(mGɓE3+ |ime<B!I!@>!C;vdZ3kȠA .9%B#!3:8yřQ_,;8:BXft0<0d(ټYY8B!⠩-BqDa1*TQ3='…"bz2΄BQ'*df D.TdÆLfimU}M O8-!y0:ȝxȻfzO-sNle L6M-(^,#fA}sB!t@VTfz&2ji͢uC!!!4:x/fe1˴@P/g"URQ} V#Frd^eA)(0)Z,=}3}MBQ8Qw ԕCnoTU|k,L!$`">f$]:m1kȑG4!,FC5:'^s]޹kW5Fe#e*A稣DfھغUkMwnnuH!$poݻA F/,2vi^Q 2}]BI3r۷gz̘!2piP%2}BIrg!g*;&uu*<[#3}BI!nt0@jmH6mJey箙~ !B r{DN>ٴ` ;BH"@wQt ᰲcZ |"L_ۄB *| "３!aTwkBHxVs3!d'rr.\Sab<#M M΄P**vm1 ty=M 89!tHP9 FÇ̝顋={ElzpOB0%1*t9LW$,_.ry,Y2}BHE~brA*ʳkW'if9a3!E"Qik>>[dLG$hlLUyD!9rk>UwqceI3)ty瞙!$`s ΝUC&~#SO5m=#,L!\XdᇛU{;LA֓NNN9XR_? &[~M! BH",56r$Ulܨ,Pf$Kŀd BYM*-n/LaORțo'lu_x<lP# `ƏG` cMIk+3-;wlcC&%$mJd1cTرƚ$$'=45jU BFS D EfzT.7,! j0gV<`r0H$0P3[a!puo~teBW˖lu_x:  (pԃ\q#Fk O]w55&[~*h#! b&#6  .0$!ia{GaS;TѨGB( 1G`. Gu@3Ȓf"^xm0haq0 I#@??`& Hdg7[gU'($a(dƶRӾ=XdXIM<*h#XPh#x2^Rs jnn]%Ic BѨG10 `8?FʀL= 5KHGʽ&[7 ƢI€BPq?:p啪b]߾F$$g~6`v-Uh#iPO, \'4_& i<7QAa@\,S2he#*e1 8qJ&[=aBѨG~ 4KJoX{xC?Xd[ w&PmEf lIB:~e叠7gQP;GLN?XthUAj;OHj" 'A I+W/d:;<*܇TC[7#MBF$OD `-*l4 X!@wc q#8xcMBoWM"TѨG Ah+<(TUWGI6oVSS`48$pT9--UnJJ5K!Fx-g&[em}S A*Dfu94$!Ve9V`-^xdC(NPqckBR΁.,`4PE3g~ԜaC&2Wwas=.J=P@9u е& !$̟-3fw坍W$TT0jW(?R%) *kb^//=g?q{9ƍ-M3YedSvT( @XHÇ*fgGiIpfOc ~d+W7h)10'X`3SU`ҥiS-]Fa8  Ey.] g,3|wS:>|T#R7ݤAAA|F^~5 8Sv.m00r0?lࡇQ5I:zwG/۾1GвPؿ(+\&S'spsd !O`Lb{Y5#Tˉ7[wߝwVЕEUS .) (8N8!EW3.SJnSm(h)3Qyyњ5*QQ'apcƤ̗0cpZ-/Xc{Ҧ"*礓wz H VU)kFxYbetΆR#5ZYXS@EEf^شIW~i6 X޹ XJKn~KsgcXC͛[ ]/տ& ^}Ux]صKijR%=zQs<3s.L'/,/K^VE9f|{@nf,Qum-Р2z*peם7VA=p`k7UzŋMƢI#@Y[ҋQ|ƏYNHY\9Gd6<3v;[S#2iHϞ~DN 3b۹>NSƮxt*o!2vlsUP r";v̙}K8,2}HƢI"@W 3fogLAYEȢEݻE>l~.9䯝s[o=vt5m.]?ĶVE;W={^ygl;"&RTdR 0CcQ$K$Q5]0"SdvuWr_?={Dؿ}=N]G^rp۾J'SO^@ ݗxEl5MM"ge\u.RU^Ɯ9'rOS'l,d*j),F}2}w\\v2Wo(rz#_DD^fog4'2`@"]$"~zhߍ"۶)吏ݵ+;kGyec("V`^Æ-\vY)/ s#v6ONaĘ1B"} _B~2yD%g@c~q:CQ?{wvΜ.~yvVDZ?aQޙLn 0F2hjJi$%*'F^*qrj;jUaԴ ߮r]>w–Ir2}>jZ9ʐyoWS$ԔD?NkoFEE*G駛jUw^)B]da$`-Ɣ`^UWşFWĞck͇|&[0aBgv_?Isy=d;w yzk~3Fl\N8io}+v3훤Yc}V pa`=ggLǁܹw/q^?Vu;uJl~{P*+cqS~)={$Nn8HzɓcqLɐX ا]0G̯{&AfꢗUVLЧѣÇG/klhnN~ص ز%zY>2}ߝ;c~{۷.0ۍaWVzowolvÞ=M"&()nM_0~E,نu `yP/s^]/(W^l,v|p-]ֿ?0~|\裃( V zHfT.4  Z9! !DBU"`e眓x{.1:OU;|J~O7S bˆ$ .@*v1)Ҷ@u8 'xx;}jP0jZH! s+MӧxN&xRFf^-Uwo`g#lɖNlNq^L\wpq`Ra-:) .Ի:vFA W_^͖w -Qj!Y,6RYm "'bɵ5?um׬Qt~]E~C>JNnź89͟`gض- *KSD?~S5k$^ N`]2=  U܉()QkHv?{NLbР6,}Kc9n}MKuulgqڻ7v=wmJ"e'W}Eyﻦ&ݺe$y55=ETa?cQWC(eT.h9ձyy3~}P(X|5#aZ⋁8M?^2gq g/-RO+gr[wf)WB*YϋѣMFLpY*d4W/S0BE= @kSիFVٳ/.^]6thb1?__֭z<~A}p0VKhRyxG޳G@C <ܻرp6$7((Vv[]Q镳"-@j2s@**T*W/I&ٱ#v<~?r2a*7<;T툨KzTdqr=AEƔ);?D /_:yC'{/EjR几+ZYJa9d'_{%֮]*c7gMM*[t^vÇnrpF&ъFŶysi=TŠV^;9_}6H;b @RGfoƩ7Sn9h+Ng׿6꭮kWz}9SMӥs ;S}}lKK ȑ;`Gݷ7cų&d9Orqt)S iOś6a LiG"0o^jSTlH{w[~pzkleæ&`&?L%ݱr}6%KJ`A7.U1V+9矏]) IDAT/pqg$Ca!pM*9*SzGʯXF T9d3Qݻ+ҥ,fծ Ίۺg3p5k A& 0 H[NS(9[ JJ;4HLp(NΦZ`i( `SiIezkcDow߮QD)vq;E:w>^AA⩍NnCC ?2uDDcg1fB!Gw߲25MMjVۏ8{sV\~ !""7\uUlf>M8J Ru9{j˾?NV,m#y=a:^,X rjND΍mg6>8vN I`BVvKwb~`(VlؐG={+#"k.}uuE@߫<۷7pXd~U0祗DnE_?MNueqbwΓOƶu%37wȌ";w*"e$[Y}u@D/\ b~N8Adn}GfqfxoJ;7֤I[ٕs-Zg  ?]p;%K3[AEͫ*(Uq |Hr? :0qdI:ƎUNK͹wZI6=daǎU*!P.]9Diݺ$@ K0*oƢc0QI̩"r$('rLܳzSCdH@nk?񷿭[[a"փ|sQ~x0܍tV]T:8l濍W^oĶbHmiQ̟Mփs(p T*csƏW 8X"ʥZBۧJٻnWWRvҢ }zk0BM:NIe/5c2ZO.ĻfM (ݪ,s^*귾TV'BKJI~3LJn [UK< #F=w& ˢEcUil!x[G<1@/x ҥ$̕Lm?8+ҥj^޹J.?Ld. 8\V{˖)s?Q8̞dk"Ӻ0$VDi( HpaF[g$νv'~;'B?:L< ^j` 9-6 Y$YgolΜ`YT+瞛|'B:[?"bF? (M C&&p x۶*ܥv߾;'B:ӧ3bN(~7aCbjU6zy^Jte*OXXxq;Z:q""< lbť OWooCDWiW/`H3etQ}QMq1)o3@WI707o+ Xw{M6Ef0ط%$P|Q) {I71 $GIKWBvbܛ#'ZZZ\%$PB!$!9cqbvt\ p8;+tCa@Hb/Е8  7n( Q >NLCa@Hb@,|#M=N۴EH0 BH Br'AKKKTr'h1H?ʕ܌˖-KI$w0 $Gq'N`AI&0U7s9طo_JAr Br'? $# 0ݻwmۆ3gm6LLH& Z JH=N9-¢XAk׮5.}h1 BH BrN7ݕ7k`moݺuF& !9XJKKQZZY}v( OaJo&nٳw b€E[ 틾}s?c~Gֵ֢o<LOVaeۑ!9X QXX/ .Z R8c'uy޽ѥKʕ+rJ}AfX !Ba@!(bPPPZ QƋ1(((#UUUr݇bŊ@10 $Gv%~c^܊%1>|8];`]OUNq0 $G[ ]2G}>(ƍǀ5Xuaн{Hn8$ 3X-hmml_|^z \sM~w4un" <qe+B!$!9=@-,"LWOah NoǔgCWqBrJp)̙ˎHZBclʕ`u~E5PD* -)G\m۶e+|fiΊV@uiiiTu f8Ur |rL8sŬY2Ng>c1hnnvt5uh1"=LohJꏝu$0 BH oD7] ˗^k}hӲv%hp<~i1H 7AZ # 7k$7aa رcI_*vXh?xH$Ǖ`1UX2|h.] Xl}܄}) :@%Jn[Y" گtE{{~n 71{bf},t%M ZمWٷ3 ѾŀB!( R@{ڵ /R9سgOw[$QVTTDrsbA~+ZϫJ/י)aΏ@^8Aa10 BH `j{:SrMaӦMشi O>9%[ 'B  A|)-UnD뮻зo_<qߘI] @g6~\ r `Ċ(l۶-'WB6 ?06Q00i@_ng00LSSS{gPoN{ֲiVBPAϞ=ѳgO29Y R?zDuuVA2)QGERoNm1ƀh( ca&L@=_b I&y}W*LNo^X,' PVV `ۥKe1`߾}t***0m4ʝg"QWAǀ€B!( c}޽;55^ )Sj*OYb}# _h@^^^c]EEE(--EiiioQ[СCd+AgfL+aΝxw}tb 0 kSAWR;0ցG"lJ7k ub:3Q+!Haϕ`&llr%444Nرc}̀p >4cPPP>}Di+gq0N_){.l־ S?e˖/_+Z* %%%ŻF tТ}FÑL>V=O&^+)G\bòˆqV "Bf;MX&a0uԈ8lllĿo] ?:X@|ݺu=CmmmdԖT?.C6Z,06m2n1θIB!D00UE[] Z[[ þA{dk5[ln1^ka7P/VKKKo(mpݻof"=7Z b [ z;#<Ca`D] N}%΀Hԕ`V/sج6RFק@v\N1 /GVF:+A?CmcQ8a1v 睤 XoΝ;Gnx&aОґ0A8ʐYSS\w^*߬ .]4fY*jTlܸ@Mt"hJd-2| k!׶-$Y ͆NRa͢;| ?xo [z M'j1ؾ}{:u'2+I l1pőrZvaQD|kkku%bᵍbT<ەc/€B!( -Z1̚5 /SO={ ;d:/GuD] pMY&fY*\ :њapw%X⨩n-[s1}M[6l𵮕ӧcҥے005pg&ML, UD)0pD(%J•A*%]q}y-++P*Ya=^ڎj9#G 3W3'00͙HVAb .ol8 xJ8ԬoW6- w0 ?OYgKWm }&k1п# իWl:/7O|;?~b -mݨVdm}![e1JBBڵkoAR߈#"˪GV]v:̙3cַl޽A-JHb'U u6kwygb B!D00bPQQ ZYƂ+lu%8}{#35]Q_^šG4^۽(--w܁;$~3fLdƍyAݺu/m1ԩJKK444Dt > j18?16};?"00=/=)?ڣ+!?~ꊌVa_477_믿{AoСe"b,ՕbȐ!2dc {JhjjqE阕`-ϕ`߷jM'텵ZftK {(ߤ<_aP\\Am1VT ȴ;]W^~*'?ʕ+?Hk^zEĿӾIXbHuȋH?s۶mQ>2cۛ0`eNiak.隕 NrDADw)ۭ]6"n^<3x' =Yg fDۺuʢӾ9[WBAAAOp%ņ燵(Vs}LZ !h*[(s.am1Fp%Xc`4bඝu_NgaٲeQFyn#}LNsmg1Юma]ZZTDb }Y-t%Z cו`N$A86>o~gKDH$@ĪU⮟HDY A|҅u. k骪*_Z*c 9 88c faaac q%,\0nc6~ik%[, h10ߧ-oڦ,-2}mmmD?oF’%K|zS=+H@|W>ΡP(vAAA1+@M"€CW!B"P͕xmΝ;'0,-"ؼys$Q7N9Z}֟^D)~LctH+Auo;wΝ;]w.Šk׮g=_}Y~G5j1]+!?$|HWBf+0v^QPPOՈR IDATauVk2y n|h%+a߾}͚zV_ac6f+:VIw/] o,hlltu%Xs}D^ҭ첟-Qvn}:v֭[u9Z;@Hg%hAQQQX3٤0hnnJ붍Pq E{ >g"P@MT[ R>444D= ۷G}s[-~] ZL KuJd銉/ }555wͼ>^ MMiݽa="a`r:?&f%ń.&^2B@a`ڕw^+aYo1x'<O>A߾}q7O2Gu%DMs"  1(((vvۿ5 M4[%(No~ 1[LwA"eccVVV'[&\ 1 Z +N7)K, U1":1࣏>7ߌ;v`̙,zu%I*0hmm^u2Vq a`}اjuݷoߨ3^ZL>6N)^z ,@kk+.]kZ oECo2nI>hHV$]P?p{Z*N?oAb b1QR?+ak#;+Ȝ0pJ&׺V  O>Wzuʦax;5B!C@a`C&ƵB&G?>_;uM HCշ O5&b ֿu%rN㝓v nV<~(Lu3::.ȱz{;^1NG'W[߶mJp}wdb &n~ @ 1+`Kĕ`MUĻ֒Ø;wEAhjjyP&c'uNtC ^/WNY+뭹5z]c q /W>:u]z7]ٳY{0p >u޽}k q~Ok%HkJ]"[-$af%)Q/2Y ~O?g}sln{ s= "Mt\ZZZ$ /`_ޱ} b-𞕐C@1ЖDb I83گT[- Jp{;uAhY [lW_<;6Ί5sa`Ca0e̝pfu~|+^)@uN"2@b@ϩ̳uVoȐ!o޼---Quߺ?~MՀsS?Mh)=Y ֔NݮUVܵkW{~1 ?0p+?n0ŀB! xd+A[[[ﻮgw%x$j1hjjL+pM"F׷x>td+oN11j1hiiMkQQQ A1pZ_7oAkkkdt̉|E!? Ft6W;VWB# oLc` ?Ca{VBzLhn]ٯ+:+AD\O&̕`5]^ 5[qC0vc`xS- f% 1444Dgqq1BVa |IMu$cG7J5nҤIشiS`5L5i$|[J8o@u`J@?,7~^]mcRXϘXWRRJTVVpn^ ȞG}90ۧb`^Yw"_bºcĩg e1cqmaK'm=~Ӗd?˗G ~1ӤXCAߠ:EmNnJA(BϞ=k׮ tE[>ܯ+N۹Y ^\ ijDg*D_[[ JwdKYb`֖|`>.P\pEo|n݊[Fn^bV5կӍ0VAQw^+[n֭[%٭2@lKfVJWJda= 0ȆY cbZ~m 뵥\( !0@q8thk@[tGOk g/*|IN1f~=]8J,vJj1V+))e1EEEX] ޮ(%Z+k)_WB^^/^^TT3ZA~~uXTT黟,ik[AT<͎[|H{0/૮Bm8-/,~3^qhwߍn*sk.|@vf>?Vx' )..Fqq/S}Jtf%q%LpOԕP(5Zhӳ>^C܊(;J]+!1 >tãߛݻwr*(&L@⋱Ѻ_:z_q0`: Sm-β|wgq|A*pipx" 5",~'|X cPQQ]趵0j1~Z8*  0Hb?{.Aկp89ZdeJnJK2r%N[2j}#1D,f%dIxڷŀ{C=e˖aڴiv-^_2У:.ּ<M:7-m7f3f >l^k+jkk#xb\~P=zD"b~$b1*bJpsX-@8@oP^^-[ Y A-zNb"O~@D/= 2f DW0J(+_\ BJ<p%hxH2J(,,x/B!C@aZ1X"'xM \@[b^^^.,[ >uEG_W#O+oo JHU.jb`}Hԕ~Y %IޏWRM"dc ,~;jy~8p+a"6k? ǯc'ӚˁQm^-gLW s%h[ hGIII-&y;z7-Ce+jYSQQTAqm=V_7p}QzQ=~C=:{d$JAH1ڃ[,R1+!0pK㶝wmScPVVő @ՎM@@qEʝj;--->ڱv~s`D ^}׬}mY?c|xVd-ltN3f;P  EZ[[cSMvW^&ެfMV"\{-`;wx O>/UVF/MSz`9wfI-xwgy_|1!BP$~^z)j}'(ߜNii)җ"J>G2c}]0 *&akU`̙=q".zR 1A] g1H֕cbbBW^>][|๝beZ-[z=? rgSqnm1fZ`V~ul2c '_28hxy?Ș1Q.BbuuuC57F}/A[QXX>}y%)iy>߶>p"ڰ NO1hjjrB5kf/L (6mbӦMr-G\.S.GL&GG Ԕȕ*/v>{b0<L1PgOA· 6i q2x`j:;yQ*AXd.p׿7JR(P+X-sm^(db*Tk,AAyMI?-d}$_X*>9)ڳAV!#"pѢE6q>O ;\Dy \~g^xA{P b33wǼT|()4Xw~8v  <,6ۿSO%],:{V…t)HT"oWyguss+gTﵫ Ǯ.?_%S6%k@NC'6nPsnv˩[RO~RQ PlNRԑћ.\8 vuuq0^naز|21J%b˸ɥXwiB{\w/΢Evb3> %x/IO\Ae ^SSg&XP,?_̈́iSt>A >QLk(]s /rs!oeq.'PsR̜9^`qDZf O :km?V4 w75A[}kӶ[> ~A?/"/n顳|>[C1Pb@(rJAA d{] +.q|ڧNԩSCG 3Z* qq}!MHެg@}sꉁA['M6 g^EɜZ@{;4dE=(aM+WG9~:b PL ;+Zdi}cNM)|3+?U L÷2iX{;:pSњ/cppлB>PG `\FmVfc֑, Ĺd1z{{=v3ft>ϧDG1KmVT*1M G1#Vqu@  1hMfE mXY߲~=-ӆw`sZ *$b<0oz" c2xA "Ig K__?J@E~D~Nb2 IDAT>s I<|/Q Z0Ġp'3 7~X}v!#]r3^xb000euu8۴SI8L18l.P _^*q#8< =mcgG_vM̱:'H1gcǔ eD1M.0`·5g}t'A7ЬO$eV1eȦLOIՑUBAr's1޲/|-CL@ʮ XO?Z500Rke88-ڵ˹ ]hc<_usܬcXI$lF10N`m6l= td<ҩTٖ{]fsqm7]È5R%bcgW-B6 Dt>Aϔ ։xźޔ@5%D1Kbp= ~3R(<;)aI=I۶]%byG7mdbIT_g?9n18X9}L ~X̸>:/x\Y#=Э37b`1bpj*@!gcˮfl3Az(c(Fuw mcP._M&Ig{~)r;vh|844#X(CT w\MnNڀ9PP@M'.cppya׳~}Rh|x\_|̙υ~Q-u0E>mb{Q ^wK[ȕ]Eis!L&ocUcelNIP91 @wf6jGD3dzO)S!W੧)A> Y1qfDt3!jWgJ*YU &:*!Ȕ0E UZ V 0,\C  ~q _SXx_Kjk9JđYrżP S dSB<cdJy3;AߣwS*~kRKrSb080,yܹ;:(w-;~غlo^wb`QV3.J3}ex9w]Sb _~Ghb;|y3V .`VW^ѾQUUG}_|_MD$ "-\kCC,XO-Tgpx"]Ir7T OhǠ"b0g˙}ֱj%Z/~ڽ|ϸAsb Aۿ+t~$"Pdi~>#ȔPaTrY;_T {p睕km7(> D’L_&~ڽ{q}=O<}21< ɯdQܹs=;k)?. $&}1K}'p>bfRT|P%|YW"Grہ8b-D ~(TJ1hnn=& +NN}~ tMH&*. RFHFJ(>b1$4K9v_z(E1P| ;<2]" v]e3`K|۩پm>I{f ߉dז/1IToJ"˿ YyDdbvl:y>O0[܎PxF~aAAP]z(N\-wu:R̐c a`S(X ylL顅x _>'d}]z)\z)ŠM]7}:Lb-2 lAb 9PvjH(J02 ~1F(7$ iA\?74wg>U3gN[bcP*uZd'WYEV̓ksyЀ7ԫtR;T0v Y2mR)24?*v.oheL T %+}rA\5%ȃ}iV2;1hi!Q1F_~N'Kˬ{Z<+),::g:b*?dz@1pALRڷ OŶ1(+@ vel%@َ)!Ld=}{T}[Sʭ"QB~E+5%@b0]M^M8TUb``````` 8>UGO|Z~ #o|^mDQ (AL.c &W_mٗ{{9|Z~ #TWd2} %կBk+m Q)M>wZvٓ/w[kR(V7jn&^cJlFF}o~Nw}wL m1, iM [aP_OlԔs' JbJ[1P?L<~ PVѿIi.bVs-VHbYc+?* wNM h| L j$ Uh0ĠBTjJr0S\rTEЋfφnn+Vp&IuxQL -F5yg0f·A}oTUVy'x5%ŊE> P:!u˹y q&YkYv&%pc}; f7vGrd1vuyژq#YuJv رU|))#W.M ^v`?7~~:~og^?* w2Nlw}q| v\yςlx٬+ lBaT?TaAe"pr(OwR(@P* tuAW>d2lws9>|67*X,|^T 4I)T%r)L1c  9=SW_՞[`TOTB*•ZC @vv ?iH\c.WQU( 1Z 1)|yov麜 @Uؘ"e|=` 9=*1SE?c8{2p>z&PRW'YXα[ +;1X|9լ\| Ǜ3EjÈt=0 b3 fHuYf1}Rw~/(X4[6 JXdNű'zX84!OeQ ""-?[F<=\qhhw'iͩhȎ$U:ݬT*N:4y ڀI1}~~A{@XꑇQq%";v9Xd֠/ Svkߝ@J!*1(Pu"JM CC  e? _bm@:@RŨ:(;bC lڄ(-!obP!t\uɐgݑM bpWrWryO}w ouD^k$?wfa.@qVϳI%> UWf1PM ~|>ǴGa4$ͮwTUb(krLNNܻٔ),=)x!)K$V~d5#(>祐(KB9˖YtKYߙZnXy{7%r c T)'z͢u{]IZ|\5E1HSUUg_[_ƽBQ L 3fpoq} AsjJ89OahEbt@R" VW{si-1 !557;Abަ\~w&U[bƖ-ToJkJ}x/587e2ր( X Fl=k&ɤ˔Gz`g{X‸H>" {۩8j2M fSBbrb֔{ 1P& OLeL ?0===d2.k 6O&.1MDRIRWMAUUd2Hb`@uۧh UJuǑhTC~A'[%\&Wy ܌+W;∑u4><)u{ux4;To׮`#׻*@1h·$9 "YIqF 0eNWD" w,u(,D({UV`&bTbb~b ^ 1cP)1 b0j#O- Ub\.MSOSO9ڣP!Bx*rŽ!8'ATb ϾqJ<u3br;`nS8T;tA<M:Ҏ^C^FˣR,~Q VYs#oѦk kP<| tfL5o1uuIr2J* pTY#=i`lUb܃J Yѥ @JK"_OG W ;G R12w!~¬!C&N٬+2nfoekbJHǮ] jSG "ZJ[!DS$ɰd'-(9aC *s1L A*,YEU þַ)4RSBXz6%]אwҙg+D Wl4O: LӁ.)A W\W\A\vEX[g?k-/1۶qPeNR$_Xf=bG1S6Fk;vZkLHWÜ=ۧɲeh\sTF+j'h"tjh9ʓlC3nhiJn3·b;٩/@?(G1PCxcJ2IWXT!ښ_3bPb5}gȞ}6v3%6mQ]Q{~}Ipd@G DgD Sdy\SB??#gYh@->3da3>HܩE/1&UciPc0.A,r<-w[XJ z6)6_PR؂\mR)%s\sgАE $vϟL=s9Z#@Jq3cPb 'b"yVGHr pwZ_d<q*4>6#\|" @ uj*>P.vrq kxgN ^uz{{ϰ΀̍7Rkx21hzUI^ #Y\WQ ##`?_#`L&Y\r% ^1PM w}7Gy$?OCASb61%òpUp-"xzO24bh]{F10G1%9 BIBD.iAXT/~ {9b1\YWnA[b0}WR' *1A^,? S±d<@7ֿvX!/7ް'IO:m-iNCʪ5H6"ADs=xp T)vu3}THy\1fe|A1d2ߊKKYj'Vj H.&0K%(qL&ogc1Xv-k׮;mJtmX'voXnN47+W2eY>!+"F ZgW TS_i ,{^o+{{"MZam% Wܪ~t/vlWHXdttXℹxb* 34!߾llhտBSp%ʎnxYx)gնzg 1hݴrʌT4ĠE1 JR ܁6#CCnhسVGP?wHEc Sص 4*`$VGCCC(@|?~e<Ȅ",Ynp= ) "vO bSgqWOvR3Y3w.7˖b$x,j|#S,Q} wn8u>T'naj_p( |ŔU18 YJӾ;~-OˊyR] hwn- -Zį}?rq 7su "[N 3%5UØٝ.6ipOA%KxvsoX[K H&uvP8i]ϻB%AC |y2+K@7(۷ow|>ʶڃ@\I^>(@QVdobF71^y6ugB v|#*1D5%iɤs0b xU|jOD,1ب|{b𳟹~r9l/d2{ bR,Z4Q)'NHmC80ĠBQfar}*VM:KTEy& l_W]X9ƅH\4662\baJ>eNf]mmt)j~>O)f_Lݬab^Rw~6]cŗ فlj-T-OR z ja%Ŕ_@b`Dr$w]~Xt{7+AjJF<bֆǫ@yn~]b`,M r(Ko'xcw$Ioj>>ǭSѓ 'f|]mh,vr uiBWaw[9)\HfU$;TaAA[['-Xb,M TwidYS`466:rcy,dsdJkQ u5lU+<e3%)5"3l|.dG[y@ XS^(ӬG1%N%ɱJ$b \f(o ٌM\&ϳWRֿ޴QC)!oKIP)?SB7Φ1x' %9D[FMM +JQL m͔ޝ'TҞKƟ6  uֿ?^|1͊ώ.;#ЩMJ ɘ HӮN9Jx'kf7c 3*JNG1Rƙg$ǣ~ӦM//wJ'EE?Y+5>n,A:n^>NJS0NZq%d!̝K28R <U+1e +$V1 u>ufM GIڣ\CbxSϡWA`kxQ\۵#C1S ն)D1Pž}<1PGD%F 2 +lT֬(b̲\$6xiM#~sLHc0<<[P!"H>8&2*r r ~v{hjjbҥ.)rus+=pｮ3--6_ ;tǠnpTSB4%̚ZUJM A2 rN_Iz]" cL)' -Ui'qx{`T Cv1ƹWyden }MMi;JLZGg<(JH;Sbٰ6yj)^B6%h<$`4(2cTU9M[ç>_s :t `hJPژQ +iL ;Pc(ɨDͮ]\ɆPW;g;SjD-Q"=߿@YV} ЛmJE% ,*A"4)A b # 1xQ+_*歌U:bg6cJ8÷!Oet=a(1n/}KڮzXS5V;8 H1{7os{txP_^͙@8x!>o'usNL^ztuui&Xv:k1\!ZufY #}T~ղyG# ੓x_#C Rj8U;`{yTbP*Xb+V`KG >($܊5TcpgrP!N1'>8%tl+~G%\D"t^gy&'OꫯTujaBUi~9NoWڋjSW)uIkBmJO<O-R1PN`K,~W?t]ؾxd”J8 CBMY{睮dة`5r<,Я]v',zҤIL6,PITwݻϯ;:\!2n?aiq݂碋.`td2* W2Ν;ٹsn?]xi"Y| n>mmmZdڴi܏mPL$(&p|Ͼ0ɦM0)5dC FAЋ6ѨԔB33}P4X&òw|3l8E!`u21(˿*\M J%1L$؆m(P!ҤƔ @ڔZv cPV21P;f^bmI`?N%X˖}tlᇻ``Q.-1#|7*!hVA zzz\:2~+\qǿ'AP,e>ù۵NJ.f_쳟})!JNԆ`a(>:1;,X͑: b @Yr`fb*",4>*1>ݙYWcYhzqd>bH$6m(N۷)I<>|c "r"}H56`%z b@c A1蠣}Fc41Fhlr`FA\v/t`=2r.Uӟ!oy즄J9DP(D&DD"c!q:]==xDQL P B(}pEAT x VFD)A=nK5ؾ(A)iWrK?\tQy$X1p!Δ SPRbW@`9\Q0/vZ}b E1 oCpAA 2@ j.1V ?p.׳w^)!b```````Q@`7% Y\SBT8ZS5\5\O?]rԓ 9)!@2%smH%% agP -#Sds;wd(A倓+V3G/! k|T)Qmojm&V)AV R2 Ȕ+FQ)NAP(Jh@}u#D!'_۶muV`}r±K2T*SO$Z;a( DI>q} tq"i%CLw/+;VD)%1H$N;<>)a82NQa0|}kzmT{ǷYbկ~O$gvϽRK PPлb Ԕi/} ԐƊ:eAv%+MَKz,1C$%[D2l߾!7I(U5+>lyW%Ʋgٲe{̎=0`8} N˗k˰M=v@ 9b`(e}|)wf-R2`QY| "?OD%I;;1<z8>MY(jFcI@?2; O={``@cw/ b0gyhkT8M:C @_b`V ƒ̘1/ˑC*-#.T*L&yq(%p 9 !ă! 1t3ٔ`P$ O$ns+jg$=24dU/,\>O:$)J{RSAS%” UN&=e{Z<˷݆U l>(ZK)ai3եFvgGg IDATJZ 2D(AgP&Qr[IϔN18 :)`6%DIu<^8r9~n,DiZSTY0S.[۷ӰN \.f<$NP|؟8UK0lp-1cJTA(`J,C%Bc JL&=Uam3%$J:њ{8:b7#xB|ZIe;Q@t{X]uБk|.b]M`sj P_ONd@`6K\IPA>I {'E1R ).bͫF1{m+vq{%U&L:Pou?&b0 舁 Xd L+Wo֭[SO=_lC>w?юPb޸| !bN`R|8TB D_.gՔ ߇D 7#Z@%WdJ2WCX8,›C (a|eSBx"*Sbl2|L޷QA8_?Sa戍AlB?R9Ab E+RĹD8ٱo+pn٦hW[> b'3% X+oSQ .b0 ĠtUKYԔhkJ lQ J{JדT: ;0%ꢚ\?wp?B0g\~

v16xDJNkJ9EJZ @YFv灐-b161Pd\),Pb617IjŐnr9=xnx9V@2\Qn$BhBGx0·b0 ;!p{/ܢbV[ -L@1"ٳ mH3y:ړL&IRD"Acc#wS/F T C a`0b :r涨(eK˖% q3eTBJ% B:aU1(IuQ"0Nzl(r8zet)`6)aH*6;X1 j[#f9 33f`09>UUUeSB|הO޲iwHz=b5Q*ro1oPKGU cAT9(|q+ghb`0!Ԕ KϔAmK76f)Sx'8gqN8XF \Q`3} E+_dĺv9>hĔVjJP2@t'AW6 1J^0`BP)1LmD!L_kֿq䑀,v<1bϬ+¹TG uB eqEq>Tc *0\&*`)?κwCaW+b0sxI3Z \V| TYW444& A6u:ɸ@[1ұ2J‰'XWTv`mm\"qÔW)Ei} X4+ᜅ6D)%A RT*Q O\"T*4G\bŔ #b`L ڌoҥar<|k[$tm8Xn9w^bՌPk%%iC'3@kVvJM a*rvJ| E eW_*$^hR`,SP ZZZ"mc|8>c|h2 {;UUU>s9VBZt7notG%Q;/xixC+9yxS" ;|:MDǔ cHݯRbr l?x) *!]?r# 0ծ9oS'\0 & B JgpaNmAsD1+5dg_9.qjl)k1:z1۽{7g~Jnil14y(!iOZS"\p_:+t۸PX+~SnQdMzą 1!Dؖ\f :d2Y1:Ylss3UUUEz{{#f\bc$O$򗏳b 0ĠRŠ}}\{CJVJ  b߇nW *!q'>OVuO>9%$ V_$GvaL b`0aԔp(Eft30*~DVqf(aI&KJXA0%b 'Ppf7/5@U q(Ae.]ŇaEN;4Z[[2eJcU`A ]]]ʫ |T9x`׮]vQK\SB]]If@,8Q u ߿uP~MMM\|Fo'%UqO9`HY `@X0 $BA t(`,(ruW~іDU6i2o߾,2s߿ȌWˀkkWkQ-6e"]ktIp4PGM<`aagJT1K (rZ?]oHcnJX,ʂ9Q  $.2%'8)<00I1w8y 1PCcm0b & ~:lo| *A>A+F1at,r02]pU@_ M ,|_A&JȊAmm-}}}.à `1% :b`0a>}:W(b7*Xa@cŔ0888@taM &"Z'JyG%@n1%1c00`BqW8x/&#D Juy q4< =ew9fYrcaTbdHR | ^@_x"Q)ky!1%P bhA>rCaO$466Fn_Q c#~:늢䩥E&m} :߿I|0Q 2 )8a9L J)!Ja2ر9#S,) XQ oyHۃDQ >ϓfiiia z:Q\.+2%l۶Yw( ` `Fe8i$8ԔӮ$Sqtz3q\hO=O?4`ݳEQz qڨcJbp0dy &F100Eb$ } A@8x'bD82V|8AmTø TMO3ZC؈C >qL(P1/~G!xI)~Q/@\#'/NMMA(o=b```C1 8pY7)X)E%g%}OeBTB (1% b N%30! 1001ZSBpŸ3OT(+a1%(qY(QfͺEU >bPI%?.'n``c4ĠT*9AgHR)8aF|4Ŕ 큃@}:` n7n(94Xi'%`*Q r͢=d/e)mjiiyZbf lF1k&M`d>B mc 5U?^ኣQ @n!o=b```````7LU٬']TS g°ٲ. W,J0L:[5%T*WcOgJ,a y`+g, L9swTSB)A[%J1)ؐ&ϻڨ3[_\ٳ#RxE% RY:y}t/b +·Akk7؈C 䎳P("{u Y)p(A:FQMT@Dxx+SC <6o8JE[ZZرc]1p(J| 3(̘1#t@|v]y@hjjbҤIon & SH|v^yN8'b #R)!rTxwнĔNr1ԔPI8Q rLxx 鴩!6d޽WY{^(xBѶ pM `[_WLqfwFyL;Sf:[qiDDEA-*ACP }'+@3ireu/0 Ç_*ח~ITB.=sμ0w㎌>']!G"v/` HRHdΜ9l {1t^`رg͇W/M%Q 2ƌ>']ҧװaò>p뭷uD@DDDz04662j(:~lr~W=h-]tEs룄%Kc92IX&O_ȑ K9Yzn= {/%DYm͚5ܹH0H_{ ||TBIп*da,%r*!0У[{;ۿ=W_ >|Y^K܀kcZ䚕r-rU,Z7R9'X;* $g7z {y%/G a,R,C 4Jã+W2qD * n֯_϶m.: cpWs7֦G -[`2xM,/P_/h 1x1:ղ(<>π|BfvfX ZB ;Pl%:1y  %Gy\v g7dzt5~`-.\' }6G0!~  a`R8qdIR2s$Gf;( G H^rQ&r) Lz ~3c .\ v-V;X(4:8`)0h庺`P٬ZD*Dw 1Hm>TB6͇(VA&r9^dc7xѣGgvz>jv `?:8MS|yAx%%EЅAzs[R׎s 2T1% &S 酀 %oNB=<q*qٱχE`^%EDD*Jwwmnc30\.{JBsVV s*\+f(O7ߜkDH )6G 1_'<@G`98` # Pmm:+E b$ M͇ ^?WՌ_k&եESmI;I2iS*О=!p<ؾjsS@5. HFC8 !N+0 gĬG";q%T"ٮ1߆3CtЦQ$In>QB…lRsnvu-Rv 䲼acƄp j0"sY u~<͛aF%{uX48[> 8`!|z@ZIw)A1Hʹ|J3gMСCYjs1Уȑ#!yTxkLuOr uDBrdCa(b؅A0Ȥ(͇o9s ͦZx@z;O=C:`e꺋aa*`4uaL*6="*qE CHHaBKޥ7^ ڵp6EavS1','gzzB5vl:mzErUk;CLJ3>5@zmg1[zυУD$R`69vG^-T^Mϣ'}1!96q+V8ztg1.ȳιhX&N  Avm^=JHN.}~\1bk_/Z4:*Xasp$<xdѮPxg)ڋ~R > Կlv ~ӟ/Kn$^]`8&&XpEP`y/zd؞}~!~ O>̴0H5EU6ٳwthկ,=]-(cw~xl *""լ' ݳ?`q(raKwR$Z[Ώ*Y544|%c=KawW^yEGc U-b|XJC.( b8X lr'Suuҳ8%Uk_NmnQB|q϶9wQSjI7UaP l'!v8b( `2)͎ ޔ)Mϣ=/`smaYiફ& jq55aV`|\[%Y8vK=ȧdf1#TvVRRKQ]̻2Xj* TAS~B]Q>EPA,w^F?xdQC8fED$o/lqrբI* `fxMC(Bdc}}Qv 2ɓJ$qG]dGqȅR6A,\G>7YtϞP!Ν mzzL0I7ec1l.cG_/El$8B);l*W^ɓaR(R~_'!0w|11S [n/Av-o}}7VZY1\8ahw7^XZ]2xgxg92Zx\͇"xC>6[-. b9E?8`a MϣI|Y`<6C`p1UDaK$y.hn?yBKKK_'~pWp} yӹ;yG>|O%H[.1C> ߳ZT\asp8wl2YTRdFb߾}WFπj,envvYt- b. ާ&8*ІxæQ$ : U-26,ѡxg)9 Q!ϙvdrTeasD O,zp\M2YR$WJёdr]4ƸUua;5ش/SGlYJPa E\N(yբ S)/,?BE )ދAS0zZ0H`6ٳwȧP vSzv8dQap ;Qx̓mzE.*DIETgg"WWBzz␗: 2tFu s0s0,I$!VY * `֮ ?""NU0pp4wՙV;KXWTa ۱q{z;5NAMw^SBe\_QTSB8]}=dM_h: K|Ty*Q33;wƒvղT9$]S8M(Ygs GQJPPD[D֣1LU<́AA`*Z\2wι? 1ɬ)ŠC.F L&T6Iǎ TG\௽ڜ>O"gφ!o\ZqVh(TJwK`m?nMbꗈH81c7qȋ(ޘ 8hs0^d9+WZ (!믿 j&>=Ŝ kpբҟ 9`|`hGG[2G<H- (A2vp6-6!w1fGb* :BrɢqsceT z6;Ç:"耧 =gyӢ8SaP ʣw~U<9TmzrSh@2v-+VFC樏cEep* (~uExcCŮxg)mBcCӄ ^ZT2 HB>EB~=aPT|(A.)(f=C.* ,wO8ɢwMMMϣ'G : tuзxWQgVJnT\{PKlӵn];lYMS b&8=8[-*QaPBx%x7M G]/e@$o;wBss#ج!,%`!ɢqb¦QJOl.Æ ;󤌽Jt)|fx.7Y="D0()΍?L=w.=PsTmT={BHܹݬC.K* ʌ -X9z4!L 7,)!GaŊ/KJE{{e0!8dmIe(x-[`ppȦQDJI!<1o 2t|ɢw(15jhnn|YRL7Ì!1;QR4* *]?4Y=IԄ; )K>J rH[:4TrһD'b|P_?lzpp$"6y01Cyw X aJ%XYPJIQaPR,;ֆ;NG1;0{vcժmz[-*GAslB~EOw~Q*sdc|70\m)()YzQ8Bok,X?Ԏb)RaP%8ѣc h!V KTD'N w*gԃTJқJ2|jҪ UhT-E\Jk,\hc!DCԤ 0b6 m&<\,qH,y@OHs8dQaPx5lmBWE]ђCw0lTLZTʗ ;O 9hmMd(0Pa爴X9 ,%!+=Mz]Bqb``:ymk2aÆweС0Tvh'aY.Gw dM#gTx˦Q.O;e*C C eCKѻ\n M޼OwBvn"/N77.٥Gqʤ@T4^xdQÝИ1.^Rl3gpЬ!TKVJeSa sA3a&&;%1G eQX4,Nzxɬ0C+&Th OL޹xmzYrqȯEqȟZ-** $:5X;B]]ܦҩǠ֭ c/6UB8xjQTz88;M,w;|Y* `v쬊m]BmOͶc”)&K䥭/j8ds"@ AO\  )9* d;D}Qkj7Yi !&+YJ%9L$yݺx Kk׆˗[CE0vEEw ) FS&vuwxs'<`Ck h'18d)'* 8xIpdS"qKv 8yL4Ƹ:^]BNJs;v!T\BwwnO!bH!]B6R㝿y,!C+t*X>!!Muբ"Š@ʞCQs#`3]gzTA|"e<)PZ!Kw 46 wnM=z/yMϣX{{ne?â`  ()c wr& 6̜8<UW]1Gí^n#!/rjQRQERM❟7Y4_W@<&-uW^YWR@7Ìq' öjQ)<|QY_nVk$a}{*#s,""< CiOxIwuWoa׿/'?Ç[gW(AF e󫯆KqGڵ0~ýɓ':y[{.#""CL/`+_oyٳw Oz?/""R<\{^M---AWWy9{ﯾں(XbHp;]f6Bбc&ߒ+ zzȑ63!""7]w]>w.=!C\yӦY'|Ǻ?"""oh?я<௽Z+|,"";1-ｬɏ?M7ݔ!Tw ^0"""莶8dH>~|MMM2AP﯈H}Ο^́ $㐿Y煮HoWP􄰦o.>=8{ĈC`]|^q"""ar<׊}so=^9^P[HpKte [D<_0bEDD$'\q(YDDD:p.5g,yxC>=bDDD$nA'= /CDDDxO3,8;EDD$!nv.~"""R j=чø xCWHu07FNVJIENDB`gsignal/man/medfilt1.Rd0000644000176200001440000000507714420222025014447 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/medfilt1.R \name{medfilt1} \alias{medfilt1} \title{1-D median filtering} \usage{ medfilt1(x, n = 3, MARGIN = 2, na.omit = FALSE, ...) } \arguments{ \item{x}{Input signal, specified as a numeric vector, matrix or array.} \item{n}{positive integer width of the median window; must be odd. Default: 3} \item{MARGIN}{Vector giving the subscripts which the function will be applied over. E.g., for a matrix 1 indicates rows, 2 indicates columns, c(1, 2) indicates rows and columns. Where X has named dimnames, it can be a character vector selecting dimension names. Default: 2 (columns).} \item{na.omit}{logical indicating whether to omit missing values, or interpolate then using a cubic spline function (\code{\link[stats]{splinefun}}). Default: FALSE} \item{...}{other arguments passed to \code{runmed}} } \value{ Filtered signal, returned as a numeric vector, matrix, or array, of the same size as \code{x}. } \description{ Apply a running median of odd span to the input \code{x} } \details{ This function computes a running median over the input \code{x}, using the \code{\link[stats]{runmed}} function. Because of that, it works a little differently than the 'Matlab' or 'Octave' versions (i.e., it does not produce exactly the same values). \describe{ \item{missing values}{The 'Mablab' and 'Octave' functions have a \code{'nanflag'} option that allows to include or remove missing values. If inclusion is specifies, then the function returns a signal so that the median of any segment containing NAs is also NA. Because the \code{'runmed'} function does not include an \code{na.omit} option, implementing this functionality would lead to a considerable speed loss. Instead, a \code{na.omit} parameter was implemented that allows either omitting NAs or interpolating them with a spline function.} \item{endpoint filtering}{Instead of the \code{'zeropad'} and \code{'truncate'} options to the \code{'padding'} argument in the 'Matlab' and 'Octave' functions, the present version uses the standard \code{endrule} parameter of the \code{'runmed'} function, with options \code{keep}, \code{constant}, or \code{median}.} } } \examples{ ## noise suppression fs <- 100 t <- seq(0, 1, 1/fs) x <- sin(2 * pi * t * 3) + 0.25 * sin(2 * pi * t * 40) plot(t, x, type = "l", xlab = "", ylab = "") y <- medfilt1(x, 11) lines (t, y, col = "red") legend("topright", c("Original", "Filtered"), lty = 1, col = 1:2) } \seealso{ \code{\link[stats]{runmed}}, \code{\link[stats]{splinefun}} } \author{ Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/flattopwin.Rd0000644000176200001440000000321114420222025015115 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/flattopwin.R \name{flattopwin} \alias{flattopwin} \title{Flat top window} \usage{ flattopwin(n, method = c("symmetric", "periodic")) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{method}{Character string. Window sampling method, specified as: \describe{ \item{"symmetric"}{(Default). Use this option when using windows for filter design.} \item{"periodic"}{This option is useful for spectral analysis because it enables a windowed signal to have the perfect periodic extension implicit in the discrete Fourier transform. When 'periodic' is specified, the function computes a window of length \code{n + 1} and returns the first \code{n} points.} }} } \value{ Flat top window, returned as a vector. } \description{ Return the filter coefficients of a flat top window. } \details{ The Flat Top window is defined by the function: \deqn{f(w) = 1 - 1.93 cos(2 \pi w) + 1.29 cos(4 \pi w) - 0.388 cos(6 \pi w) + 0.0322 cos(8 \pi w)} where \code{w = i/(n-1)} for \code{i=0:n-1} for a symmetric window, or \code{w = i/n} for \code{i=0:n-1} for a periodic window. The default is symmetric. The returned window is normalized to a peak of 1 at w = 0.5. Flat top windows have very low passband ripple (< 0.01 dB) and are used primarily for calibration purposes. Their bandwidth is approximately 2.5 times wider than a Hann window. } \examples{ ft <- flattopwin(64) plot (ft, type = "l", xlab = "Samples", ylab =" Amplitude") } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/filter2.Rd0000644000176200001440000000321014420222025014274 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/filter2.R \name{filter2} \alias{filter2} \title{2-D digital filter} \usage{ filter2(h, x, shape = c("same", "full", "valid")) } \arguments{ \item{h}{transfer function, specified as a matrix.} \item{x}{numeric matrix containing the input signal to be filtered.} \item{shape}{Subsection of convolution, partially matched to: \describe{ \item{"same"}{Return the central part of the filtered data; same size as \code{x} (Default)} \item{"full"}{Return the full 2-D filtered data, with zero-padding on all sides before filtering} \item{"valid"}{Return only the parts which do not include zero-padded edges.} }} } \value{ The filtered signal, returned as a matrix } \description{ Apply a 2-D digital filter to the data in \code{x}. } \details{ The \code{filter2} function filters data by taking the 2-D convolution of the input \code{x} and the coefficient matrix \code{h} rotated 180 degrees. More specifically, \code{filter2(h, x, shape)} is equivalent to \code{conv2(x, rot90(h, 2), shape)}. } \examples{ op <- par(mfcol = c(1, 2)) x <- seq(-10, 10, length.out = 30) y <- x f <- function(x, y) { r <- sqrt(x^2+y^2); 10 * sin(r)/r } z <- outer(x, y, f) z[is.na(z)] <- 1 persp(x, y, z, theta = 30, phi = 30, expand = 0.5, col = "lightblue") title( main = "Original") h <- matrix(c(1, -2, 1, -2, 3, -2, 1, -2, 1), 3, 3) zf <-filter2(h, z, 'same') persp(x, y, zf, theta = 30, phi = 30, expand = 0.5, col = "lightgreen") title( main = "Filtered") par(op) } \seealso{ \code{\link{conv2}} } \author{ Paul Kienzle. Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/ellipord.Rd0000644000176200001440000000424414420222025014547 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ellipord.R \name{ellipord} \alias{ellipord} \title{Elliptic Filter Order} \usage{ ellipord(Wp, Ws, Rp, Rs, plane = c("z", "s")) } \arguments{ \item{Wp, Ws}{pass-band and stop-band edges. For a low-pass or high-pass filter, \code{Wp} and \code{Ws} are scalars. For a band-pass or band-rejection filter, both are vectors of length 2. For a low-pass filter, \code{Wp < Ws}. For a high-pass filter, \code{Ws > Wp}. For a band-pass \code{(Ws[1] < Wp[1] < Wp[2] < Ws[2])} or band-reject \code{(Wp[1] < Ws[1] < Ws[2] < Wp[2])} filter design, \code{Wp} gives the edges of the pass band, and \code{Ws} gives the edges of the stop band. For digital filters, frequencies are normalized to [0, 1], corresponding to the range [0, fs/2]. In case of an analog filter, all frequencies are specified in radians per second.} \item{Rp}{allowable decibels of ripple in the pass band.} \item{Rs}{minimum attenuation in the stop band in dB.} \item{plane}{"z" for a digital filter or "s" for an analog filter.} } \value{ A list of class \code{\link{FilterSpecs}} with the following list elements: \describe{ \item{n}{filter order} \item{Wc}{cutoff frequency} \item{type}{filter type, one of \code{"low"}, \code{"high"}, \code{"stop"}, or \code{"pass"}.} \item{Rp}{dB of passband ripple.} \item{Rs}{dB of stopband ripple.} } } \description{ Compute elliptic filter order and cutoff for the desired response characteristics. } \examples{ fs <- 10000 spec <- ellipord(1000/(fs/2), 1200/(fs/2), 0.5, 29) ef <- ellip(spec) hf <- freqz(ef, fs = fs) plot(c(0, 1000, 1000, 0, 0), c(0, 0, -0.5, -0.5, 0), type = "l", xlab = "Frequency (Hz)", ylab = "Attenuation (dB)", col = "red", ylim = c(-35,0), xlim = c(0,2000)) lines(c(5000, 1200, 1200, 5000, 5000), c(-1000, -1000, -29, -29, -1000), col = "red") lines(hf$w, 20*log10(abs(hf$h))) } \seealso{ \code{\link{buttord}}, \code{\link{cheb1ord}}, \code{\link{cheb2ord}}, \code{\link{ellip}} } \author{ Paulo Neis, \email{p_neis@yahoo.com.br},\cr adapted by Charles Praplan.\cr Conversion to R by Tom Short,\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/aryule.Rd0000644000176200001440000000373714420222025014244 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/aryule.R \name{aryule} \alias{aryule} \title{Autoregressive model coefficients - Yule-Walker method} \usage{ aryule(x, p) } \arguments{ \item{x}{input data, specified as a numeric or complex vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{p}{model order; number of poles in the AR model or limit to the number of poles if a valid criterion is provided. Must be smaller than the length of \code{x} minus 1.} } \value{ A \code{list} containing the following elements: \describe{ \item{a}{vector or matrix containing \code{(p + 1)} autoregression coefficients. If \code{x} is a matrix, then each row of a corresponds to a column of \code{x}. \code{a} has \code{p + 1} columns.} \item{e}{white noise input variance, returned as a vector. If \code{x} is a matrix, then each element of e corresponds to a column of \code{x}.} \item{k}{Reflection coefficients defining the lattice-filter embodiment of the model returned as vector or a matrix. If \code{x} is a matrix, then each column of \code{k} corresponds to a column of \code{x}. \code{k} has \code{p} rows.} } } \description{ compute autoregressive all-pole model parameters using the Yule-Walker method. } \details{ \code{aryule} uses the Levinson-Durbin recursion on the biased estimate of the sample autocorrelation sequence to compute the parameters. } \note{ The power spectrum of the resulting filter can be plotted with \code{pyulear(x, p)}, or you can plot it directly with \code{ar_psd(a,v,...)}. } \examples{ a <- Arma(1, c(1, -2.7607, 3.8106, -2.6535, 0.9238)) y <- filter(a, rnorm(1024)) coefs <- aryule(y, 4) } \seealso{ \code{\link{ar_psd}}, \code{\link{arburg}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net},\cr Peter V. Lanspeary, \email{pvl@mecheng.adelaide.edu.au}.\cr Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@gmail.com}. } gsignal/man/interp.Rd0000644000176200001440000000306714420222025014240 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/interp.R \name{interp} \alias{interp} \title{Interpolation} \usage{ interp(x, q, n = 4, Wc = 0.5) } \arguments{ \item{x}{input data, specified as a numeric vector.} \item{q}{interpolation factor, specified as a positive integer.} \item{n}{Half the number of input samples used for interpolation, specified as a positive integer. For best results, use \code{n} no larger than 10. The low-pass interpolation filter has length \code{2 × n × q + 1}. Default: 4.} \item{Wc}{Normalized cutoff frequency of the input signal, specified as a positive real scalar not greater than 1 that represents a fraction of the Nyquist frequency. A value of 1 means that the signal occupies the full Nyquist interval. Default: 0.5.} } \value{ interpolated signal, returned as a vector. } \description{ Increase sample rate by integer factor. } \examples{ # Generate a signal t <- seq(0, 2, 0.01) x <- chirp(t, 2, .5, 10,'quadratic') + sin(2 * pi * t * 0.4) w <- seq(1, 121, 4) plot(t[w] * 1000, x[w], type = "h", xlab = "", ylab = "") points(t[w] * 1000, x[w]) abline (h = 0) y <- interp(x[seq(1, length(x), 4)], 4, 4, 1) lines(t[1:121] * 1000, y[1:121], type = "l", col = "red") points(t[1:121] * 1000, y[1:121], col = "red", pch = '+') legend("topleft", legend = c("original", "interpolated"), lty = 1, pch = c(1, 3), col = c(1, 2)) } \seealso{ \code{\link{decimate}}, \code{\link{resample}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/qp_kaiser.Rd0000644000176200001440000000201214420222025014702 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/qp_kaiser.R \name{qp_kaiser} \alias{qp_kaiser} \title{Kaiser FIR filter design} \usage{ qp_kaiser(nb, at, linear = FALSE) } \arguments{ \item{nb}{number of frequency bands, specified as a scalar} \item{at}{attenuation (in dB) in the stop band.} \item{linear}{logical, indicating linear scaling. If FALSE (default), the Kaiser window is multiplied by the ideal impulse response \eqn{h(n) = a sinc(an)} and converted to its minimum-phase version by means of a Hilbert transform.} } \value{ The FIR filter coefficients, of class \code{Ma}. } \description{ Compute FIR filter for use with a quasi-perfect reconstruction polyphase-network filter bank. } \examples{ \donttest{ freqz(qp_kaiser(1, 20)) freqz(qp_kaiser(1, 40)) } } \seealso{ \code{\link{Ma}}, \code{\link{filter}}, \code{\link{fftfilt}}, \code{\link{fir2}} } \author{ André Carezia, \email{andre@carezia.eng.br}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/filtic.Rd0000644000176200001440000000464414420222025014213 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/filtic.R \name{filtic} \alias{filtic} \alias{filtic.default} \alias{filtic.Arma} \alias{filtic.Ma} \alias{filtic.Sos} \alias{filtic.Zpg} \title{Filter Initial Conditions} \usage{ filtic(filt, ...) \method{filtic}{default}(filt, a, y, x = 0, ...) \method{filtic}{Arma}(filt, y, x = 0, ...) \method{filtic}{Ma}(filt, y, x = 0, ...) \method{filtic}{Sos}(filt, y, x = 0, ...) \method{filtic}{Zpg}(filt, y, x = 0, ...) } \arguments{ \item{filt}{For the default case, the moving-average coefficients of an ARMA filter (normally called \code{b}), specified as a vector. Generically, \code{filt} specifies an arbitrary filter operation.} \item{...}{additional arguments (ignored).} \item{a}{the autoregressive (recursive) coefficients of an ARMA filter.} \item{y}{output vector, with the most recent values first.} \item{x}{input vector, with the most recent values first. Default: 0} } \value{ Initial conditions for filter specified by \code{filt}, input vector \code{x}, and output vector \code{y}, returned as a vector. } \description{ Compute the initial conditions for a filter. } \details{ This function computes the same values that would be obtained from the function \code{filter} given past inputs \code{x} and outputs \code{y}. The vectors \code{x} and \code{y} contain the most recent inputs and outputs respectively, with the newest values first: \code{x = c(x(-1), x(-2), ... x(-nb)); nb = length(b)-1}\cr \code{y = c(y(-1), y(-2), ... y(-na)); na = length(a)-a} If \code{length(x) < nb} then it is zero padded. If \code{length(y) < na} then it is zero padded. } \examples{ ## Simple low pass filter b <- c(0.25, 0.25) a <- c(1.0, -0.5) ic <- filtic(b, a, 1, 1) ## Simple high pass filter b <- c(0.25, -0.25) a <- c(1.0, 0.5) ic <- filtic(b, a, 0, 1) ## Example from Python scipy.signal.lfilter() documentation t <- seq(-1, 1, length.out = 201) x <- (sin(2 * pi * 0.75 * t * (1 - t) + 2.1) + 0.1 * sin(2 * pi * 1.25 * t + 1) + 0.18 * cos(2 * pi * 3.85 * t)) h <- butter(3, 0.05) l <- max(length(h$b), length(h$a)) - 1 zi <- filtic(h, rep(1, l), rep(1, l)) z <- filter(h, x, zi * x[1]) } \seealso{ \code{\link{filter}}, \code{\link{sosfilt}}, \code{\link{filtfilt}}, \code{\link{filter_zi}} } \author{ David Billinghurst, \email{David.Billinghurst@riotinto.com}.\cr Adapted and converted to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/detrend.Rd0000644000176200001440000000214114420222025014354 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/detrend.R \name{detrend} \alias{detrend} \title{Remove Polynomial Trend} \usage{ detrend(x, p = 1) } \arguments{ \item{x}{Input vector or matrix. If \code{x} is a matrix, the trend is removed from the columns.} \item{p}{Order of the polynomial. Default: 1. The order of the polynomial can also be given as a string, in which case \code{p} must be either \code{"constant"} (corresponds to \code{p = 0}) or \code{"linear"} (corresponds to \code{p = 1}).} } \value{ The detrended data, of same type and dimensions as \code{x} } \description{ \code{detrend} removes the polynomial trend of order \code{p} from the data \code{x}. } \examples{ t <- 0:20 x <- 3 * sin(t) + t y <- detrend(x) plot(t, x, type = "l", ylim = c(-5, 25), xlab = "", ylab = "") lines(t, y, col = "red") lines(t, x - y, lty = 2) legend('topleft', legend = c('Input Data', 'Detrended Data', 'Trend'), col = c(1, 2 ,1), lty = c(1, 1, 2)) } \author{ Kurt Hornik, \email{Kurt.Hornik@wu-wien.ac.at}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/fftconv.Rd0000644000176200001440000000274614420222025014407 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fftconv.R \name{fftconv} \alias{fftconv} \title{FFT-based convolution} \usage{ fftconv(x, y, n = NULL) } \arguments{ \item{x, y}{input vectors.} \item{n}{FFT length, specified as a positive integer. The FFT size must be an even power of 2 and must be greater than or equal to the length of \code{filt}. If the specified \code{n} does not meet these criteria, it is automatically adjusted to the nearest value that does. If \code{n = NULL} (default), then the overlap-add method is not used.} } \value{ Convoluted signal, specified as a a vector of length equal to \code{length (x) + length (y) - 1}. If \code{x} and \code{y} are the coefficient vectors of two polynomials, the returned value is the coefficient vector of the product polynomial. } \description{ Convolve two vectors using the FFT for computation. } \details{ The computation uses the FFT by calling the function \code{fftfilt}. If the optional argument \code{n} is specified, an \code{n}-point overlap-add FFT is used. } \examples{ u <- rep(1L, 3) v <- c(1, 1, 0, 0, 0, 1, 1) w1 <- conv(u, v) # time-domain convolution w2 <- fftconv(u, v) # frequency domain convolution all.equal(w1, w2) # same results } \seealso{ \code{\link{conv}}, \code{\link{conv2}} } \author{ Kurt Hornik, \email{Kurt.Hornik@wu-wien.ac.at},\cr adapted by John W. Eaton.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/sos2zp.Rd0000644000176200001440000000246014420222025014173 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sos2zp.R \name{sos2zp} \alias{sos2zp} \title{Sos to zero-pole-gain} \usage{ sos2zp(sos, g = 1) } \arguments{ \item{sos}{Second-order section representation, specified as an nrow-by-6 matrix, whose rows contain the numerator and denominator coefficients of the second-order sections:\cr \code{sos <- rbind(cbind(B1, A1), cbind(...), cbind(Bn, An))}, where \code{B1 <- c(b0, b1, b2)}, and \code{A1 <- c(a0, a1, a2)} for section 1, etc. The b0 entry must be nonzero for each section.} \item{g}{Overall gain factor that effectively scales the output \code{b} vector (or any one of the input \code{B_i} vectors). Default: 1.} } \value{ A list of class "Zpg" with the following list elements: \describe{ \item{z}{complex vector of the zeros of the model (roots of \code{B(z)})} \item{p}{complex vector of the poles of the model (roots of \code{A(z)})} \item{k}{overall gain (\code{B(Inf)})} } } \description{ Convert digital filter second-order section data to zero-pole-gain form. } \examples{ sos <- rbind(c(1, 0, 1, 1, 0, -0.81), c(1, 0, 0, 1, 0, 0.49)) zpk <- sos2zp(sos) } \seealso{ \code{\link{filter}} } \author{ Julius O. Smith III \email{jos@ccrma.stanford.edu}.\cr Conversion to R by, Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com} } gsignal/man/unshiftdata.Rd0000644000176200001440000000326514420222025015251 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/unshiftdata.R \name{unshiftdata} \alias{unshiftdata} \title{Inverse of shiftdata} \usage{ unshiftdata(sd) } \arguments{ \item{sd}{A list of objects named \code{x}, \code{perm}, and \code{nshifts}, as returned by \code{shiftdata()}} } \value{ Array with the same values and dimensions as passed to a previous call to \code{shiftdata}. } \description{ Reverse what has been done by \code{shiftdata()}. } \details{ \code{unshiftdata} restores the orientation of the data that was shifted with shiftdata. The permutation vector is given by \code{perm}, and \code{nshifts} is the number of shifts that was returned from \code{shiftdata()}. \code{unshiftdata} is meant to be used in tandem with \code{shiftdata}. These functions are useful for creating functions that work along a certain dimension, like filter, goertzel, sgolayfilt, and sosfilt. These functions are useful for creating functions that work along a certain dimension, like \code{\link{filter}}, \code{\link{sgolayfilt}}, and \code{\link{sosfilt}}. } \examples{ ## create a 3x3 magic square x <- pracma::magic(3) ## Shift the matrix x to work along the second dimension. ## The permutation vector, perm, and the number of shifts, nshifts, ## are returned along with the shifted matrix. sd <- shiftdata(x, 2) ## Shift the matrix back to its original shape. y <- unshiftdata(sd) ## Rearrange Array to Operate on First Nonsingleton Dimension x <- 1:5 sd <- shiftdata(x) y <- unshiftdata(sd) } \seealso{ \code{\link{shiftdata}} } \author{ Georgios Ouzounis, \email{ouzounis_georgios@hotmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/tripuls.Rd0000644000176200001440000000337414420222025014442 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tripulse.R \name{tripuls} \alias{tripuls} \title{Sampled aperiodic triangle} \usage{ tripuls(t, w = 1, skew = 0) } \arguments{ \item{t}{Sample times of triangle wave specified by a vector.} \item{w}{Width of the triangular pulse to be generated. Default: 1.} \item{skew}{Skew, a value between -1 and 1, indicating the relative placement of the peak within the width. -1 indicates that the peak should be at \code{-w / 2}, and 1 indicates that the peak should be at \code{w / 2}. Default: 0 (no skew).} } \value{ Triangular pulse, returned as a vector. } \description{ Generate a triangular pulse over the interval \code{-w / 2} to \code{w / 2}, sampled at times \code{t}. } \details{ \code{y <- tripuls(t)} returns a continuous, aperiodic, symmetric, unity-height triangular pulse at the times indicated in array \code{t}, centered about \code{t = 0} and with a default width of 1. \code{y <- tripuls(t, w)} generates a triangular pulse of width \code{w}. \code{y <- tripuls(t, w, skew)} generates a triangular pulse with skew \code{skew}, where \eqn{-1 \le skew \le 1}. When \code{skew} is 0, a symmetric triangular pulse is generated. } \examples{ fs <- 10e3 t <- seq(-0.1, 0.1, 1/fs) w <- 40e-3 y <- tripuls(t, w) plot(t, y, type="l", xlab = "", ylab = "", main = "Symmetric triangular pulse") ## displace into paste and future tpast <- -45e-3 spast <- -0.45 ypast <- tripuls(t-tpast, w, spast) tfutr <- 60e-3 sfutr <- 1 yfutr <- tripuls(t-tfutr, w/2, sfutr) plot (t, y, type = "l", xlab = "", ylab = "", ylim = c(0, 1)) lines(t, ypast, col = "red") lines(t, yfutr, col = "blue") } \author{ Paul Kienzle, Mike Miller.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/ellipap.Rd0000644000176200001440000000160314420222025014357 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ellipap.R \name{ellipap} \alias{ellipap} \title{Low-pass analog elliptic filter} \usage{ ellipap(n, Rp, Rs) } \arguments{ \item{n}{Order of the filter.} \item{Rp}{dB of passband ripple.} \item{Rs}{dB of stopband ripple.} } \value{ list of class \code{\link{Zpg}} containing zeros, poles and gain of the filter. } \description{ Return the zeros, poles and gain of an analog elliptic low-pass filter prototype. } \details{ This function exists for compatibility with 'Matlab' and 'OCtave' only, and is equivalent to \code{ellip(n, Rp, Rs, 1, "low", "s")}. } \examples{ ## 9th order elliptic low-pass analog filter zp <- ellipap(9, .1, 40) w <- seq(0, 4, length.out = 128) freqs(zp, w) } \author{ Carne Draug, \email{carandraug+dev@gmail.com}. Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/cheby1.Rd0000644000176200001440000000611614420222025014110 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cheby1.R \name{cheby1} \alias{cheby1} \alias{cheby1.FilterSpecs} \alias{cheby1.default} \title{Chebyshev Type I filter design} \usage{ cheby1(n, ...) \method{cheby1}{FilterSpecs}(n, ...) \method{cheby1}{default}( n, Rp, w, type = c("low", "high", "stop", "pass"), plane = c("z", "s"), output = c("Arma", "Zpg", "Sos"), ... ) } \arguments{ \item{n}{filter order.} \item{...}{additional arguments passed to \code{cheby1}, overriding those given by \code{n} of class \code{\link{FilterSpecs}}.} \item{Rp}{dB of passband ripple.} \item{w}{critical frequencies of the filter. \code{w} must be a scalar for low-pass and high-pass filters, and \code{w} must be a two-element vector c(low, high) specifying the lower and upper bands in radians/second. For digital filters, W must be between 0 and 1 where 1 is the Nyquist frequency.} \item{type}{filter type, one of \code{"low"}, \code{"high"}, \code{"stop"}, or \code{"pass"}.} \item{plane}{"z" for a digital filter or "s" for an analog filter.} \item{output}{Type of output, one of: \describe{ \item{"Arma"}{Autoregressive-Moving average (aka numerator/denominator, aka b/a)} \item{"Zpg"}{Zero-pole-gain format} \item{"Sos"}{Second-order sections} } Default is \code{"Arma"} for compatibility with the 'signal' package and the 'Matlab' and 'Octave' equivalents, but \code{"Sos"} should be preferred for general-purpose filtering because of numeric stability.} } \value{ Depending on the value of the \code{output} parameter, a list of class \code{\link{Arma}}, \code{\link{Zpg}}, or \code{\link{Sos}} containing the filter coefficients } \description{ Compute the transfer function coefficients of a Chebyshev Type I filter. } \details{ Chebyshev filters are analog or digital filters having a steeper roll-off than Butterworth filters, and have passband ripple (type I) or stopband ripple (type II). Because \code{cheby1} is generic, it can be extended to accept other inputs, using \code{cheb1ord} to generate filter criteria for example. } \examples{ ## compare the frequency responses of 5th-order ## Butterworth and Chebyshev filters. bf <- butter(5, 0.1) cf <- cheby1(5, 3, 0.1) bfr <- freqz(bf) cfr <- freqz(cf) plot(bfr$w / pi, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-40, 0), xlim = c(0, .5), xlab = "Frequency", ylab = c("dB")) lines(cfr$w / pi, 20 * log10(abs(cfr$h)), col = "red") # compare type I and type II Chebyshev filters. c1fr <- freqz(cheby1(5, .5, 0.5)) c2fr <- freqz(cheby2(5, 20, 0.5)) plot(c1fr$w / pi, abs(c1fr$h), type = "l", ylim = c(0, 1), xlab = "Frequency", ylab = c("Magnitude")) lines(c2fr$w / pi, abs(c2fr$h), col = "red") } \references{ \url{https://en.wikipedia.org/wiki/Chebyshev_filter} } \seealso{ \code{\link{Arma}}, \code{\link{filter}}, \code{\link{butter}}, \code{\link{ellip}}, \code{\link{cheb1ord}}, \code{\link{FilterSpecs}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net},\cr Doug Stewart, \email{dastew@sympatico.ca}.\cr Conversion to R Tom Short,\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/idct.Rd0000644000176200001440000000274314420222025013662 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/idct.R \name{idct} \alias{idct} \title{Inverse Discrete Cosine Transform} \usage{ idct(x, n = NROW(x)) } \arguments{ \item{x}{input discrete cosine transform, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{n}{transform length, specified as a positive integer scalar. Default: \code{NROW(x)}.} } \value{ Inverse discrete cosine transform, returned as a vector or matrix. } \description{ Compute the inverse unitary discrete cosine transform of a signal. } \details{ The discrete cosine transform (DCT) is closely related to the discrete Fourier transform. You can often reconstruct a sequence very accurately from only a few DCT coefficients. This property is useful for applications requiring data reduction. } \examples{ x <- seq_len(100) + 50 * cos(seq_len(100) * 2 * pi / 40) X <- dct(x) # Find which cosine coefficients are significant (approx.) # zero the rest nsig <- which(abs(X) < 1) N <- length(X) - length(nsig) + 1 X[nsig] <- 0 # Reconstruct the signal and compare it to the original signal. xx <- idct(X) plot(x, type = "l") lines(xx, col = "red") legend("bottomright", legend = c("Original", paste("Reconstructed, N =", N)), lty = 1, col = 1:2) } \seealso{ \code{\link{dct}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/filtfilt.Rd0000644000176200001440000000546414420222025014557 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/filtfilt.R \name{filtfilt} \alias{filtfilt} \alias{filtfilt.default} \alias{filtfilt.Arma} \alias{filtfilt.Ma} \alias{filtfilt.Sos} \alias{filtfilt.Zpg} \title{Zero-phase digital filtering} \usage{ filtfilt(filt, ...) \method{filtfilt}{default}(filt, a, x, ...) \method{filtfilt}{Arma}(filt, x, ...) \method{filtfilt}{Ma}(filt, x, ...) \method{filtfilt}{Sos}(filt, x, ...) \method{filtfilt}{Zpg}(filt, x, ...) } \arguments{ \item{filt}{For the default case, the moving-average coefficients of an ARMA filter (normally called \code{b}). Generically, \code{filt} specifies an arbitrary filter operation.} \item{...}{additional arguments (ignored).} \item{a}{the autoregressive (recursive) coefficients of an ARMA filter, specified as a vector. If \code{a[1]} is not equal to 1, then filter normalizes the filter coefficients by \code{a[1]}. Therefore, \code{a[1]} must be nonzero.} \item{x}{the input signal to be filtered. If \code{x} is a matrix, all colums are filtered.} } \value{ The filtered signal, normally of the same length of the input signal \code{x}, returned as a vector or matrix. } \description{ Forward and reverse filter the signal. } \details{ Forward and reverse filtering the signal corrects for phase distortion introduced by a one-pass filter, though it does square the magnitude response in the process. That’s the theory at least. In practice the phase correction is not perfect, and magnitude response is distorted, particularly in the stop band. Before filtering the input signal is extended with a reflected part of both ends of the signal. The length of this extension is 3 times the filter order. The Gustafsson [1] method is then used to specify the initial conditions used to further handle the edges of the signal. } \examples{ bf <- butter(3, 0.1) # 10 Hz low-pass filter t <- seq(0, 1, len = 100) # 1 second sample x <- sin(2* pi * t * 2.3) + 0.25 * rnorm(length(t)) # 2.3 Hz sinusoid+noise z <- filter(bf, x) # apply filter plot(t, x, type = "l") lines(t, z, col = "red") zz <- filtfilt(bf, x) lines(t, zz, col="blue") legend("bottomleft", legend = c("original", "filter", "filtfilt"), lty = 1, col = c("black", "red", "blue")) } \references{ [1] Gustafsson, F. (1996). Determining the initial states in forward-backward filtering. IEEE Transactions on Signal Processing, 44(4), 988 - 992. } \seealso{ \code{\link{filter}}, \code{\link{filter_zi}}, \code{\link{Arma}}, \code{\link{Sos}}, \code{\link{Zpg}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net},\cr Francesco Potortì, \email{pot@gnu.org},\cr Luca Citi, \email{lciti@essex.ac.uk}.\cr Conversion to R and adapted by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/buttap.Rd0000644000176200001440000000143014420222025014226 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/buttap.R \name{buttap} \alias{buttap} \title{Butterworth filter prototype} \usage{ buttap(n) } \arguments{ \item{n}{Order of the filter.} } \value{ List of class \code{\link{Zpg}} containing poles and gain of the filter. } \description{ Return the poles and gain of an analog Butterworth lowpass filter prototype. } \details{ This function exists for compatibility with 'Matlab' and 'Octave' only, and is equivalent to \code{butter(n, 1, "low", "s")}. } \examples{ ## 9th order Butterworth low-pass analog filter zp <- buttap(9) w <- seq(0, 4, length.out = 128) freqs(zp, w) } \author{ Carne Draug, \email{carandraug+dev@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/polyreduce.Rd0000644000176200001440000000116214420222025015104 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/polyreduce.R \name{polyreduce} \alias{polyreduce} \title{Reduce polynomial} \usage{ polyreduce(pc) } \arguments{ \item{pc}{vector of polynomial coefficients} } \value{ Vector of reduced polynomial coefficients. } \description{ Reduce a polynomial coefficient vector to a minimum number of terms by stripping off any leading zeros. } \examples{ p <- polyreduce(c(0, 0, 1, 2, 3)) } \author{ Tony Richardson, \email{arichard@stark.cc.oh.us},\cr adapted by John W. Eaton.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com} } gsignal/man/hilbert.Rd0000644000176200001440000000441514420222025014366 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/hilbert.R \name{hilbert} \alias{hilbert} \title{Hilbert transform} \usage{ hilbert(x, n = ifelse(is.vector(x), length(x), nrow(x))) } \arguments{ \item{x}{Input array, specified as a vector or a matrix. In case of a matrix, the Hilbert transform of all columns is computed.} \item{n}{use an n-point FFT to compute the Hilbert transform. The input data is zero-padded or truncated to length n, as appropriate.} } \value{ Analytic signal, of length \code{n}, returned as a complex vector or matrix, the real part of which contains the original signal, and the imaginary part of which contains the Hilbert transform of \code{x}. } \description{ Computes the extension of a real valued signal to an analytic signal. } \details{ The function returns returns a complex helical sequence, sometimes called the analytic signal, from a real data sequence. The analytic signal has a real part, which is the original data, and an imaginary part, which contains the Hilbert transform. The imaginary part is a version of the original real sequence with a 90 degrees phase shift. Sines are therefore transformed to cosines, and conversely, cosines are transformed to sines. The Hilbert-transformed series has the same amplitude and frequency content as the original sequence. The transform includes phase information that depends on the phase of the original. } \examples{ ## notice that the imaginary signal is phase-shifted 90 degrees t <- seq(0, 10, length = 256) z <- hilbert(sin(2 * pi * 0.5 * t)) plot(t, Re(z), type = "l", col="blue") lines (t, Im(z), col = "red") legend('topright', lty = 1, legend = c("Real", "Imag"), col = c("blue", "red")) ## the magnitude of the hilbert transform eliminates the carrier t <- seq(0, 10, length = 1024) x <- 5 * cos(0.2 * t) * sin(100 * t) plot(t, x, type = "l", col = "green") lines (t, abs(hilbert(x)), col = "blue") legend('topright', lty = 1, legend = c("x", "|hilbert(x)|"), col = c("green", "blue")) } \references{ \url{https://en.wikipedia.org/wiki/Hilbert_transform}, \url{https://en.wikipedia.org/wiki/Analytic_signal} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net},\cr Peter L. Soendergaard.\cr Conversion to R by Geert van Boxtel, \email{gjmvanboxtel@gmail.com} } gsignal/man/fir2.Rd0000644000176200001440000000426014420222025013575 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fir2.R \name{fir2} \alias{fir2} \title{Frequency sampling-based FIR filter design} \usage{ fir2(n, f, m, grid_n = 512, ramp_n = NULL, window = hamming(n + 1)) } \arguments{ \item{n}{filter order (1 less than the length of the filter).} \item{f}{vector of frequency points in the range from 0 to 1, where 1 corresponds to the Nyquist frequency. The first point of \code{f} must be 0 and the last point must be 1. \code{f} must be sorted in increasing order. Duplicate frequency points are allowed and are treated as steps in the frequency response.} \item{m}{vector of the same length as \code{f} containing the desired magnitude response at each of the points specified in \code{f}.} \item{grid_n}{length of ideal frequency response function. \code{grid_n} defaults to 512, and should be a power of 2 bigger than \code{n}.} \item{ramp_n}{transition width for jumps in filter response (defaults to \code{grid_n / 20}). A wider ramp gives wider transitions but has better stopband characteristics.} \item{window}{smoothing window. The returned filter is the same shape as the smoothing window. Default: \code{hamming(n + 1)}.} } \value{ The FIR filter coefficients, a vector of length \code{n + 1}, of class \code{Ma}. } \description{ Produce a FIR filter with arbitrary frequency response over frequency bands. } \details{ The function linearly interpolates the desired frequency response onto a dense grid and then uses the inverse Fourier transform and a Hamming window to obtain the filter coefficients. } \examples{ f <- c(0, 0.3, 0.3, 0.6, 0.6, 1) m <- c(0, 0, 1, 1/2, 0, 0) fh <- freqz(fir2(100, f, m)) op <- par(mfrow = c(1, 2)) plot(f, m, type = "b", ylab = "magnitude", xlab = "Frequency") lines(fh$w / pi, abs(fh$h), col = "blue") # plot in dB: plot(f, 20*log10(m+1e-5), type = "b", ylab = "dB", xlab = "Frequency") lines(fh$w / pi, 20*log10(abs(fh$h)), col = "blue") par(op) } \seealso{ \code{\link{Ma}}, \code{\link{filter}}, \code{\link{fftfilt}}, \code{\link{fir1}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R Tom Short,\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/polystab.Rd0000644000176200001440000000127514420222025014573 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/polystab.R \name{polystab} \alias{polystab} \title{Stabilize polynomial} \usage{ polystab(a) } \arguments{ \item{a}{vector of polynomial coefficients, normally in the z-domain} } \value{ Vector of stabilized polynomial coefficients. } \description{ Stabilize the polynomial transfer function by replacing all roots outside the unit circle with their reflection inside the unit circle. } \examples{ unstable <- c(-0.5, 1) zplane(unstable, 1) stable <- polystab(unstable) zplane(stable, 1) } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com} } gsignal/man/besself.Rd0000644000176200001440000000427214420222025014361 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/besself.R \name{besself} \alias{besself} \title{Bessel analog filter design} \usage{ besself(n, w, type = c("low", "high", "stop", "pass")) } \arguments{ \item{n}{filter order.} \item{w}{critical frequencies of the filter. \code{w} must be a scalar for low-pass and high-pass filters, and \code{w} must be a two-element vector c(low, high) specifying the lower and upper bands in radians/second.} \item{type}{filter type, one of \code{"low"} (default), \code{"high"}, \code{"stop"}, or \code{"pass"}.} } \value{ List of class \code{'\link{Zpg}'} containing poles and gain of the filter. } \description{ Compute the transfer function coefficients of an analog Bessel filter. } \details{ Bessel filters are characterized by an almost constant group delay across the entire passband, thus preserving the wave shape of filtered signals in the passband. Lowpass Bessel filters have a monotonically decreasing magnitude response, as do lowpass Butterworth filters. Compared to the Butterworth, Chebyshev, and elliptic filters, the Bessel filter has the slowest rolloff and requires the highest order to meet an attenuation specification. } \note{ As the important characteristic of a Bessel filter is its maximally-flat group delay, and not the amplitude response, it is inappropriate to use the bilinear transform to convert the analog Bessel filter into a digital form (since this preserves the amplitude response but not the group delay) [1]. } \examples{ w <- seq(0, 4, length.out = 128) ## 5th order Bessel low-pass analog filter zp <- besself(5, 1.0) freqs(zp, w) ## 5th order Bessel high-pass analog filter zp <- besself(5, 1.0, 'high') freqs(zp, w) ## 5th order Bessel band-pass analog filter zp <- besself(5, c(1, 2), 'pass') freqs(zp, w) ## 5th order Bessel band-stop analog filter zp <- besself(5, c(1, 2), 'stop') freqs(zp, w) } \references{ [1] \url{https://en.wikipedia.org/wiki/Bessel_filter} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net},\cr Doug Stewart, \email{dastew@sympatico.ca},\cr Thomas Sailer, \email{t.sailer@alumni.ethz.ch}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/sgolay.Rd0000644000176200001440000000562714420222025014241 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sgolay.R \name{sgolay} \alias{sgolay} \title{Savitzky-Golay filter design} \usage{ sgolay(p, n, m = 0, ts = 1) } \arguments{ \item{p}{Polynomial filter order; must be smaller than \code{n}.} \item{n}{Filter length; must a an odd positive integer.} \item{m}{Return the m-th derivative of the filter coefficients. Default: 0} \item{ts}{Scaling factor. Default: 1} } \value{ An square matrix with dimensions \code{length(n)} that is of class \code{"sgolayFilter"}, so it can be used with \code{filter}. } \description{ Compute the filter coefficients for all Savitzky-Golay FIR smoothing filters. } \details{ The early rows of the resulting filter smooth based on future values and later rows smooth based on past values, with the middle row using half future and half past. In particular, you can use row \code{i} to estimate \code{x(k)} based on the \code{i-1} preceding values and the \code{n-i} following values of \code{x} values as \code{y(k) = F[i, ] * x[(k - i + 1):(k + n -i)]}. Normally, you would apply the first \code{(n-1)/2} rows to the first \code{k} points of the vector, the last \code{k} rows to the last \code{k} points of the vector and middle row to the remainder, but for example if you were running on a real-time system where you wanted to smooth based on the all the data collected up to the current time, with a lag of five samples, you could apply just the filter on row \code{n - 5} to your window of length \code{n} each time you added a new sample. } \examples{ ## Generate a signal that consists of a 0.2 Hz sinusoid embedded ## in white Gaussian noise and sampled five times a second for 200 seconds. dt <- 1 / 5 t <- seq(0, 200 - dt, dt) x <- 5 * sin(2 * pi * 0.2 * t) + rnorm(length(t)) ## Use sgolay to smooth the signal. ## Use 21-sample frames and fourth order polynomials. p <- 4 n <- 21 sg <- sgolay(p, n) ## Compute the steady-state portion of the signal by convolving it ## with the center row of b. ycenter <- conv(x, sg[(n + 1)/2, ], 'valid') ## Compute the transients. Use the last rows of b for the startup ## and the first rows of b for the terminal. ybegin <- sg[seq(nrow(sg), (n + 3) / 2, -1), ] \%*\% x[seq(n, 1, -1)] yend <- sg[seq((n - 1)/2, 1, -1), ] \%*\% x[seq(length(x), (length(x) - (n - 1)), -1)] ## Concatenate the transients and the steady-state portion to ## generate the complete smoothed signal. ## Plot the original signal and the Savitzky-Golay estimate. y = c(ybegin, ycenter, yend) plot(t, x, type = "l", xlab = "", ylab = "", ylim = c(-8, 10)) lines(t, y, col = 2) legend("topright", c('Noisy Sinusoid','S-G smoothed sinusoid'), lty = 1, col = c(1,2)) } \seealso{ \code{\link{sgolayfilt}} } \author{ Paul Kienzle \email{pkienzle@users.sf.net},\cr Pascal Dupuis, \email{Pascal.Dupuis@esat.kuleuven.ac.be}.\cr Conversion to R Tom Short,\cr adapted by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/buttord.Rd0000644000176200001440000000476114420222025014424 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/buttord.R \name{buttord} \alias{buttord} \title{Butterworth filter order and cutoff frequency} \usage{ buttord(Wp, Ws, Rp, Rs, plane = c("z", "s")) } \arguments{ \item{Wp, Ws}{pass-band and stop-band edges. For a low-pass or high-pass filter, \code{Wp} and \code{Ws} are scalars. For a band-pass or band-rejection filter, both are vectors of length 2. For a low-pass filter, \code{Wp < Ws}. For a high-pass filter, \code{Ws > Wp}. For a band-pass \code{(Ws[1] < Wp[1] < Wp[2] < Ws[2])} or band-reject \code{(Wp[1] < Ws[1] < Ws[2] < Wp[2])} filter design, \code{Wp} gives the edges of the pass band, and \code{Ws} gives the edges of the stop band. For digital filters, frequencies are normalized to [0, 1], corresponding to the range [0, fs/2]. In case of an analog filter, all frequencies are specified in radians per second.} \item{Rp}{allowable decibels of ripple in the pass band.} \item{Rs}{minimum attenuation in the stop band in dB.} \item{plane}{"z" for a digital filter or "s" for an analog filter.} } \value{ A list of class \code{\link{FilterSpecs}} with the following list elements: \describe{ \item{n}{filter order} \item{Wc}{cutoff frequency} \item{type}{filter type, normally one of "low", "high", "stop", or "pass".} } } \description{ Compute the minimum filter order of a Butterworth filter with the desired response characteristics. } \details{ Deriving the order and cutoff is based on: \if{latex}{ \deqn{|H(W)|^{2} = 1/[1 + (W / Wc)^{(2N)}] = 10^{(-R / 10)}} } \if{html}{\preformatted{ 2 (2N) (-R / 10) |H(W)| = 1/[1 + (W / Wc) ] = 10 }} With some algebra, you can solve simultaneously for \code{Wc} and \code{N} given \code{Ws}, \code{Rs} and Wp,Rp. Rounding N to the next greater integer, one can recalculate the allowable range for \code{Wc} (filter characteristic touching the pass band edge or the stop band edge). For other types of filter, before making the above calculation, the requirements must be transformed to lowpass requirements. After the calculation, \code{Wc} must be transformed back to the original filter type. } \examples{ ## low-pass 30 Hz filter fs <- 128 butspec <- buttord(30/(fs/2), 40/(fs/2), 0.5, 40) but <- butter(butspec) freqz(but, fs = fs) } \seealso{ \code{\link{butter}}, \code{\link{FilterSpecs}} } \author{ Paul Kienzle,\cr adapted by Charles Praplan.\cr Conversion to R by Tom Short,\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/sosfilt.Rd0000644000176200001440000000573214420222025014423 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sosfilt.R \name{sosfilt} \alias{sosfilt} \title{Second-order sections filtering} \usage{ sosfilt(sos, x, zi = NULL) } \arguments{ \item{sos}{Second-order section representation, specified as an nrow-by-6 matrix, whose rows contain the numerator and denominator coefficients of the second-order sections:\cr \code{sos <- rbind(cbind(B1, A1), cbind(...), cbind(Bn, An))}, where \code{B1 <- c(b0, b1, b2)}, and \code{A1 <- c(a0, a1, a2)} for section 1, etc. The b0 entry must be nonzero for each section.} \item{x}{the input signal to be filtered, specified as a numeric or complex vector or matrix. If \code{x} is a matrix, each column is filtered.} \item{zi}{If \code{zi} is provided, it is taken as the initial state of the system and the final state is returned as zf. If \code{x} is a vector, \code{zi} must be a matrix with \code{nrow(sos)} rows and 2 columns. If \code{x} is a matrix, then \code{zi} must be a 3-dimensional array of size \code{(nrow(sos), 2, ncol(x))}. Alternatively, \code{zi} may be the character string \code{"zf"}, which specifies to return the final state vector even though the initial state vector is set to all zeros. Default: NULL.} } \value{ The filtered signal, of the same dimensions as the input signal. In case the \code{zi} input argument was specified, a list with two elements is returned containing the variables \code{y}, which represents the output signal, and \code{zf}, which contains the final state vector or matrix. } \description{ One-dimensional second-order (biquadratic) sections IIR digital filtering. } \details{ The filter function is implemented as a series of second-order filters with direct-form II transposed structure. It is designed to minimize numerical precision errors for high-order filters [1]. } \examples{ fs <- 1000 t <- seq(0, 1, 1/fs) s <- sin(2* pi * t * 6) x <- s + rnorm(length(t)) plot(t, x, type = "l", col="light gray") lines(t, s, col="black") sosg <- butter(3, 0.02, output = "Sos") sos <- sosg$sos sos[1, 1:3] <- sos[1, 1:3] * sosg$g y <- sosfilt(matrix(sos, ncol=6), x) lines(t, y, col="red") ## using 'filter' will handle the gain for you y2 <- filter(sosg, x) all.equal(y, y2) ## The following example is from Python scipy.signal.sosfilt ## It shows the instability that results from trying to do a ## 13th-order filter in a single stage (the numerical error ## pushes some poles outside of the unit circle) arma <- ellip(13, 0.009, 80, 0.05, output='Arma') sos <- ellip(13, 0.009, 80, 0.05, output='Sos') x <- rep(0, 700); x[1] <- 1 y_arma <- filter(arma, x) y_sos <- filter(sos, x) plot(y_arma, type ="l") lines (y_sos, col = 2) legend("topleft", legend = c("Arma", "Sos"), lty = 1, col = 1:2) } \references{ Smith III, J.O. (2012). Introduction to digital filters, with audio applications (3rd Ed.). W3K Publishing. } \seealso{ \code{\link{filter}}, \code{\link{filtfilt}}, \code{\link{Sos}} } \author{ Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/fracshift.Rd0000644000176200001440000000370414420222025014706 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fracshift.R \name{fracshift} \alias{fracshift} \title{Fractional shift} \usage{ fracshift(x, d, h = NULL) } \arguments{ \item{x}{input data, specified as a numeric vector.} \item{d}{number of samples to shift \code{x} by, specified as a numeric value} \item{h}{interpolator impulse response, specified as a numeric vector. If NULL (default), the interpolator is designed by a Kaiser-windowed sinecard.} } \value{ A list of matrices size \code{nr}, where \code{nr} is the number of rows in \code{x}. Each element of the list contains a matrix with two rows. The first row is the initial index of a sequence of 1s and the second row is the end index of that sequence. If \code{nr == 1} the output is a matrix with two rows. } \description{ Shift a signal by a (possibly fractional) number of samples. } \details{ The function calculates the initial index and end index of the sequences of 1’s in the rows of \code{x}. The clusters are sought in the rows of the array \code{x}. The function works by finding the indexes of jumps between consecutive values in the rows of \code{x}. } \examples{ N = 1024 t <- seq(0, 1, length.out = N) x <- exp(-t^2 / 2 / 0.25^2) * sin(2 * pi * 10 * t) dt <- 0.25 d <- dt / (t[2] - t[1]) y <- fracshift(x, d) plot(t, x, type = "l", xlab = "Time", ylab = "Sigfnal") lines (t, y, col = "red") legend("topright", legend = c("original", "shifted"), lty = 1, col = 1:2) } \references{ [1] A. V. Oppenheim, R. W. Schafer and J. R. Buck, Discrete-time signal processing, Signal processing series, Prentice-Hall, 1999.\cr [2] T.I. Laakso, V. Valimaki, M. Karjalainen and U.K. Laine Splitting the unit delay, IEEE Signal Processing Magazine, vol. 13, no. 1, pp 30--59 Jan 1996. } \author{ Eric Chassande-Mottin, \email{ecm@apc.univ-paris7.fr},\cr Juan Pablo Carbajal, \email{carbajal@ifi.uzh.ch},\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/boxcar.Rd0000644000176200001440000000174414420222025014215 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/boxcar.R \name{boxcar} \alias{boxcar} \title{Rectangular window} \usage{ boxcar(n) } \arguments{ \item{n}{Window length, specified as a positive integer.} } \value{ rectangular window, returned as a vector. } \description{ Return the filter coefficients of a boxcar (rectangular) window. } \details{ The rectangular window (sometimes known as the boxcar or Dirichlet window) is the simplest window, equivalent to replacing all but \code{n} values of a data sequence by zeros, making it appear as though the waveform suddenly turns on and off. Other windows are designed to moderate these sudden changes, which reduces scalloping loss and improves dynamic range. } \examples{ b <- boxcar(64) plot (b, type = "l", xlab = "Samples", ylab =" Amplitude") } \seealso{ \code{\link{triang}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/cheby2.Rd0000644000176200001440000000604414420222025014111 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cheby2.R \name{cheby2} \alias{cheby2} \alias{cheby2.FilterSpecs} \alias{cheby2.default} \title{Chebyshev Type II filter design} \usage{ cheby2(n, ...) \method{cheby2}{FilterSpecs}(n, ...) \method{cheby2}{default}( n, Rs, w, type = c("low", "high", "stop", "pass"), plane = c("z", "s"), output = c("Arma", "Zpg", "Sos"), ... ) } \arguments{ \item{n}{filter order.} \item{...}{additional arguments passed to cheby1, overriding those given by \code{n} of class \code{FilterSpecs}.} \item{Rs}{dB of stopband ripple.} \item{w}{critical frequencies of the filter. \code{w} must be a scalar for low-pass and high-pass filters, and \code{w} must be a two-element vector c(low, high) specifying the lower and upper bands in radians/second. For digital filters, W must be between 0 and 1 where 1 is the Nyquist frequency.} \item{type}{filter type, one of \code{"low"}, \code{"high"}, \code{"stop"}, or \code{"pass"}.} \item{plane}{"z" for a digital filter or "s" for an analog filter.} \item{output}{Type of output, one of: \describe{ \item{"Arma"}{Autoregressive-Moving average (aka numerator/denominator, aka b/a)} \item{"Zpg"}{Zero-pole-gain format} \item{"Sos"}{Second-order sections} } Default is \code{"Arma"} compatibility with the 'signal' package and the 'Matlab' and 'Octave' equivalents, but \code{"Sos"} should be preferred for general-purpose filtering because of numeric stability.} } \value{ Depending on the value of the \code{output} parameter, a list of class \code{\link{Arma}}, \code{\link{Zpg}}, or \code{\link{Sos}} containing the filter coefficients } \description{ Compute the transfer function coefficients of a Chebyshev Type II filter. } \details{ Chebyshev filters are analog or digital filters having a steeper roll-off than Butterworth filters, and have passband ripple (type I) or stopband ripple (type II). Because \code{cheby2} is generic, it can be extended to accept other inputs, using \code{cheb2ord} to generate filter criteria for example. } \examples{ ## compare the frequency responses of 5th-order ## Butterworth and Chebyshev filters. bf <- butter(5, 0.1) cf <- cheby2(5, 20, 0.1) bfr <- freqz(bf) cfr <- freqz(cf) plot(bfr$w / pi, 20 * log10(abs(bfr$h)), type = "l", ylim = c(-40, 0), xlim = c(0, .5), xlab = "Frequency", ylab = c("dB")) lines(cfr$w / pi, 20 * log10(abs(cfr$h)), col = "red") # compare type I and type II Chebyshev filters. c1fr <- freqz(cheby1(5, .5, 0.5)) c2fr <- freqz(cheby2(5, 20, 0.5)) plot(c1fr$w / pi, abs(c1fr$h), type = "l", ylim = c(0, 1.1), xlab = "Frequency", ylab = c("Magnitude")) lines(c2fr$w / pi, abs(c2fr$h), col = "red") } \references{ \url{https://en.wikipedia.org/wiki/Chebyshev_filter} } \seealso{ \code{\link{Arma}}, \code{\link{filter}}, \code{\link{butter}}, \code{\link{ellip}}, \code{\link{cheb2ord}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net},\cr Doug Stewart, \email{dastew@sympatico.ca}.\cr Conversion to R Tom Short,\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/firls.Rd0000644000176200001440000000251614661623627014100 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/firls.R \name{firls} \alias{firls} \title{Least-squares linear-phase FIR filter design} \usage{ firls(n, f, a, w = rep(1L, length(a)/2)) } \arguments{ \item{n}{filter order (1 less than the length of the filter). Must be even. If odd, it is incremented by one.} \item{f}{vector of frequency points in the range from 0 to 1, where 1 corresponds to the Nyquist frequency. Each band is specified by two frequencies, so the vector must have an even length. .} \item{a}{vector of the same length as \code{f} containing the desired amplitude at each of the points specified in \code{f}.} \item{w}{weighting function that contains one value for each band that weights the mean squared error in that band. \code{w} must be half the length of \code{f}.} } \value{ The FIR filter coefficients, a vector of length \code{n + 1}, of class \code{Ma}. } \description{ Produce a linear phase filter such that the integral of the weighted mean squared error in the specified bands is minimized. } \examples{ freqz(firls(255, c(0, 0.25, 0.3, 1), c(1, 1, 0, 0))) } \seealso{ \code{\link{Ma}}, \code{\link{filter}}, \code{\link{fftfilt}}, \code{\link{fir1}} } \author{ Quentin Spencer, \email{qspencer@ieee.org}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/decimate.Rd0000644000176200001440000000302314661623627014526 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/decimate.R \name{decimate} \alias{decimate} \title{Decrease sample rate} \usage{ decimate(x, q, ftype = c("iir", "fir"), n = ifelse(ftype == "iir", 8, 30)) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{q}{decimation factor, specified as a positive integer.} \item{ftype}{filter type; either \code{"fir"}, specifying a FIR filter of length \code{n} designed with the function \code{\link{fir1}}, or \code{"iir"} (default), specifying an IIR Chebyshev filter of order 8 using the function \code{\link{cheby1}}.} \item{n}{Order of the filter used prior to the downsampling, specified as a positive integer. Default: 8 if \code{ftype} equals \code{"iir"}; 30 of \code{ftype} equals \code{"fir"}.} } \value{ downsampled signal, returned as a vector or matrix. } \description{ Downsample a signal by an integer factor. } \examples{ t <- seq(0, 2, 0.01) x <- chirp(t, 2, .5, 10, 'quadratic') + sin(2 * pi * t * 0.4) w <- 1:121 plot(t[w] * 1000, x[w], type = "h", col = "green") points(t[w] * 1000, x[w], col = "green") y = decimate(x, 4) lines(t[seq(1, 121, 4)] * 1000, y[1:31], type = "h", col = "red") points(t[seq(1, 121, 4)] * 1000, y[1:31], col = "red") } \seealso{ \code{\link{cheby1}}, \code{\link{fir1}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/pow2db.Rd0000644000176200001440000000117614420222025014133 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/pow2db.R \name{pow2db} \alias{pow2db} \alias{db2pow} \title{Power - decibel conversion} \usage{ pow2db(x) db2pow(x) } \arguments{ \item{x}{input data, specified as a numeric vector, matrix, or multidimensional array. Must be non-negative for numeric \code{x}.} } \value{ Converted data, same type and dimensions as \code{x}. } \description{ Convert power to decibel and decibel to power. } \examples{ db <- pow2db(c(0, 10, 100)) pow <- db2pow(c(-10, 0, 10)) } \author{ P. Sudeepam\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/gsignal-package.Rd0000644000176200001440000000704214420222025015751 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gsignal.R \docType{package} \name{gsignal-package} \alias{gsignal} \alias{gsignal-package} \title{gsignal: Signal Processing} \description{ R implementation of the 'Octave' package 'signal', containing a variety of signal processing tools, such as signal generation and measurement, correlation and convolution, filtering, filter design, filter analysis and conversion, power spectrum analysis, system identification, decimation and sample rate change, and windowing. } \details{ The package 'gsignal' is an implementation in R of the 'Octave' package 'signal'. It provides signal processing algorithms for use with R, include the creation of waveforms, FIR and IIR filter design, spectral analysis, Fourier and other transforms, window functions, and resampling and rate changing. The 'Octave' package 'signal' release 1.4.1 (2019-02-08) was used to port the functions to R. Note that compatibility of function parameters and return values was not explicitly pursued. } \references{ \url{https://wiki.octave.org/Signal_package},\cr \url{https://octave.sourceforge.io/signal/} } \seealso{ Useful links: \itemize{ \item \url{https://github.com/gjmvanboxtel/gsignal} \item Report bugs at \url{https://github.com/gjmvanboxtel/gsignal/issues} } } \author{ \strong{Maintainer}: Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com} (Maintainer) Authors: \itemize{ \item Tom Short \email{tshort@eprisolutions.com} (Author of 'signal' package) \item Paul Kienzle (Majority of the original sources) } Other contributors: \itemize{ \item Ben Abbott [contributor] \item Juan Aguado [contributor] \item Muthiah Annamalai [contributor] \item Leonardo Araujo [contributor] \item William Asquith [contributor] \item David Bateman [contributor] \item David Billinghurst [contributor] \item Juan Pablo Carbajal [contributor] \item André Carezia [contributor] \item Vincent Cautaerts [contributor] \item Eric Chassande-Mottin [contributor] \item Luca Citi [contributor] \item Dave Cogdell [contributor] \item Carlo de Falco [contributor] \item Carne Draug [contributor] \item Pascal Dupuis [contributor] \item John W. Eaton [contributor] \item R.G.H Eschauzier [contributor] \item Andrew Fitting [contributor] \item Alan J. Greenberger [contributor] \item Mike Gross [contributor] \item Daniel Gunyan [contributor] \item Kai Habel [contributor] \item Kurt Hornik [contributor] \item Jake Janovetz [contributor] \item Alexander Klein [contributor] \item Peter V. Lanspeary [contributor] \item Bill Lash [contributor] \item Friedrich Leissh [contributor] \item Laurent S. Mazet [contributor] \item Mike Miller [contributor] \item Petr Mikulik [contributor] \item Paolo Neis [contributor] \item Georgios Ouzounis [contributor] \item Sylvain Pelissier [contributor] \item Francesco Potortì [contributor] \item Charles Praplan [contributor] \item Lukas F. Reichlin [contributor] \item Tony Richardson [contributor] \item Asbjorn Sabo [contributor] \item Thomas Sailer [contributor] \item Rolf Schirmacher [contributor] \item Rolf Schirmacher [contributor] \item Ivan Selesnick [contributor] \item Julius O. Smith III [contributor] \item Peter L. Soendergaard [contributor] \item Quentin Spencer [contributor] \item Doug Stewart [contributor] \item P. Sudeepam [contributor] \item Stefan van der Walt [contributor] \item Andreas Weber [contributor] \item P. Sudeepam [contributor] \item Andreas Weingessel [contributor] } } \keyword{internal} gsignal/man/conv2.Rd0000644000176200001440000000221214420222025013755 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/conv2.R \name{conv2} \alias{conv2} \title{2-D convolution} \usage{ conv2(a, b, shape = c("full", "same", "valid")) } \arguments{ \item{a, b}{Input matrices, coerced to numeric.} \item{shape}{Subsection of convolution, partially matched to: \describe{ \item{"full"}{Return the full convolution (default)} \item{"same"}{Return the central part of the convolution with the same size as A. The central part of the convolution begins at the indices \code{floor(c(nrow(b), ncol(b)) / 2 + 1)}} \item{"valid"}{Return only the parts which do not include zero-padded edges. The size of the result is \code{max(nrow(a) - nrow(a) + 1, 0)} by \code{max(ncol(A) - ncol(B) + 1, 0)}} }} } \value{ Convolution of input matrices, returned as a matrix. } \description{ Compute the two-dimensional convolution of two matrices. } \examples{ a <- matrix(1:16, 4, 4) b <- matrix(1:9, 3,3) cnv <- conv2(a, b) cnv <- conv2(a, b, "same") cnv <- conv2(a, b, "valid") } \seealso{ \code{\link{conv}}, \code{\link[stats]{convolve}} } \author{ Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/bitrevorder.Rd0000644000176200001440000000252614420222025015265 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bitrevorder.R \name{bitrevorder} \alias{bitrevorder} \title{Permute input to bit-reversed order} \usage{ bitrevorder(x, index.return = FALSE) } \arguments{ \item{x}{input data, specified as a vector. The length of \code{x} must be an integer power of 2.} \item{index.return}{logical indicating if the ordering index vector should be returned as well. Default: \code{FALSE}.} } \value{ The bit-reversed input vector. If \code{index.return = TRUE}, then a list containing the bit-reversed input vector (\code{y}), and the digit-reversed indices (\code{i}). } \description{ Reorder the elements of the input vector in bit-reversed order. } \details{ This function is equivalent to calling \code{digitrevorder(x, 2)}, and is useful for prearranging filter coefficients so that bit-reversed ordering does not have to be performed as part of an fft or ifft computation. } \examples{ x <- 0:15 v <- bitrevorder(x) dec2bin <- function(x, l) substr(paste(as.integer(rev(intToBits(x))), collapse = ""), 32 - l + 1, 32) x_bin <- sapply(x, dec2bin, 4) v_bin <- sapply(v, dec2bin, 4) data.frame(x, x_bin, v, v_bin) } \seealso{ \code{\link{digitrevorder}}, \code{\link{fft}}, \code{\link{ifft}} } \author{ Mike Miller.\cr Port to to by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/blackmanharris.Rd0000644000176200001440000000301714420222025015713 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/blackmanharris.R \name{blackmanharris} \alias{blackmanharris} \title{Blackman-Harris window} \usage{ blackmanharris(n, method = c("symmetric", "periodic")) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{method}{Character string. Window sampling method, specified as: \describe{ \item{"symmetric" (Default)}{Use this option when using windows for filter design.} \item{"periodic"}{This option is useful for spectral analysis because it enables a windowed signal to have the perfect periodic extension implicit in the discrete Fourier transform. When "periodic" is specified, the function computes a window of length \code{n + 1} and returns the first \code{n} points.} }} } \value{ Blackman-Harris window, returned as a vector. } \description{ Return the filter coefficients of a minimum four-term Blackman-Harris window. } \details{ The Blackman window is a member of the family of cosine sum windows. It is a generalization of the Hamming family, produced by adding more shifted sinc functions, meant to minimize side-lobe levels. } \examples{ b <- blackmanharris(64) plot (b, type = "l", xlab = "Samples", ylab =" Amplitude") bs = blackmanharris(64,'symmetric') bp = blackmanharris(63,'periodic') plot (bs, type = "l", xlab = "Samples", ylab =" Amplitude") lines(bp, col="red") } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/zerocrossing.Rd0000644000176200001440000000131514420222025015460 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/zerocrossing.R \name{zerocrossing} \alias{zerocrossing} \title{Zero Crossing} \usage{ zerocrossing(x, y) } \arguments{ \item{x}{the x-coordinates of points in the function.} \item{y}{the y-coordinates of points in the function.} } \value{ Zero-crossing points } \description{ Estimate zero crossing points of waveform. } \examples{ x <- seq(0, 1, length.out = 100) y <- runif(100) - 0.5 x0 <- zerocrossing(x, y) plot(x, y, type ="l", xlab = "", ylab = "") points(x0, rep(0, length(x0)), col = "red") } \author{ Carlo de Falco, \email{carlo.defalco@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/sigmoid_train.Rd0000644000176200001440000000536714420222025015574 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sigmoid_train.R \name{sigmoid_train} \alias{sigmoid_train} \title{Sigmoid Train} \usage{ sigmoid_train(t, ranges, rc) } \arguments{ \item{t}{Vector (or coerced to a vector) of time values at which the sigmoids are calculated.} \item{ranges}{Matrix or array with 2 columns containing the time values within \code{t} at which each sigmoid is evaluated. The number of sigmoids is determined by the number of rows in \code{ranges}.} \item{rc}{Time constant. Either a scalar or a matrix or array with 2 columns containing the rising and falling time constants of each sigmoid. If a matrix or array is passed in \code{rc}, its size must equal the size of \code{ranges}. If a single scalar is passed in \code{rc}, then all sigmoids have the same time constant and are symmetrical.} } \value{ A list consisting two variables; \code{y} the combined sigmoid train (length identical to \code{t}), and \code{s}, the individual sigmoids (number of rows equal to number of rows in \code{ranges} and \code{rc}. } \description{ Evaluate a train of sigmoid functions at \code{t}. } \details{ The number and duration of each sigmoid is determined from ranges. Each row of \code{ranges} represents a real interval, e.g. if sigmoid \code{i} starts at \code{t = 0.1} and ends at \code{t = 0.5}, then \code{ranges[i, ] = c(0.1, 0.5)}. The input \code{rc} is an array that defines the rising and falling time constants of each sigmoid. Its size must equal the size of ranges. The individual sigmoids are returned in \code{s}. The combined sigmoid train is returned in the vector \code{y} of length equal to \code{t}, and such that \code{y = max(s)}. } \examples{ t <- seq(0, 2, length.out = 500) ranges <- rbind(c(0.1, 0.4), c(0.6, 0.8), c(1, 2)) rc <- rbind(c(1e-2, 1e-3), c(1e-3, 2e-2), c(2e-2, 1e-2)) st <- sigmoid_train (t, ranges, rc) plot(t, st$y[1,], type="n", xlab = "Time(s)", ylab = "S(t)", main = "Vectorized use of sigmoid train") for (i in 1:3) rect(ranges[i, 1], 0, ranges[i, 2], 1, border = NA, col="pink") for (i in 1:3) lines(t, st$y[i,]) # The colored regions show the limits defined in range. t <- seq(0, 2, length.out = 500) ranges <- rbind(c(0.1, 0.4), c(0.6, 0.8), c(1, 2)) rc <- rbind(c(1e-2, 1e-3), c(1e-3, 2e-2), c(2e-2, 1e-2)) amp <- c(4, 2, 3) st <- sigmoid_train (t, ranges, rc) y <- amp \%*\% st$y plot(t, y[1,], type="l", xlab = 'time', ylab = 'signal', main = 'Varying amplitude sigmoid train', col="blue") lines(t, st$s, col = "orange") legend("topright", legend = c("Sigmoid train", "Components"), lty = 1, col = c("blue", "orange")) } \author{ Juan Pablo Carbajal, \email{carbajal@ifi.uzh.ch}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/dftmtx.Rd0000644000176200001440000000227214420222025014242 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/dftmtx.R \name{dftmtx} \alias{dftmtx} \title{Discrete Fourier Transform Matrix} \usage{ dftmtx(n) } \arguments{ \item{n}{Size of Fourier transformation matrix, specified as a positive integer.} } \value{ Fourier transform matrix. } \description{ Compute the discrete Fourier transform matrix } \details{ A discrete Fourier transform matrix is a complex matrix whose matrix product with a vector computes the discrete Fourier transform of the vector. \code{dftmtx} takes the FFT of the identity matrix to generate the transform matrix. For a column vector \code{x}, \code{y <- dftmtx(n) * x} is the same as \code{y <- fft(x, postpad(x, n)}. The inverse discrete Fourier transform matrix is \code{inv <- Conj(dftmtx(n)) / n}. In general this is less efficient than calling the \code{fft} and \code{ifft} functions directly. } \examples{ x <- seq_len(256) y1 <- stats::fft(x) n <- length(x) y2 <- drop(x \%*\% dftmtx(n)) mx <- max(abs(y1 - y2)) } \seealso{ \code{\link[stats]{fft}}, \code{\link{ifft}} } \author{ David Bateman, \email{adb014@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/gmonopuls.Rd0000644000176200001440000000205214420222025014753 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gmonopuls.R \name{gmonopuls} \alias{gmonopuls} \title{Gaussian monopulse} \usage{ gmonopuls(t, fc = 1000) } \arguments{ \item{t}{Vector of time values at which the unit-amplitude Gaussian monopulse is calculated.} \item{fc}{Center frequency of the Gaussian monopulses, specified as a real positive scalar expressed in Hz. Default: 1000} } \value{ Samples of the Gaussian monopulse, returned as a vector of unit amplitude at the times indicated by the time vector \code{t}. } \description{ Returns samples of the unit-amplitude Gaussian monopulse. } \examples{ fs <- 11025 # arbitrary sample rate t <- seq(-10, 10, 1/fs) y1 <- gmonopuls(t, 0.1) y2 <- gmonopuls(t, 0.2) plot(t, y1, type="l", xlab = "Time", ylab = "Amplitude") lines(t, y2, col = "red") legend("topright", legend = c("fc = 0.1", "fc = 0.2"), lty = 1, col = c(1, 2)) } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/fftfilt.Rd0000644000176200001440000000742214420222025014374 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fftfilt.R \name{fftfilt} \alias{fftfilt} \alias{fftfilt.default} \alias{fftfilt.Ma} \title{FFT-based FIR filtering} \usage{ fftfilt(b, x, n = NULL) \method{fftfilt}{default}(b, x, n = NULL) \method{fftfilt}{Ma}(b, x, n = NULL) } \arguments{ \item{b}{moving average (Ma) coefficients of a FIR filter, specified as a vector.} \item{x}{the input signal to be filtered. If x is a matrix, its columns are filtered.} \item{n}{FFT length, specified as a positive integer. The FFT size must be an even power of 2 and must be greater than or equal to the length of \code{filt}. If the specified \code{n} does not meet these criteria, it is automatically adjusted to the nearest value that does. If \code{n = NULL} (default), then the overlap-add method is not used.} } \value{ The filtered signal, returned as a vector or matrix with the same dimensions as \code{x}. } \description{ FFT-based FIR filtering using the overlap-add method. } \details{ This function combines two important techniques to speed up filtering of long signals, the overlap-add method, and FFT convolution. The overlap-add method is used to break long signals into smaller segments for easier processing or preventing memory problems. FFT convolution uses the overlap-add method together with the Fast Fourier Transform, allowing signals to be convolved by multiplying their frequency spectra. For filter kernels longer than about 64 points, FFT convolution is faster than standard convolution, while producing exactly the same result. The overlap-add technique works as follows. When an \code{N} length signal is convolved with a filter kernel of length \code{M}, the output signal is \code{N + M - 1} samples long, i.e., the signal is expanded 'to the right'. The signal is then broken into \code{k} smaller segments, and the convolution of each segment with the f kernel will have a result of length \code{N / k + M -1}. The individual segments are then added together. The rightmost \code{M - 1} samples overlap with the leftmost \code{M - 1} samples of the next segment. The overlap-add method produces exactly the same output signal as direct convolution. FFT convolution uses the principle that multiplication in the frequency domain corresponds to convolution in the time domain. The input signal is transformed into the frequency domain using the FFT, multiplied by the frequency response of the filter, and then transformed back into the time domain using the inverse FFT. With FFT convolution, the filter kernel can be made very long, with very little penalty in execution time. } \examples{ t <- seq(0, 1, len = 10000) # 1 second sample x <- sin(2* pi * t * 2.3) + 0.25 * rnorm(length(t)) # 2.3 Hz sinusoid+noise filt <- rep(0.1, 10) # filter kernel y1 <- filter(filt, 1, x) # use normal convolution y2 <- fftfilt(filt, x) # FFT convolution plot(t, x, type = "l") lines(t, y1, col = "red") lines(t, y2, col = "blue") ## use 'filter' with different classes t <- seq(0, 1, len = 10000) # 1 second sample x <- sin(2* pi * t * 2.3) + 0.25 * rnorm(length(t)) # 2.3 Hz sinusoid+noise ma <- Ma(rep(0.1, 10)) # filter kernel y1 <- filter(ma, x) # convulution filter y2 <- fftfilt(ma, x) # FFT filter all.equal(y1, y2) # same result } \references{ \url{https://en.wikipedia.org/wiki/Overlap-add_method}. } \seealso{ \code{\link{filter}} } \author{ Kurt Hornik, \email{Kurt.Hornik@wu-wien.ac.at},\cr adapted by John W. Eaton.\cr Conversion to R by Tom Short,\cr adapted by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/wkeep.Rd0000644000176200001440000000311214420222025014041 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/wkeep.R \name{wkeep} \alias{wkeep} \title{Keep part of vector or matrix} \usage{ wkeep(x, l, opt = "centered") } \arguments{ \item{x}{input data, specified as a numeric vector or matrix.} \item{l}{either a positive integer value, specifying the length to extract from the input *vector* \code{x}, or a vector of length 2, indicating the submatrix to extract from the *matrix* \code{x}. See the examples.} \item{opt}{One of: \describe{ \item{character string}{matched against \code{c("centered", "left", "right")}, indicating the location of the *vector* \code{x} to extract} \item{positive integer}{starting index of the input *vector* \code{x}} \item{two-element vector}{starting row and columns from the *matrix* \code{x}} } See the examples. Default: "centered".} } \value{ extracted vector or matrix } \description{ Extract elements from a vector or matrix. } \examples{ ## create a vector x <- 1:10 ## Extract a vector of length 6 from the central part of x. y <- wkeep(x, 6, 'c') ## Extract two vectors of length 6, one from the left part of x, and the ## other from the right part of x. y <- wkeep(x, 6, 'l') y <- wkeep(x, 6, 'r') ## Create a 5-by-5 matrix. x <- matrix(round(runif(25, 0, 25)), 5, 5) ## Extract a 3-by-2 matrix from the center of x y <- wkeep(x, c(3, 2)) ## Extract from x the 2-by-4 submatrix starting at x[3, 1]. y <- wkeep(x, c(2, 4), c(3, 1)) } \author{ Sylvain Pelissier, \email{sylvain.pelissier@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/chebwin.Rd0000644000176200001440000000274314420222025014356 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/chebwin.R \name{chebwin} \alias{chebwin} \title{Chebyshev window} \usage{ chebwin(n, at = 100) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{at}{Stop-band attenuation in dB. Default: 100.} } \value{ Chebyshev window, returned as a vector. If you specify a one-point window \code{(n = 1)}, the value 1 is returned. } \description{ Return the filter coefficients of a Dolph-Chebyshev window. } \details{ The window is described in frequency domain by the expression: \if{latex}{ \deqn{W(k) = \frac{Cheb(m - 1, \beta \cdot cos(\pi \cdot k / m))}{Cheb(m - 1, \beta)}} } \if{html}{\preformatted{ Cheb(m - 1, Beta * cos(\pi * k / m)) W(k) = ------------------------------------ Cheb(m - 1, Beta) }} with \if{latex}{ \deqn{\beta = cosh(1 / (m - 1) \cdot acosh(10^{(at / 20)})} } \if{html}{\preformatted{ Beta = cosh(1 / (m - 1) * acosh(10^(at / 20)) }} and and \eqn{Cheb(m, x)} denoting the \eqn{m}-th order Chebyshev polynomial calculated at the point \eqn{x}. Note that the denominator in W(k) above is not computed, and after the inverse Fourier transform the window is scaled by making its maximum value unitary. } \examples{ cw <- chebwin(64) plot (cw, type = "l", xlab = "Samples", ylab =" Amplitude") } \author{ André Carezia, \email{acarezia@uol.com.br}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/idct2.Rd0000644000176200001440000000242714420222025013743 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/idct2.R \name{idct2} \alias{idct2} \title{Inverse 2-D Discrete Cosine Transform} \usage{ idct2(x, m = NROW(x), n = NCOL(x)) } \arguments{ \item{x}{2-D numeric matrix} \item{m}{Number of rows, specified as a positive integer. \code{dct2} pads or truncates \code{x} so that it has \code{m} rows. Default: \code{NROW(x)}.} \item{n}{Number of columns, specified as a positive integer. \code{dct2} pads or truncates \code{x} so that it has \code{n} columns. Default: \code{NCOL(x)}.} } \value{ \code{m}-by-\code{n} numeric discrete cosine transformed matrix. } \description{ Compute the inverse two-dimensional discrete cosine transform of a matrix. } \details{ The discrete cosine transform (DCT) is closely related to the discrete Fourier transform. It is a separable linear transformation; that is, the two-dimensional transform is equivalent to a one-dimensional DCT performed along a single dimension followed by a one-dimensional DCT in the other dimension. } \examples{ A <- matrix(50 * runif(100), 10, 10) B <- dct2(A) B[which(B < 1)] <- 0 AA <- idct2(B) } \seealso{ \code{\link{dct2}} } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/xcorr2.Rd0000644000176200001440000000360514420222025014154 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/xcorr2.R \name{xcorr2} \alias{xcorr2} \title{2-D cross-correlation} \usage{ xcorr2(a, b = a, scale = c("none", "biased", "unbiased", "coeff")) } \arguments{ \item{a}{Input matrix, coerced to numeric. Must not be missing.} \item{b}{Input matrix, coerced to numeric. Default: \code{a}.} \item{scale}{Character string. Specifies the type of scaling applied to the correlation matrix. matched to one of: \describe{ \item{"none"}{no scaling} \item{"biased"}{Scales the raw cross-correlation by the maximum number of elements of \code{a} and \code{b} involved in the generation of any element of the output matrix.} \item{"unbiased"}{Scales the raw correlation by dividing each element in the cross-correlation matrix by the number of products \code{a} and \code{b} used to generate that element. } \item{"coeff"}{Scales the normalized cross-correlation on the range of [0 1] so that a value of 1 corresponds to a correlation coefficient of 1. } }} } \value{ 2-D cross-correlation or autocorrelation matrix, returned as a matrix } \description{ Compute the 2D cross-correlation of matrices \code{a} and \code{b}. } \details{ If \code{b} is not specified, computes autocorrelation of \code{a}, i.e., same as \code{xcorr2 (a, a)}. } \examples{ m1 <- matrix(c(17, 24, 1, 8, 15, 23, 5, 7, 14, 16, 4, 6, 13, 20, 22, 10, 12, 19, 21, 3, 11, 18, 25, 2, 9), 5, 5, byrow = TRUE) m2 <- matrix(c(8, 1, 6, 3, 5, 7, 4, 9, 2), 3, 3, byrow = TRUE) R <- xcorr2(m1, m2) } \seealso{ \code{\link{conv2}}, \code{\link{xcorr}}. } \author{ Dave Cogdell, \email{cogdelld@asme.org},\cr Paul Kienzle, \email{pkienzle@users.sf.net},\cr Carne Draug, \email{carandraug+dev@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/gausswin.Rd0000644000176200001440000000227614420222025014600 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/gausswin.R \name{gausswin} \alias{gausswin} \title{Gaussian window} \usage{ gausswin(n, a = 2.5) } \arguments{ \item{n}{Window length, specified as a positive integer.} \item{a}{Width factor, specified as a positive real scalar. \code{a} is inversely proportional to the width of the window. Default: 2.5.} } \value{ Gaussian convolution window, returned as a vector. } \description{ Return the filter coefficients of a Gaussian window of length \code{n}. } \details{ The width of the window is inversely proportional to the parameter \code{a}. Use larger \code{a} for a narrower window. Use larger \code{m} for a smoother curve. \deqn{w = e^{(-(a*x)^{2}/2 )}} for \code{x <- seq(-(n - 1) / n, (n - 1) / n, by = n)}. The exact correspondence with the standard deviation of a Gaussian probability density function is \eqn{\sigma = (n - 1) / (2a)}. } \examples{ g1 <- gausswin(64) g2 <- gausswin(64, 5) plot (g1, type = "l", xlab = "Samples", ylab =" Amplitude", ylim = c(0, 1)) lines(g2, col = "red") } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Geert van Boxtel \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/cplxreal.Rd0000644000176200001440000000302714420222025014545 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cplxreal.R \name{cplxreal} \alias{cplxreal} \title{Sort complex conjugate pairs and real} \usage{ cplxreal(z, tol = 100 * .Machine$double.eps, MARGIN = 2) } \arguments{ \item{z}{Vector, matrix, or array of complex numbers.} \item{tol}{Weighting factor \code{0 < tol < 1}, which determines the tolerance of matching. Default: \code{100 * .Machine$double.eps}.} \item{MARGIN}{Vector giving the subscripts which the function will be applied over. E.g., for a matrix 1 indicates rows, 2 indicates columns, c(1, 2) indicates rows and columns. Where X has named dimnames, it can be a character vector selecting dimension names. Default: 2 (columns).} } \value{ A list containing two variables: \describe{ \item{zc}{Vector, matrix or array containing ordered complex conjugate pairs by increasing real parts. Only the positive imaginary complex numbers of each complex conjugate pair are returned.} \item{zr}{Vector, matrix or array containing ordered real numbers.} } } \description{ Sort numbers into into complex-conjugate-valued and real-valued elements. } \details{ An error is signaled if some complex numbers could not be paired and if all complex numbers are not exact conjugates (to within tol). Note that here is no defined order for pairs with identical real parts but differing imaginary parts. } \examples{ r <- cplxreal(c(1, 1 + 3i, 2 - 5i, 1-3i, 2 + 5i, 4, 3)) } \seealso{ \code{\link{cplxpair}} } \author{ Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/impz.Rd0000644000176200001440000000417314420222025013715 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/impz.R \name{impz} \alias{impz} \alias{print.impz} \alias{impz.Arma} \alias{impz.Ma} \alias{impz.Sos} \alias{impz.Zpg} \alias{impz.default} \title{Impulse response of digital filter} \usage{ impz(filt, ...) \method{print}{impz}(x, ...) \method{impz}{Arma}(filt, ...) \method{impz}{Ma}(filt, ...) \method{impz}{Sos}(filt, ...) \method{impz}{Zpg}(filt, ...) \method{impz}{default}(filt, a = 1, n = NULL, fs = 1, ...) } \arguments{ \item{filt}{for the default case, the moving-average coefficients of an ARMA model or filter. Generically, \code{filt} specifies an arbitrary model or filter operation.} \item{...}{for methods of \code{freqz}, arguments are passed to the default method. For \code{plot.impz}, additional arguments are passed through to plot.} \item{x}{object to be printed or plotted.} \item{a}{the autoregressive (recursive) coefficients of an ARMA filter.} \item{n}{number of points at which to evaluate the frequency response. If \code{n} is a vector with a length greater than 1, then evaluate the frequency response at these points. For fastest computation, \code{n} should factor into a small number of small primes. Default: 512.} \item{fs}{sampling frequency in Hz. If not specified (default = 2 * pi), the frequencies are in radians.} } \value{ For \code{impz}, a list of class \code{"impz"} with items: \describe{ \item{x}{impulse response signal.} \item{t}{time.} } } \description{ Compute the z-plane impulse response of an ARMA model or rational IIR filter. A plot of the impulse and step responses is generated. } \note{ When results of \code{impz} are printed, \code{plot} will be called to display a plot of the impulse response against frequency. As with lattice plots, automatic printing does not work inside loops and function calls, so explicit calls to print or plot are needed there. } \examples{ ## elliptic low-pass filter elp <- ellip(4, 0.5, 20, 0.4) impz(elp) xt <- impz(elp) } \author{ Paul Kienzle, \email{pkienzle@users.sf.net}.\cr Conversion to R by Tom Short;\cr adapted by Geert van Boxtel, \email{gjmvanboxtel@gmail.com} } gsignal/man/bartlett.Rd0000644000176200001440000000172014420222025014552 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/bartlett.R \name{bartlett} \alias{bartlett} \title{Bartlett window} \usage{ bartlett(n) } \arguments{ \item{n}{Window length, specified as a positive integer.} } \value{ Bartlett window, returned as a vector. If you specify a one-point window \code{(n = 1)}, the value 1 is returned. } \description{ Return the filter coefficients of a Bartlett (triangular) window. } \details{ The Bartlett window is very similar to a triangular window as returned by the \code{\link{triang}} function. However, the Bartlett window always has zeros at the first and last samples, while the triangular window is nonzero at those points. } \examples{ bw <- bartlett(64) plot (bw, type = "l", xlab = "Samples", ylab =" Amplitude") } \seealso{ \code{\link{triang}} } \author{ Andreas Weingessel, \email{Andreas.Weingessel@ci.tuwien.ac.at}. Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/fftshift.Rd0000644000176200001440000000411714420222025014551 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fftshift.R \name{fftshift} \alias{fftshift} \title{Zero-frequency shift} \usage{ fftshift(x, MARGIN = 2) } \arguments{ \item{x}{input data, specified as a vector or matrix.} \item{MARGIN}{dimension to operate along, 1 = row, 2 = columns (default). Specifying \code{MARGIN = c(1, 2)} centers along both rows and columns. Ignored when \code{x} is a vector.} } \value{ vector or matrix with centered frequency. } \description{ Perform a shift in order to move the frequency 0 to the center of the input. } \details{ If \code{x} is a vector of \code{N} elements corresponding to \code{N} time samples spaced by \code{dt}, then \code{fftshift(x)} corresponds to frequencies \code{f = c(-seq(ceiling((N-1)/2), 1, -1), 0, (1:floor((N-1)/2))) * df}, where \code{df = 1 / (N * dt)}. In other words, the left and right halves of \code{x} are swapped. If \code{x} is a matrix, then \code{fftshift} operates on the rows or columns of \code{x}, according to the \code{MARGIN} argument, i.e. it swaps the the upper and lower halves of the matrix \code{(MARGIN = 1)}, or the left and right halves of the matrix \code{(MARGIN = 2)}. Specifying \code{MARGIN = c(1, 2)} swaps along both dimensions, i.e., swaps the first quadrant with the fourth, and the second with the third. } \examples{ Xeven <- 1:6 ev <- fftshift(Xeven) # returns 4 5 6 1 2 3 Xodd <- 1:7 odd <- fftshift(Xodd) # returns 5 6 7 1 2 3 4 fs <- 100 # sampling frequency t <- seq(0, 10 - 1/fs, 1/fs) # time vector S <- cos(2 * pi * 15 * t) n <- length(S) X <- fft(S) f <- (0:(n - 1)) * (fs / n); # frequency range power <- abs(X)^2 / n # power plot(f, power, type="l") Y <- fftshift(X) fsh <- ((-n/2):(n/2-1)) * (fs / n) # zero-centered frequency range powersh <- abs(Y)^2 / n # zero-centered power plot(fsh, powersh, type = "l") } \seealso{ \code{ifftshift} } \author{ Vincent Cautaerts, \email{vincent@comf5.comm.eng.osaka-u.ac.jp},\cr adapted by John W. Eaton.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/fht.Rd0000644000176200001440000000371314420222025013516 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/fht.R \name{fht} \alias{fht} \alias{ifht} \title{Fast Hartley Transform} \usage{ fht(x, n = NROW(x)) ifht(x, n = NROW(x)) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{n}{transform length, specified as a positive integer scalar. Default: \code{NROW(x)}.} } \value{ (inverse) Hartley transform, returned as a vector or matrix. } \description{ Compute the (inverse) Hartley transform of a signal using FFT } \details{ The Hartley transform is an integral transform closely related to the Fourier transform, but which transforms real-valued functions to real-valued functions. Compared to the Fourier transform, the Hartley transform has the advantages of transforming real functions to real functions (as opposed to requiring complex numbers) and of being its own inverse [1]. This function implements the Hartley transform by calculating the difference between the real- and imaginary-valued parts of the Fourier-transformed signal [1]. The forward and inverse Hartley transforms are the same (except for a scale factor of 1/N for the inverse Hartley transform), but implemented using different functions. } \examples{ # FHT of a 2.5 Hz signal with offset fs <- 100 secs <- 10 freq <- 2.5 t <- seq(0, secs - 1 / fs, 1 / fs) x <- 5 * t + 50 * cos(freq * 2 * pi * t) X <- fht(x) op <- par(mfrow = c(2, 1)) plot(t, x, type = "l", xlab = "", ylab = "", main = "Signal") f <- seq(0, fs - (1 / fs), length.out = length(t)) to <- which(f >= 5)[1] plot(f[1:to], X[1:to], type = "l", xlab = "", ylab = "", main = "Hartley Transform") par(op) } \references{ [1] \url{https://en.wikipedia.org/wiki/Hartley_transform} } \seealso{ \code{\link{fft}} } \author{ Muthiah Annamalai, \email{muthiah.annamalai@uta.edu}.\ Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/mpoles.Rd0000644000176200001440000000230614420222025014231 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mpoles.R \name{mpoles} \alias{mpoles} \title{Multiplicity of poles} \usage{ mpoles(p, tol = 0.001, reorder = TRUE, index.return = FALSE) } \arguments{ \item{p}{vector of poles.} \item{tol}{tolerance. If the relative difference of two poles is less than \code{tol} then they are considered to be multiples. The default value for \code{tol} is 0.001.} \item{reorder}{logical. If \code{TRUE}, (default), the output is ordered from largest pole to smallest pole.} \item{index.return}{logical indicating if index vector should be returned as well. See examples. Default: \code{FALSE}.} } \value{ If \code{index.return = TRUE}, a list consisting of two vectors: \describe{ \item{m}{vector specifying the multiplicity of the poles} \item{n}{index} } If \code{index.return = FALSE}, only \code{m} is returned (as a vector). } \description{ Identify unique poles and their associated multiplicity. } \examples{ p <- c(2, 3, 1, 1, 2) ret <- mpoles(p, index = TRUE) } \seealso{ \code{\link{poly}}, \code{\link{residue}} } \author{ Ben Abbott, \email{bpabbott@mac.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com} } gsignal/man/upfirdn.Rd0000644000176200001440000000401414420222025014377 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/upfirdn.R \name{upfirdn} \alias{upfirdn} \title{Upsample, apply FIR filter, downsample} \usage{ upfirdn(x, h, p = 1, q = 1) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{h}{Impulse response of the FIR filter specified as a numeric vector or matrix. If it is a vector, then it represents one FIR filter to may be applied to multiple signals in \code{x}; if it is a matrix, then each column is a separate FIR impulse response.} \item{p}{Upsampling factor, specified as a positive integer (default: 1).} \item{q}{downsampling factor, specified as a positive integer (default: 1).} } \value{ output signal, returned as a vector or matrix. Each column has length \code{ceiling(((length(x) - 1) * p + length(h)) / q)}. } \description{ Filter and resample a signal using polyphase interpolation. } \details{ upfirdn performs a cascade of three operations: \enumerate{ \item Upsample the input data in the matrix \code{x} by a factor of the integer \code{p} (inserting zeros) \item FIR filter the upsampled signal data with the impulse response sequence given in the vector or matrix \code{h} \item Downsample the result by a factor of the integer \code{q} (throwing away samples) } The FIR filter is usually a lowpass filter, which you must design using another function such as \code{fir1}. } \note{ This function uses a polyphase implementation, which is generally faster than using \code{filter} by a factor equal to the downsampling factor, since it only calculates the needed outputs. } \examples{ x <- c(1, 1, 1) h <- c(1, 1) ## FIR filter y <- upfirdn(x, h) ## FIR filter + upsampling y <- upfirdn(x, h, 5) ## FIR filter + downsampling y <- upfirdn(x, h, 1, 2) ## FIR filter + up/downsampling y <- upfirdn(x, h, 5, 2) } \seealso{ \code{\link{fir1}} } \author{ Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/cheb1ap.Rd0000644000176200001440000000154014420222025014234 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cheb1ap.R \name{cheb1ap} \alias{cheb1ap} \title{Chebyshev Type I filter prototype} \usage{ cheb1ap(n, Rp) } \arguments{ \item{n}{Order of the filter.} \item{Rp}{dB of pass-band ripple.} } \value{ List of class \code{\link{Zpg}} containing the poles and gain of the filter. } \description{ Return the poles and gain of an analog Chebyshev Type I lowpass filter prototype. } \details{ This function exists for compatibility with 'Matlab' and 'OCtave' only, and is equivalent to \code{cheby1(n, Rp, 1, "low", "s")}. } \examples{ ## 9th order Chebyshev type I low-pass analog filter zp <- cheb1ap(9, .1) w <- seq(0, 4, length.out = 128) freqs(zp, w) } \author{ Carne Draug, \email{carandraug+dev@gmail.com}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/man/mscohere.Rd0000644000176200001440000001030014420222025014530 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mscohere.R \name{mscohere} \alias{mscohere} \alias{cohere} \title{Magnitude-squared coherence} \usage{ mscohere( x, window = nextpow2(sqrt(NROW(x))), overlap = 0.5, nfft = ifelse(isScalar(window), window, length(window)), fs = 1, detrend = c("long-mean", "short-mean", "long-linear", "short-linear", "none") ) cohere( x, window = nextpow2(sqrt(NROW(x))), overlap = 0.5, nfft = ifelse(isScalar(window), window, length(window)), fs = 1, detrend = c("long-mean", "short-mean", "long-linear", "short-linear", "none") ) } \arguments{ \item{x}{input data, specified as a numeric vector or matrix. In case of a vector it represents a single signal; in case of a matrix each column is a signal.} \item{window}{If \code{window} is a vector, each segment has the same length as \code{window} and is multiplied by \code{window} before (optional) zero-padding and calculation of its periodogram. If \code{window} is a scalar, each segment has a length of \code{window} and a Hamming window is used. Default: \code{nextpow2(sqrt(length(x)))} (the square root of the length of \code{x} rounded up to the next power of two). The window length must be larger than 3.} \item{overlap}{segment overlap, specified as a numeric value expressed as a multiple of window or segment length. 0 <= overlap < 1. Default: 0.5.} \item{nfft}{Length of FFT, specified as an integer scalar. The default is the length of the \code{window} vector or has the same value as the scalar \code{window} argument. If \code{nfft} is larger than the segment length, (seg_len), the data segment is padded \code{nfft - seg_len} zeros. The default is no padding. Nfft values smaller than the length of the data segment (or window) are ignored. Note that the use of padding to increase the frequency resolution of the spectral estimate is controversial.} \item{fs}{sampling frequency (Hertz), specified as a positive scalar. Default: 1.} \item{detrend}{character string specifying detrending option; one of: \describe{ \item{\code{long-mean}}{remove the mean from the data before splitting into segments (default)} \item{\code{short-mean}}{remove the mean value of each segment} \item{\code{long-linear}}{remove linear trend from the data before splitting into segments} \item{\code{short-linear}}{remove linear trend from each segment} \item{\code{none}}{no detrending} }} } \value{ A list containing the following elements: \describe{ \item{\code{freq}}{vector of frequencies at which the spectral variables are estimated. If \code{x} is numeric, power from negative frequencies is added to the positive side of the spectrum, but not at zero or Nyquist (fs/2) frequencies. This keeps power equal in time and spectral domains. If \code{x} is complex, then the whole frequency range is returned.} \item{\code{coh}}{NULL for univariate series. For multivariate series, a matrix containing the squared coherence between different series. Column \eqn{i + (j - 1) * (j - 2)/2 } of \code{coh} contains the cross-spectral estimates between columns \eqn{i} and \eqn{j} of \eqn{x}, where \eqn{i < j}.} } } \description{ Compute the magnitude-squared coherence estimates of input signals. } \details{ \code{mscohere} estimates the magnitude-squared coherence function using Welch’s overlapped averaged periodogram method [1] } \note{ The function \code{mscohere} (and its deprecated alias \code{cohere}) is a wrapper for the function \code{pwelch}, which is more complete and more flexible. } \examples{ fs <- 1000 f <- 250 t <- seq(0, 1 - 1/fs, 1/fs) s1 <- sin(2 * pi * f * t) + runif(length(t)) s2 <- sin(2 * pi * f * t - pi / 3) + runif(length(t)) rv <- mscohere(cbind(s1, s2), fs = fs) plot(rv$freq, rv$coh, type="l", xlab = "Frequency", ylab = "Coherence") } \references{ [1] Welch, P.D. (1967). The use of Fast Fourier Transform for the estimation of power spectra: A method based on time averaging over short, modified periodograms. IEEE Transactions on Audio and Electroacoustics, AU-15 (2): 70–73.\cr } \author{ Peter V. Lanspeary, \email{pvl@mecheng.adelaide.edu.au}.\cr Conversion to R by Geert van Boxtel, \email{G.J.M.vanBoxtel@gmail.com}. } gsignal/DESCRIPTION0000644000176200001440000001253114670417477013427 0ustar liggesusersPackage: gsignal Type: Package Title: Signal Processing Version: 0.3-7 Date: 2024-09-11 Authors@R: c(person("Geert", "van Boxtel", role = c("aut", "cre"), email = "G.J.M.vanBoxtel@gmail.com", comment = "Maintainer"), person("Tom", "Short", role = "aut", email = "tshort@eprisolutions.com", comment="Author of 'signal' package"), person("Paul", "Kienzle", role = "aut", comment = "Majority of the original sources"), person("Ben", "Abbott", role = "ctb"), person("Juan", "Aguado", role = "ctb"), person("Muthiah", "Annamalai", role = "ctb"), person("Leonardo", "Araujo", role = "ctb"), person("William", "Asquith", role = "ctb"), person("David", "Bateman", role = "ctb"), person("David", "Billinghurst", role = "ctb"), person("Juan Pablo", "Carbajal", role = "ctb"), person("André", "Carezia", role = "ctb"), person("Vincent", "Cautaerts", role = "ctb"), person("Eric", "Chassande-Mottin", role = "ctb"), person("Luca", "Citi", role = "ctb"), person("Dave", "Cogdell", role = "ctb"), person("Carlo", "de Falco", role = "ctb"), person("Carne", "Draug", role = "ctb"), person("Pascal", "Dupuis", role = "ctb"), person("John W.", "Eaton", role = "ctb"), person("R.G.H", "Eschauzier", role = "ctb"), person("Andrew", "Fitting", role = "ctb"), person("Alan J.", "Greenberger", role = "ctb"), person("Mike", "Gross", role = "ctb"), person("Daniel", "Gunyan", role = "ctb"), person("Kai", "Habel", role = "ctb"), person("Kurt", "Hornik", role = "ctb"), person("Jake", "Janovetz", role = "ctb"), person("Alexander", "Klein", role = "ctb"), person("Peter V.", "Lanspeary", role = "ctb"), person("Bill", "Lash", role = "ctb"), person("Friedrich", "Leissh", role = "ctb"), person("Laurent S.", "Mazet", role = "ctb"), person("Mike", "Miller", role = "ctb"), person("Petr", "Mikulik", role = "ctb"), person("Paolo", "Neis", role = "ctb"), person("Georgios", "Ouzounis", role = "ctb"), person("Sylvain", "Pelissier", role = "ctb"), person("Francesco", "Potortì", role = "ctb"), person("Charles", "Praplan", role = "ctb"), person("Lukas F.", "Reichlin", role = "ctb"), person("Tony", "Richardson", role = "ctb"), person("Asbjorn", "Sabo", role = "ctb"), person("Thomas", "Sailer", role = "ctb"), person("Rolf", "Schirmacher", role = "ctb"), person("Rolf", "Schirmacher", role = "ctb"), person("Ivan", "Selesnick", role = "ctb"), person("Julius O.", "Smith III", role = "ctb"), person("Peter L.", "Soendergaard", role = "ctb"), person("Quentin", "Spencer", role = "ctb"), person("Doug", "Stewart", role = "ctb"), person("P.", "Sudeepam", role = "ctb"), person("Stefan", "van der Walt", role = "ctb"), person("Andreas", "Weber", role = "ctb"), person("P.", "Sudeepam", role = "ctb"), person("Andreas", "Weingessel", role = "ctb")) Description: R implementation of the 'Octave' package 'signal', containing a variety of signal processing tools, such as signal generation and measurement, correlation and convolution, filtering, filter design, filter analysis and conversion, power spectrum analysis, system identification, decimation and sample rate change, and windowing. Depends: R (>= 3.5.0) LinkingTo: Rcpp Imports: pracma, Rcpp, grDevices License: GPL-3 Encoding: UTF-8 Language: en-US URL: https://github.com/gjmvanboxtel/gsignal BugReports: https://github.com/gjmvanboxtel/gsignal/issues LazyData: true RoxygenNote: 7.3.2 Suggests: knitr, rmarkdown, testthat, ggplot2, gridExtra, microbenchmark, covr VignetteBuilder: knitr NeedsCompilation: yes Packaged: 2024-09-11 12:27:07 UTC; geert Author: Geert van Boxtel [aut, cre] (Maintainer), Tom Short [aut] (Author of 'signal' package), Paul Kienzle [aut] (Majority of the original sources), Ben Abbott [ctb], Juan Aguado [ctb], Muthiah Annamalai [ctb], Leonardo Araujo [ctb], William Asquith [ctb], David Bateman [ctb], David Billinghurst [ctb], Juan Pablo Carbajal [ctb], André Carezia [ctb], Vincent Cautaerts [ctb], Eric Chassande-Mottin [ctb], Luca Citi [ctb], Dave Cogdell [ctb], Carlo de Falco [ctb], Carne Draug [ctb], Pascal Dupuis [ctb], John W. Eaton [ctb], R.G.H Eschauzier [ctb], Andrew Fitting [ctb], Alan J. Greenberger [ctb], Mike Gross [ctb], Daniel Gunyan [ctb], Kai Habel [ctb], Kurt Hornik [ctb], Jake Janovetz [ctb], Alexander Klein [ctb], Peter V. Lanspeary [ctb], Bill Lash [ctb], Friedrich Leissh [ctb], Laurent S. Mazet [ctb], Mike Miller [ctb], Petr Mikulik [ctb], Paolo Neis [ctb], Georgios Ouzounis [ctb], Sylvain Pelissier [ctb], Francesco Potortì [ctb], Charles Praplan [ctb], Lukas F. Reichlin [ctb], Tony Richardson [ctb], Asbjorn Sabo [ctb], Thomas Sailer [ctb], Rolf Schirmacher [ctb], Rolf Schirmacher [ctb], Ivan Selesnick [ctb], Julius O. Smith III [ctb], Peter L. Soendergaard [ctb], Quentin Spencer [ctb], Doug Stewart [ctb], P. Sudeepam [ctb], Stefan van der Walt [ctb], Andreas Weber [ctb], P. Sudeepam [ctb], Andreas Weingessel [ctb] Maintainer: Geert van Boxtel Repository: CRAN Date/Publication: 2024-09-11 22:52:47 UTC