From c8996d0ebf2ee3c8be3977827f928711aec9e6f0 Mon Sep 17 00:00:00 2001 From: pepijn-devries Date: Sat, 8 Nov 2025 13:27:35 +0100 Subject: [PATCH 1/7] improved test coverage --- DESCRIPTION | 2 +- NEWS.md | 2 +- R/cell.R | 17 +++------ R/s3.R | 64 ++++++++++---------------------- tests/testthat/test_cell.R | 10 ++++- tests/testthat/test_exceptions.R | 12 ++++++ tests/testthat/test_misc.R | 6 +++ tests/testthat/test_modinfo.R | 6 +++ 8 files changed, 60 insertions(+), 59 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 1882aa6..bae74d3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: ProTrackR2 Title: Manipulate and Play 'ProTracker' Modules -Version: 0.0.6.0012 +Version: 0.0.6.0013 Authors@R: c( person("Pepijn", "de Vries", role = c("aut", "cre"), email = "pepijn.devries@outlook.com", diff --git a/NEWS.md b/NEWS.md index fb38b0f..5fb2318 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -ProTrackR2 v0.0.6.0012 +ProTrackR2 v0.0.6.0013 ------------- * Implemented `as_pt2cell()` and `as_pt2celllist()` diff --git a/R/cell.R b/R/cell.R index 1d32af6..db653cb 100644 --- a/R/cell.R +++ b/R/cell.R @@ -29,17 +29,12 @@ pt2_cell <- function(pattern, i, j, ...) { if (is.na(i) || i < 0L || i > 63L || is.na(j) || j < 0L || j > 3L) stop("Index out of range") - if (is.raw(pattern)) { - compact <- attributes(pattern)$compact_notation - size <- ifelse(compact, 4L, pt_cell_bytesize()) - pattern <- unclass(pattern) - result <- pattern[seq_len(size) + (i*4L + j) * size] - class(result) <- "pt2cell" - attributes(result)$compact_notation <- compact - } else { - result <- c(unclass(pattern), j = i, k = j) - class(result) <- "pt2cell" - } + compact <- attributes(pattern)$compact_notation + size <- ifelse(compact, 4L, pt_cell_bytesize()) + pattern <- unclass(pattern) + result <- pattern[seq_len(size) + (i*4L + j) * size] + class(result) <- "pt2cell" + attributes(result)$compact_notation <- compact result } diff --git a/R/s3.R b/R/s3.R index a8c9285..47bece3 100644 --- a/R/s3.R +++ b/R/s3.R @@ -271,17 +271,7 @@ as.character.pt2celllist <- function(x, ...) { #' @rdname s3methods #' @export as.raw.pt2command <- function(x, ...) { - if (typeof(x) == "raw") return(x) - - if (inherits(x, "pt2celllist") || is.null(names(x))) { - mods <- lapply(x, `[[`, "mod") - i <- lapply(x, `[[`, "i") |> unlist() - j <- lapply(x, `[[`, "j") |> unlist() - k <- lapply(x, `[[`, "k") |> unlist() - pt_eff_command_(mods, i, k, j) - } else { - pt_eff_command_(list(x$mod), x$i, x$k, x$j) - } + x # pt2command is already raw } #' @method as.raw pt2cell @@ -297,37 +287,25 @@ as.raw.pt2cell <- function(x, ...) { #' @rdname s3methods #' @export as.raw.pt2cell.logical <- function(x, compact = TRUE, ...) { - if (typeof(x) == "raw") { - cur_notation <- attributes(x)$compact_notation - if (is.null(cur_notation)) - stop("Unknown notation of `pt2cell`") - if (cur_notation == compact) return (x) - if (cur_notation) { - x <- pt_decode_compact_cell(x) - } else { - x <- pt_encode_compact_cell(x) - } - class(x) <- "pt2cell" - attributes(x)$compact_notation <- !cur_notation - x + cur_notation <- attributes(x)$compact_notation + if (is.null(cur_notation)) + stop("Unknown notation of `pt2cell`") + if (cur_notation == compact) return (x) + if (cur_notation) { + x <- pt_decode_compact_cell(x) } else { - result <- - cells_as_raw_(x$mod, as.integer(x$i), compact, FALSE, - as.integer(x$j), as.integer(x$k)) - class(result) <- "pt2cell" - result + x <- pt_encode_compact_cell(x) } + class(x) <- "pt2cell" + attributes(x)$compact_notation <- !cur_notation + x } #' @method format pt2samp #' @rdname s3methods #' @export format.pt2samp <- function(x, ...) { - si <- if (typeof(x) == "raw") { - attributes(x)$sample_info - } else { - mod_sample_info_(x$mod, as.integer(x$i)) - } + si <- attributes(x)$sample_info sprintf("PT2 Sample '%s' [%i]", si$text, si$length) } @@ -399,17 +377,13 @@ as.raw.pt2samp <- function(x, ...) { #' @rdname s3methods #' @export as.integer.pt2samp <- function(x, ...) { - if (typeof(x) == "raw") { - a <- attributes(x) - x <- - unclass(x) |> - as.integer() - x[x > 127L] <- x[x > 127L] - 256L - attributes(x) <- a[!names(a) %in% "class"] - x - } else { - mod_sample_as_int_(x$mod, x$i) - } + a <- attributes(x) + x <- + unclass(x) |> + as.integer() + x[x > 127L] <- x[x > 127L] - 256L + attributes(x) <- a[!names(a) %in% "class"] + x } .command_format <- function(x, fmt = getOption("pt2_effect_format")) { diff --git a/tests/testthat/test_cell.R b/tests/testthat/test_cell.R index 2461304..679f06c 100644 --- a/tests/testthat/test_cell.R +++ b/tests/testthat/test_cell.R @@ -8,4 +8,12 @@ test_that("A character string can be coerced to pt2cell", { expect_identical({ as_pt2celllist("C-3 01 A0F") |> as.character() }, "C-3 01 A0F") -}) \ No newline at end of file +}) + +test_that("Dash can be missing when coercing to pt2cell", { + expect_identical({ + as_pt2celllist("C201A10") |> as.character() + }, "C-2 01 A10") +}) + +as_pt2cell("C201A10") |> as.character() \ No newline at end of file diff --git a/tests/testthat/test_exceptions.R b/tests/testthat/test_exceptions.R index 8866e2a..2ce7ec2 100644 --- a/tests/testthat/test_exceptions.R +++ b/tests/testthat/test_exceptions.R @@ -12,6 +12,12 @@ test_that("pt2_cell cannot be called on an unsupported type", { }) }) +test_that("Malformed string cannot be coerced to pt2_cell", { + expect_error({ + as_pt2cell("C1A10") + }) +}) + test_that("pt2_cell indices cannot be out of range", { expect_error({ pt2_cell(pt2_pattern(mod, 0L), 0L, 64L) @@ -44,6 +50,12 @@ test_that("pt2_instrument cannot be called on an unsupported type", { }) }) +test_that("NA cannot be assigned to pt2_instrument", { + expect_error({ + pt2_instrument(mod$patterns[[1]][1,1]) <- NA_integer_ + }) +}) + test_that("pt2_instrument cannot be assigned an NA", { expect_error({ pt2_instrument(1L) diff --git a/tests/testthat/test_misc.R b/tests/testthat/test_misc.R index 419ee12..7cdbdf7 100644 --- a/tests/testthat/test_misc.R +++ b/tests/testthat/test_misc.R @@ -7,3 +7,9 @@ test_that("Can add a 100th pattern to a mod", { }) }) +test_that("Commands can be extracted", { + expect_no_error({ + comm <- pt2_command(mod$patterns[[1]][]) + pt2_command(comm) + }) +}) \ No newline at end of file diff --git a/tests/testthat/test_modinfo.R b/tests/testthat/test_modinfo.R index f483f57..22e4a5d 100644 --- a/tests/testthat/test_modinfo.R +++ b/tests/testthat/test_modinfo.R @@ -21,3 +21,9 @@ test_that("Mod name can be set", { pt2_name(mod) }, "foobar") }) + +test_that("Pattern can be coerced to modplug", { + expect_equal({ + mp_pat <- as_modplug_pattern(pt2_pattern(mod, 0L))[[1]] + }, "ModPlug Tracker MOD") +}) \ No newline at end of file From 6691dad60c81a30af74c2c0c31c7c75ad4627afb Mon Sep 17 00:00:00 2001 From: pepijn-devries Date: Sat, 8 Nov 2025 16:38:56 +0100 Subject: [PATCH 2/7] Removed redundant code. Improved test coverage --- R/s3.R | 32 ++++----- R/samples.R | 18 +----- R/select_ops.R | 108 +++++++++++-------------------- tests/testthat/test_exceptions.R | 24 +++++++ tests/testthat/test_sample.R | 17 ++++- 5 files changed, 91 insertions(+), 108 deletions(-) diff --git a/R/s3.R b/R/s3.R index 47bece3..6414443 100644 --- a/R/s3.R +++ b/R/s3.R @@ -118,13 +118,9 @@ as.character.pt2command <- function(x, ...) { #' @rdname s3methods #' @export format.pt2command <- function(x, fmt = getOption("pt2_effect_format"), ...) { - if (typeof(x) == "raw") { - matrix(x, ncol = 2L, byrow = TRUE) |> - apply(1, .command_format, fmt, simplify = FALSE) |> - unlist() - } else { - .command_format(x, fmt) - } + matrix(x, ncol = 2L, byrow = TRUE) |> + apply(1, .command_format, fmt, simplify = FALSE) |> + unlist() } #' @method print pt2command @@ -191,19 +187,15 @@ as.raw.pt2celllist <- function(x, ...) { #' @export as.raw.pt2celllist.logical <- function(x, compact = TRUE, ...) { d <- attr(x, "celldim") - if (typeof(x) == "raw") { - cur_notation <- attributes(x)$compact_notation - width <- ifelse(cur_notation, 4L, pt_cell_bytesize()) - x <- - matrix(unclass(x), ncol = width, byrow = TRUE) |> - apply(1, \(y) { - class(y) <- "pt2cell" - attributes(y)$compact_notation <- cur_notation - as.raw.pt2cell(y, compact = compact) - }, simplify = FALSE) |> unlist() - } else { - x <- lapply(x, \(y) as.raw.pt2cell(y, compact = compact, ...)) |> unlist() - } + cur_notation <- attributes(x)$compact_notation + width <- ifelse(cur_notation, 4L, pt_cell_bytesize()) + x <- + matrix(unclass(x), ncol = width, byrow = TRUE) |> + apply(1, \(y) { + class(y) <- "pt2cell" + attributes(y)$compact_notation <- cur_notation + as.raw.pt2cell(y, compact = compact) + }, simplify = FALSE) |> unlist() structure(x, class = "pt2celllist", celldim = d, compact_notation = compact) } diff --git a/R/samples.R b/R/samples.R index 608b2ab..4c30619 100644 --- a/R/samples.R +++ b/R/samples.R @@ -27,9 +27,7 @@ pt2_sample <- function(mod, i, ...) { #' @method pt2_name pt2samp #' @export pt2_name.pt2samp <- function(x, ...) { - if (typeof(x) == "raw") - attributes(x)$sample_info$text else - mod_sample_info_(x$mod, as.integer(x$i))$sample_info$text + attributes(x)$sample_info$text } #' @rdname mod_info @@ -76,10 +74,6 @@ pt2_n_sample <- function(mod, ...) { count } -.test_rawsample <- function(sample) { - if (typeof(sample) != "raw") stop("Function only supports raw samples") -} - #' Get or set ProTracker sample properties #' #' Get or set properties of a ProTracker sample. See 'details' section @@ -130,14 +124,12 @@ pt2_n_sample <- function(mod, ...) { #' @rdname sample_properties #' @export pt2_finetune <- function(sample, ...) { - .test_rawsample(sample) return(attr(sample, "sample_info")$fineTune) } #' @rdname sample_properties #' @export `pt2_finetune<-` <- function(sample, ..., value) { - .test_rawsample(sample) attr(sample, "sample_info")$fineTune <- as.integer(value) validate_sample_raw_(sample) return(sample) @@ -146,14 +138,12 @@ pt2_finetune <- function(sample, ...) { #' @rdname sample_properties #' @export pt2_volume <- function(sample, ...) { - .test_rawsample(sample) return(attr(sample, "sample_info")$volume) } #' @rdname sample_properties #' @export `pt2_volume<-` <- function(sample, ..., value) { - .test_rawsample(sample) attr(sample, "sample_info")$volume <- as.integer(value) validate_sample_raw_(sample) return(sample) @@ -162,14 +152,12 @@ pt2_volume <- function(sample, ...) { #' @rdname sample_properties #' @export pt2_loop_start <- function(sample, ...) { - .test_rawsample(sample) return(attr(sample, "sample_info")$loopStart) } #' @rdname sample_properties #' @export `pt2_loop_start<-` <- function(sample, ..., value) { - .test_rawsample(sample) attr(sample, "sample_info")$loopStart <- as.integer(value - (value %% 2)) validate_sample_raw_(sample) return(sample) @@ -178,14 +166,12 @@ pt2_loop_start <- function(sample, ...) { #' @rdname sample_properties #' @export pt2_loop_length <- function(sample, ...) { - .test_rawsample(sample) return(attr(sample, "sample_info")$loopLength) } #' @rdname sample_properties #' @export `pt2_loop_length<-` <- function(sample, ..., value) { - .test_rawsample(sample) attr(sample, "sample_info")$loopLength <- as.integer(value - (value %% 2L)) validate_sample_raw_(sample) return(sample) @@ -194,7 +180,6 @@ pt2_loop_length <- function(sample, ...) { #' @rdname sample_properties #' @export pt2_is_looped <- function(sample, ...) { - .test_rawsample(sample) si <- attr(sample, "sample_info") return(!(si$loopStart == 0L && si$loopLength == 2L)) } @@ -204,7 +189,6 @@ pt2_is_looped <- function(sample, ...) { `pt2_is_looped<-` <- function(sample, ..., value) { if (!is.logical(value) || length(value) != 1) stop("Replacement value needs to be a single logical value") - .test_rawsample(sample) is_looped <- pt2_is_looped(sample) if (is_looped && !value) { attr(sample, "sample_info")$loopStart <- 0L diff --git a/R/select_ops.R b/R/select_ops.R index 9f4dbb4..f863b91 100644 --- a/R/select_ops.R +++ b/R/select_ops.R @@ -66,7 +66,7 @@ } } else { - stop("Index out of range") + stop("Unknown module element") } x } @@ -145,18 +145,13 @@ `[.pt2pat` <- function(x, i, j, ...) { if (missing(i)) i <- 1L:64L if (missing(j)) j <- 1L:4L - if (typeof(x) == "raw") { - cur_notation <- attributes(x)$compact_notation - width <- ifelse(cur_notation, 4L, pt_cell_bytesize()) - idx <- outer(i - 1L, j - 1L, \(y, z) y*width * 4L + z*width) |> c() - idx <- outer(1:width, idx, `+`) |> c() - x <- unclass(x) - x <- x[idx] - attributes(x)$compact_notation <- cur_notation - } else { - idx <- expand.grid(i = i - 1L, j = j - 1L) - x <- mapply(\(y, i, j) pt2_cell(x, i, j), i = idx[,"i"], j = idx[,"j"], SIMPLIFY = FALSE) - } + cur_notation <- attributes(x)$compact_notation + width <- ifelse(cur_notation, 4L, pt_cell_bytesize()) + idx <- outer(i - 1L, j - 1L, \(y, z) y*width * 4L + z*width) |> c() + idx <- outer(1:width, idx, `+`) |> c() + x <- unclass(x) + x <- x[idx] + attributes(x)$compact_notation <- cur_notation class(x) <- "pt2celllist" attr(x, "celldim") <- c(length(i), length(j)) as.raw.pt2celllist(x, compact = TRUE) @@ -174,26 +169,19 @@ target_idx <- expand.grid(as.integer(i) - 1L, as.integer(j) - 1L) - if (typeof(x) == "raw") { - values <- as.raw.pt2celllist(value, compact = attributes(x)$compact_notation) - compact <- attributes(x)$compact_notation - size <- ifelse(compact, 4L, pt_cell_bytesize()) - x <- x |> unclass() - target_idx <- - target_idx |> - apply(1, \(z) size * (z[1] * 4L + z[2])) |> - lapply(`+`, seq_len(size)) |> - unlist() - x[target_idx] <- unlist(values) - class(x) <- "pt2pat" - attributes(x)$compact_notation <- compact - x - } else { - values <- as.raw.pt2celllist(value, compact = FALSE) - m <- replace_cells_(x, as.matrix(target_idx), values) - if (m != "") warning(m) - x - } + values <- as.raw.pt2celllist(value, compact = attributes(x)$compact_notation) + compact <- attributes(x)$compact_notation + size <- ifelse(compact, 4L, pt_cell_bytesize()) + x <- x |> unclass() + target_idx <- + target_idx |> + apply(1, \(z) size * (z[1] * 4L + z[2])) |> + lapply(`+`, seq_len(size)) |> + unlist() + x[target_idx] <- unlist(values) + class(x) <- "pt2pat" + attributes(x)$compact_notation <- compact + x } #' @rdname select_assign @@ -216,18 +204,14 @@ if (length(list(...)) != 0) warning("Ignoring arguments passed to dots") - if (typeof(x) == "raw") { - cpt <- attr(x, "compact_notation") - d <- attr(x, "celldim") - value <- as.raw.pt2celllist(value, compact = cpt) - sz <- ifelse(cpt, 4L, pt_cell_bytesize()) - idx <- rep((i - 1L)*sz, each = sz) + seq_len(sz) - x <- unclass(x) - x[idx] <- unclass(value) - x <- structure(x, class = "pt2celllist", celldim = d, compact_notation = cpt) - } else { - replace_cells_(x, as.integer(i), as.raw.pt2celllist(value, compact = FALSE)) - } + cpt <- attr(x, "compact_notation") + d <- attr(x, "celldim") + value <- as.raw.pt2celllist(value, compact = cpt) + sz <- ifelse(cpt, 4L, pt_cell_bytesize()) + idx <- rep((i - 1L)*sz, each = sz) + seq_len(sz) + x <- unclass(x) + x[idx] <- unclass(value) + x <- structure(x, class = "pt2celllist", celldim = d, compact_notation = cpt) x } @@ -249,25 +233,17 @@ #' @rdname select_assign #' @export `[[.pt2celllist` <- function(x, i, ...) { - if (typeof(x) == "raw") { - cur_class <- class(x) - x <- .raw_sel_celllist(x, i) - class(x) <- union("pt2cell", setdiff(cur_class, "pt2cellist")) - x - } else { - NextMethod() - } + cur_class <- class(x) + x <- .raw_sel_celllist(x, i) + class(x) <- union("pt2cell", setdiff(cur_class, "pt2cellist")) + x } #' @rdname select_assign #' @export `[.pt2celllist` <- function(x, i, ...) { cur_class <- class(x) - if (typeof(x) == "raw") { - x <- .raw_sel_celllist(x, i) - } else { - x <- NextMethod() - } + x <- .raw_sel_celllist(x, i) class(x) <- cur_class x } @@ -275,24 +251,16 @@ #' @rdname select_assign #' @export `[[.pt2command` <- function(x, i, ...) { - if (typeof(x) == "raw") { - x <- .raw_sel_command(x, i) - class(x) <- "pt2command" - x - } else { - NextMethod() - } + x <- .raw_sel_command(x, i) + class(x) <- "pt2command" + x } #' @rdname select_assign #' @export `[.pt2command` <- function(x, i, ...) { cur_class <- class(x) - if (typeof(x) == "raw") { - x <- .raw_sel_command(x, i) - } else { - x <- NextMethod() - } + x <- .raw_sel_command(x, i) class(x) <- cur_class x } diff --git a/tests/testthat/test_exceptions.R b/tests/testthat/test_exceptions.R index 2ce7ec2..1918f22 100644 --- a/tests/testthat/test_exceptions.R +++ b/tests/testthat/test_exceptions.R @@ -18,6 +18,12 @@ test_that("Malformed string cannot be coerced to pt2_cell", { }) }) +test_that("Cannot convert more than 1 element to pt2_cell", { + expect_error({ + as_pt2cell(c("C101000", "C101000")) + }) +}) + test_that("pt2_cell indices cannot be out of range", { expect_error({ pt2_cell(pt2_pattern(mod, 0L), 0L, 64L) @@ -146,3 +152,21 @@ test_that("Cannot add more than 100 patterns to a module", { mod$patterns[[101]] <- pt2_new_pattern() }) }) + +test_that("Cannot set looped state to more than one value", { + expect_error({ + pt2_is_looped(mod$samples[[1]]) <- c(TRUE, TRUE) + }) +}) + +test_that("You cannot assign more than 100 patterns to a module", { + expect_error({ + mod$patterns <- mod$patterns[rep(1, times = 102L)] + }) +}) + +test_that("You cannot select unknown elements from a module", { + expect_error({ + mod[["foobar"]] + }) +}) diff --git a/tests/testthat/test_sample.R b/tests/testthat/test_sample.R index 6d01810..28af2c5 100644 --- a/tests/testthat/test_sample.R +++ b/tests/testthat/test_sample.R @@ -15,6 +15,12 @@ test_that("Sample name can be set", { }, "foobar") }) +test_that("Sample name replacement should have same number of elements as its source", { + expect_error({ + pt2_name(mod$samples) <- "foobar" + }) +}) + test_that("Sample list name can be set", { expect_identical({ pt2_name(mod$samples) <- rep("foobar", 31) @@ -51,6 +57,9 @@ test_that("Sample properties can be changed", { pt2_is_looped(mod$samples[[2]]) pt2_is_looped(mod$samples[[2]]) <- TRUE + + pt2_is_looped(mod$samples[[2]]) <- FALSE + }) }) @@ -58,4 +67,10 @@ test_that("Sample can be coerced", { expect_s3_class({ pt2_sample_to_audio(mod$samples[[1]]) }, "audioSample") -}) \ No newline at end of file +}) + +test_that("You can select a subset of samples", { + expect_equal({ + mod$samples[1:2] |> length() + }, 2L) +}) From af730baafa826fccf501d68ad5c2502eda50a0c0 Mon Sep 17 00:00:00 2001 From: pepijn-devries Date: Sat, 8 Nov 2025 18:27:31 +0100 Subject: [PATCH 3/7] select improvements. better test coverage --- R/select_ops.R | 58 +++++++++++++--------------------------- tests/testthat/test_s3.R | 10 ++++++- 2 files changed, 27 insertions(+), 41 deletions(-) diff --git a/R/select_ops.R b/R/select_ops.R index f863b91..7fc0cff 100644 --- a/R/select_ops.R +++ b/R/select_ops.R @@ -94,6 +94,7 @@ #' @rdname select_assign #' @export `[.pt2patlist` <- function(x, i, ...) { + if (missing(i)) i <- seq_along(x) x <- unclass(x) x <- NextMethod() class(x) <- "pt2patlist" @@ -125,6 +126,7 @@ #' @rdname select_assign #' @export `[.pt2samplist` <- function(x, i, ...) { + if (missing(i)) i <- seq_along(x) x <- unclass(x) x <- NextMethod() class(x) <- "pt2samplist" @@ -161,8 +163,6 @@ #' @export `[<-.pt2pat` <- function(x, i, j, ..., value) { if (is.character(value)) value <- as_pt2celllist(value) - if (!inherits(value, "pt2celllist")) - stop("`values` should be of class `pt2celllist`") if (missing(i)) i <- 1L:64L if (missing(j)) j <- 1L:4L @@ -242,6 +242,7 @@ #' @rdname select_assign #' @export `[.pt2celllist` <- function(x, i, ...) { + if (missing(i)) i <- seq_along(x) cur_class <- class(x) x <- .raw_sel_celllist(x, i) class(x) <- cur_class @@ -259,6 +260,7 @@ #' @rdname select_assign #' @export `[.pt2command` <- function(x, i, ...) { + if (missing(i)) i <- seq_along(x) cur_class <- class(x) x <- .raw_sel_command(x, i) class(x) <- cur_class @@ -268,50 +270,26 @@ #' @rdname select_assign #' @export `[[<-.pt2command` <- function(x, i, ..., value) { - if (inherits(x, c("pt2cell", "pt2celllist"))) { - - class(x) <- setdiff(class(x), "pt2command") - pt2_command(x[[i]]) <- value - class(x) <- union("pt2command", class(x)) - - } else if (typeof(x) == "raw") { - - x <- .command_list(x) - value <- pt2_command(value) |> - as.raw() |> - .command_list() - x[[i]] <- value - x <- unlist(x) - class(x) <- "pt2command" - - } else { - stop("Replacement method not implemented") - } + x <- .command_list(x) + value <- pt2_command(value) |> + as.raw() |> + .command_list() + x[[i]] <- value + x <- unlist(x) + class(x) <- "pt2command" x } #' @rdname select_assign #' @export `[<-.pt2command` <- function(x, i, ..., value) { - if (inherits(x, c("pt2cell", "pt2celllist"))) { - - class(x) <- setdiff(class(x), "pt2command") - pt2_command(x[i]) <- value - class(x) <- union("pt2command", class(x)) - - } else if (typeof(x) == "raw") { - - x <- .command_list(x) - value <- pt2_command(value) |> - as.raw() |> - .command_list() - x[i] <- value - x <- unlist(x) - class(x) <- "pt2command" - - } else { - stop("Replacement method not implemented") - } + x <- .command_list(x) + value <- pt2_command(value) |> + as.raw() |> + .command_list() + x[i] <- value + x <- unlist(x) + class(x) <- "pt2command" x } diff --git a/tests/testthat/test_s3.R b/tests/testthat/test_s3.R index f82b819..7238567 100644 --- a/tests/testthat/test_s3.R +++ b/tests/testthat/test_s3.R @@ -1,7 +1,8 @@ +mod <- pt2_read_mod(pt2_demo()) + test_that("S3 methods don't throw errors", { expect_no_error({ sink(tempfile()) - mod <- pt2_read_mod(pt2_demo()) patterns <- mod$patterns pattern <- patterns[[1]] cells <- pattern[1:4,1] @@ -42,6 +43,13 @@ test_that("S3 methods don't throw errors", { as.raw(cmnd) as.integer(sample) + sink() }) +}) + +test_that("Select and replace operators work OK", { + expect_no_error({ + mod$patterns[[1]][] <- "--- 01 111" + }) }) \ No newline at end of file From 948e497d29e571c90229b7978d1f0637321dad41 Mon Sep 17 00:00:00 2001 From: pepijn-devries Date: Sun, 9 Nov 2025 10:14:33 +0100 Subject: [PATCH 4/7] Improved select and assign behaviour --- NAMESPACE | 5 ++++ R/cell.R | 6 +++++ R/select_ops.R | 49 +++++++++++++++++++++++++++++++++++----- man/select_assign.Rd | 12 ++++++++++ tests/testthat/test_s3.R | 9 +++++++- 5 files changed, 74 insertions(+), 7 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 20a29cb..29c8160 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,11 +13,15 @@ S3method("[<-",pt2pat) S3method("[[",pt2celllist) S3method("[[",pt2command) S3method("[[",pt2mod) +S3method("[[",pt2pat) S3method("[[",pt2patlist) S3method("[[",pt2samplist) S3method("[[<-",pt2celllist) S3method("[[<-",pt2command) +S3method("[[<-",pt2mod) +S3method("[[<-",pt2pat) S3method("[[<-",pt2patlist) +S3method("[[<-",pt2samplist) S3method("pt2_name<-",pt2mod) S3method("pt2_name<-",pt2samp) S3method("pt2_name<-",pt2samplist) @@ -37,6 +41,7 @@ S3method(as.raw.pt2celllist,logical) S3method(as.raw.pt2pat,logical) S3method(as_pt2cell,character) S3method(as_pt2celllist,character) +S3method(as_pt2celllist,pt2celllist) S3method(format,pt2cell) S3method(format,pt2celllist) S3method(format,pt2command) diff --git a/R/cell.R b/R/cell.R index db653cb..245ad31 100644 --- a/R/cell.R +++ b/R/cell.R @@ -91,6 +91,12 @@ as_pt2celllist <- function(x, ...) { UseMethod("as_pt2celllist") } +#' @method as_pt2celllist pt2celllist +#' @export +as_pt2celllist.pt2celllist <- function(x, ...) { + x +} + #' @method as_pt2celllist character #' @export as_pt2celllist.character <- function(x, ...) { diff --git a/R/select_ops.R b/R/select_ops.R index 7fc0cff..1862c9f 100644 --- a/R/select_ops.R +++ b/R/select_ops.R @@ -18,6 +18,19 @@ #' @rdname select_assign #' @export `$<-.pt2mod` <- function(x, i, value) { + x[[i]] <- value + x +} + +#' @rdname select_assign +#' @export +`[[<-.pt2mod` <- function(x, i, value) { + what <- if (i == 1L || toupper(i) == "PATTERNS") "patterns" else if (i == 2L || toupper(i) == "SAMPLES") "samples" else + "unknown" + if (what == "samples" && !inherits(value, "pt2samplist")) + stop("Can only replace a sample list with an object of class `pt2samplist`") + if (what == "patterns" && !inherits(value, "pt2patlist")) + stop("Can only replace a pattern list with an object of class `pt2patlist`") value <- value |> length() |> @@ -34,7 +47,7 @@ } }) - if (i == 1L || toupper(i) == "PATTERNS") { + if (what == "patterns") { if (length(value) > 100L) stop("A ProTracker module cannot hold more than 100 patterns.") n_pat <- pt2_n_pattern(x) @@ -57,7 +70,7 @@ set_new_pattern_(x, as.integer(j - 1L), unclass(value[[j]])) } } - } else if (i == 2L || toupper(i) == "SAMPLES") { + } else if (what == "samples") { for (j in seq_len(length(value))) { if (is.raw(value[[j]])) { if (!validate_sample_raw_(value[[j]])) stop(sprintf("Not a valid sample at index %i", j)) @@ -65,8 +78,6 @@ } } - } else { - stop("Unknown module element") } x } @@ -87,7 +98,7 @@ class(result) <- "pt2samplist" result } else { - stop("Index out of range") + stop("Unknown module element") } } @@ -142,6 +153,30 @@ x } +#' @rdname select_assign +#' @export +`[[<-.pt2samplist` <- function(x, i, value) { + if (!inherits(value, "pt2samp")) + stop("Can only replace a sample in a sample list by an object of class `pt2samp`") + x <- unclass(x) + x[[i]] <- value + class(x) <- "pt2samplist" + x +} + +#' @rdname select_assign +#' @export +`[[.pt2pat` <- function(x, i, ...) { + x[][[i]] +} + +#' @rdname select_assign +#' @export +`[[<-.pt2pat` <- function(x, i, value) { + x[][[i]] <- value + x +} + #' @rdname select_assign #' @export `[.pt2pat` <- function(x, i, j, ...) { @@ -162,7 +197,7 @@ #' @rdname select_assign #' @export `[<-.pt2pat` <- function(x, i, j, ..., value) { - if (is.character(value)) value <- as_pt2celllist(value) + value <- as_pt2celllist(value) if (missing(i)) i <- 1L:64L if (missing(j)) j <- 1L:4L @@ -199,6 +234,7 @@ #' @rdname select_assign #' @export `[<-.pt2celllist` <- function(x, i, ..., value) { + if (missing(i)) i <- seq_along(x) if (!inherits(value, c("pt2cell", "pt2celllist"))) value <- as_pt2celllist(value) @@ -233,6 +269,7 @@ #' @rdname select_assign #' @export `[[.pt2celllist` <- function(x, i, ...) { + if (missing(i)) i <- seq_along(x) cur_class <- class(x) x <- .raw_sel_celllist(x, i) class(x) <- union("pt2cell", setdiff(cur_class, "pt2cellist")) diff --git a/man/select_assign.Rd b/man/select_assign.Rd index a08bc1f..4fbb67e 100644 --- a/man/select_assign.Rd +++ b/man/select_assign.Rd @@ -3,12 +3,16 @@ \name{$.pt2mod} \alias{$.pt2mod} \alias{$<-.pt2mod} +\alias{[[<-.pt2mod} \alias{[[.pt2mod} \alias{[.pt2patlist} \alias{[[.pt2patlist} \alias{[[<-.pt2patlist} \alias{[.pt2samplist} \alias{[[.pt2samplist} +\alias{[[<-.pt2samplist} +\alias{[[.pt2pat} +\alias{[[<-.pt2pat} \alias{[.pt2pat} \alias{[<-.pt2pat} \alias{[[<-.pt2celllist} @@ -25,6 +29,8 @@ \method{$}{pt2mod}(x, i) <- value +\method{[[}{pt2mod}(x, i) <- value + \method{[[}{pt2mod}(x, i, ...) \method{[}{pt2patlist}(x, i, ...) @@ -37,6 +43,12 @@ \method{[[}{pt2samplist}(x, i, ...) +\method{[[}{pt2samplist}(x, i) <- value + +\method{[[}{pt2pat}(x, i, ...) + +\method{[[}{pt2pat}(x, i) <- value + \method{[}{pt2pat}(x, i, j, ...) \method{[}{pt2pat}(x, i, j, ...) <- value diff --git a/tests/testthat/test_s3.R b/tests/testthat/test_s3.R index 7238567..39220a2 100644 --- a/tests/testthat/test_s3.R +++ b/tests/testthat/test_s3.R @@ -50,6 +50,13 @@ test_that("S3 methods don't throw errors", { test_that("Select and replace operators work OK", { expect_no_error({ - mod$patterns[[1]][] <- "--- 01 111" + pat <- mod$patterns[[1]] + pat[] + pat[][] + pat[[1]][] + pat[] <- "--- 01 111" + pat[][] <- "--- 01 111" + comm <- pt2_command(mod$patterns[[1]]) + comm[] <- "AAA" }) }) \ No newline at end of file From fccf74add0d25f3fbef75a4fffe09c5a85bea505 Mon Sep 17 00:00:00 2001 From: pepijn-devries Date: Sun, 9 Nov 2025 11:49:13 +0100 Subject: [PATCH 5/7] Removed redundant code. Iimproved test coverage --- R/cpp11.R | 40 +----- R/s3.R | 2 +- src/cpp11.cpp | 80 +---------- src/patterns.cpp | 9 +- src/pt_cell.cpp | 257 ----------------------------------- tests/testthat/test_misc.R | 4 +- tests/testthat/test_sample.R | 6 + 7 files changed, 17 insertions(+), 381 deletions(-) diff --git a/R/cpp11.R b/R/cpp11.R index 68d9aa3..6ab396a 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -48,8 +48,8 @@ pt_get_PAL_hz <- function() { .Call(`_ProTrackR2_pt_get_PAL_hz`) } -cells_as_raw_ <- function(mod, pattern, compact, as_pattern, row, channel) { - .Call(`_ProTrackR2_cells_as_raw_`, mod, pattern, compact, as_pattern, row, channel) +cells_as_raw_ <- function(mod, pattern, compact, row, channel) { + .Call(`_ProTrackR2_cells_as_raw_`, mod, pattern, compact, row, channel) } set_new_pattern_ <- function(mod, pattern_idx, data_new) { @@ -60,42 +60,14 @@ pt_cell_bytesize <- function() { .Call(`_ProTrackR2_pt_cell_bytesize`) } -pt_cell_ <- function(mod, pattern, channel, row) { - .Call(`_ProTrackR2_pt_cell_`, mod, pattern, channel, row) -} - note_to_period_ <- function(note, empty_char, finetune) { .Call(`_ProTrackR2_note_to_period_`, note, empty_char, finetune) } -pt_note_string_ <- function(mod, pattern, channel, row) { - .Call(`_ProTrackR2_pt_note_string_`, mod, pattern, channel, row) -} - pt_note_string_raw_ <- function(data) { .Call(`_ProTrackR2_pt_note_string_raw_`, data) } -pt_set_note_ <- function(mod, pattern, channel, row, replacement, warn) { - .Call(`_ProTrackR2_pt_set_note_`, mod, pattern, channel, row, replacement, warn) -} - -pt_instr_ <- function(mod, pattern, channel, row) { - .Call(`_ProTrackR2_pt_instr_`, mod, pattern, channel, row) -} - -pt_set_instr_ <- function(mod, pattern, channel, row, replacement, warn) { - .Call(`_ProTrackR2_pt_set_instr_`, mod, pattern, channel, row, replacement, warn) -} - -pt_eff_command_ <- function(mod, pattern, channel, row) { - .Call(`_ProTrackR2_pt_eff_command_`, mod, pattern, channel, row) -} - -pt_set_eff_command_ <- function(mod, pattern, channel, row, replacement, warn) { - .Call(`_ProTrackR2_pt_set_eff_command_`, mod, pattern, channel, row, replacement, warn) -} - pt_rawcell_as_char_ <- function(pattern, padding, empty_char, sformat) { .Call(`_ProTrackR2_pt_rawcell_as_char_`, pattern, padding, empty_char, sformat) } @@ -108,14 +80,6 @@ pt_encode_compact_cell <- function(source) { .Call(`_ProTrackR2_pt_encode_compact_cell`, source) } -celllist_to_raw_ <- function(celllist, compact) { - .Call(`_ProTrackR2_celllist_to_raw_`, celllist, compact) -} - -replace_cells_ <- function(pattern, idx, replacement) { - .Call(`_ProTrackR2_replace_cells_`, pattern, idx, replacement) -} - pt_cleanup_ <- function() { .Call(`_ProTrackR2_pt_cleanup_`) } diff --git a/R/s3.R b/R/s3.R index 6414443..a10be36 100644 --- a/R/s3.R +++ b/R/s3.R @@ -220,7 +220,7 @@ as.raw.pt2pat.logical <- function(x, compact = TRUE, ...) { attributes(x)$compact_notation <- !cur_notation x } else { - cells_as_raw_(x$mod, as.integer(x$i), compact, TRUE, 0L, 0L) + cells_as_raw_(x$mod, as.integer(x$i), compact, 0L, 0L) } } diff --git a/src/cpp11.cpp b/src/cpp11.cpp index 0c2ace7..01df9a9 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -90,10 +90,10 @@ extern "C" SEXP _ProTrackR2_pt_get_PAL_hz() { END_CPP11 } // patterns.cpp -SEXP cells_as_raw_(SEXP mod, int pattern, bool compact, bool as_pattern, int row, int channel); -extern "C" SEXP _ProTrackR2_cells_as_raw_(SEXP mod, SEXP pattern, SEXP compact, SEXP as_pattern, SEXP row, SEXP channel) { +SEXP cells_as_raw_(SEXP mod, int pattern, bool compact, int row, int channel); +extern "C" SEXP _ProTrackR2_cells_as_raw_(SEXP mod, SEXP pattern, SEXP compact, SEXP row, SEXP channel) { BEGIN_CPP11 - return cpp11::as_sexp(cells_as_raw_(cpp11::as_cpp>(mod), cpp11::as_cpp>(pattern), cpp11::as_cpp>(compact), cpp11::as_cpp>(as_pattern), cpp11::as_cpp>(row), cpp11::as_cpp>(channel))); + return cpp11::as_sexp(cells_as_raw_(cpp11::as_cpp>(mod), cpp11::as_cpp>(pattern), cpp11::as_cpp>(compact), cpp11::as_cpp>(row), cpp11::as_cpp>(channel))); END_CPP11 } // patterns.cpp @@ -111,13 +111,6 @@ extern "C" SEXP _ProTrackR2_pt_cell_bytesize() { END_CPP11 } // pt_cell.cpp -list pt_cell_(SEXP mod, int pattern, int channel, int row); -extern "C" SEXP _ProTrackR2_pt_cell_(SEXP mod, SEXP pattern, SEXP channel, SEXP row) { - BEGIN_CPP11 - return cpp11::as_sexp(pt_cell_(cpp11::as_cpp>(mod), cpp11::as_cpp>(pattern), cpp11::as_cpp>(channel), cpp11::as_cpp>(row))); - END_CPP11 -} -// pt_cell.cpp integers note_to_period_(strings note, std::string empty_char, int finetune); extern "C" SEXP _ProTrackR2_note_to_period_(SEXP note, SEXP empty_char, SEXP finetune) { BEGIN_CPP11 @@ -125,13 +118,6 @@ extern "C" SEXP _ProTrackR2_note_to_period_(SEXP note, SEXP empty_char, SEXP fin END_CPP11 } // pt_cell.cpp -strings pt_note_string_(list mod, integers pattern, integers channel, integers row); -extern "C" SEXP _ProTrackR2_pt_note_string_(SEXP mod, SEXP pattern, SEXP channel, SEXP row) { - BEGIN_CPP11 - return cpp11::as_sexp(pt_note_string_(cpp11::as_cpp>(mod), cpp11::as_cpp>(pattern), cpp11::as_cpp>(channel), cpp11::as_cpp>(row))); - END_CPP11 -} -// pt_cell.cpp std::string pt_note_string_raw_(raws data); extern "C" SEXP _ProTrackR2_pt_note_string_raw_(SEXP data) { BEGIN_CPP11 @@ -139,41 +125,6 @@ extern "C" SEXP _ProTrackR2_pt_note_string_raw_(SEXP data) { END_CPP11 } // pt_cell.cpp -SEXP pt_set_note_(list mod, integers pattern, integers channel, integers row, strings replacement, bool warn); -extern "C" SEXP _ProTrackR2_pt_set_note_(SEXP mod, SEXP pattern, SEXP channel, SEXP row, SEXP replacement, SEXP warn) { - BEGIN_CPP11 - return cpp11::as_sexp(pt_set_note_(cpp11::as_cpp>(mod), cpp11::as_cpp>(pattern), cpp11::as_cpp>(channel), cpp11::as_cpp>(row), cpp11::as_cpp>(replacement), cpp11::as_cpp>(warn))); - END_CPP11 -} -// pt_cell.cpp -integers pt_instr_(list mod, integers pattern, integers channel, integers row); -extern "C" SEXP _ProTrackR2_pt_instr_(SEXP mod, SEXP pattern, SEXP channel, SEXP row) { - BEGIN_CPP11 - return cpp11::as_sexp(pt_instr_(cpp11::as_cpp>(mod), cpp11::as_cpp>(pattern), cpp11::as_cpp>(channel), cpp11::as_cpp>(row))); - END_CPP11 -} -// pt_cell.cpp -SEXP pt_set_instr_(list mod, integers pattern, integers channel, integers row, integers replacement, bool warn); -extern "C" SEXP _ProTrackR2_pt_set_instr_(SEXP mod, SEXP pattern, SEXP channel, SEXP row, SEXP replacement, SEXP warn) { - BEGIN_CPP11 - return cpp11::as_sexp(pt_set_instr_(cpp11::as_cpp>(mod), cpp11::as_cpp>(pattern), cpp11::as_cpp>(channel), cpp11::as_cpp>(row), cpp11::as_cpp>(replacement), cpp11::as_cpp>(warn))); - END_CPP11 -} -// pt_cell.cpp -raws pt_eff_command_(list mod, integers pattern, integers channel, integers row); -extern "C" SEXP _ProTrackR2_pt_eff_command_(SEXP mod, SEXP pattern, SEXP channel, SEXP row) { - BEGIN_CPP11 - return cpp11::as_sexp(pt_eff_command_(cpp11::as_cpp>(mod), cpp11::as_cpp>(pattern), cpp11::as_cpp>(channel), cpp11::as_cpp>(row))); - END_CPP11 -} -// pt_cell.cpp -SEXP pt_set_eff_command_(list mod, integers pattern, integers channel, integers row, raws replacement, bool warn); -extern "C" SEXP _ProTrackR2_pt_set_eff_command_(SEXP mod, SEXP pattern, SEXP channel, SEXP row, SEXP replacement, SEXP warn) { - BEGIN_CPP11 - return cpp11::as_sexp(pt_set_eff_command_(cpp11::as_cpp>(mod), cpp11::as_cpp>(pattern), cpp11::as_cpp>(channel), cpp11::as_cpp>(row), cpp11::as_cpp>(replacement), cpp11::as_cpp>(warn))); - END_CPP11 -} -// pt_cell.cpp strings pt_rawcell_as_char_(raws pattern, strings padding, strings empty_char, list sformat); extern "C" SEXP _ProTrackR2_pt_rawcell_as_char_(SEXP pattern, SEXP padding, SEXP empty_char, SEXP sformat) { BEGIN_CPP11 @@ -194,20 +145,6 @@ extern "C" SEXP _ProTrackR2_pt_encode_compact_cell(SEXP source) { return cpp11::as_sexp(pt_encode_compact_cell(cpp11::as_cpp>(source))); END_CPP11 } -// pt_cell.cpp -raws celllist_to_raw_(list celllist, bool compact); -extern "C" SEXP _ProTrackR2_celllist_to_raw_(SEXP celllist, SEXP compact) { - BEGIN_CPP11 - return cpp11::as_sexp(celllist_to_raw_(cpp11::as_cpp>(celllist), cpp11::as_cpp>(compact))); - END_CPP11 -} -// pt_cell.cpp -r_string replace_cells_(list pattern, integers_matrix<> idx, raws replacement); -extern "C" SEXP _ProTrackR2_replace_cells_(SEXP pattern, SEXP idx, SEXP replacement) { - BEGIN_CPP11 - return cpp11::as_sexp(replace_cells_(cpp11::as_cpp>(pattern), cpp11::as_cpp>>(idx), cpp11::as_cpp>(replacement))); - END_CPP11 -} // pt_cleanup.cpp SEXP pt_cleanup_(); extern "C" SEXP _ProTrackR2_pt_cleanup_() { @@ -274,8 +211,7 @@ extern "C" SEXP _ProTrackR2_mod_set_sample_(SEXP mod, SEXP idx, SEXP smp_data) { extern "C" { static const R_CallMethodDef CallEntries[] = { - {"_ProTrackR2_celllist_to_raw_", (DL_FUNC) &_ProTrackR2_celllist_to_raw_, 2}, - {"_ProTrackR2_cells_as_raw_", (DL_FUNC) &_ProTrackR2_cells_as_raw_, 6}, + {"_ProTrackR2_cells_as_raw_", (DL_FUNC) &_ProTrackR2_cells_as_raw_, 5}, {"_ProTrackR2_mod_as_raw_", (DL_FUNC) &_ProTrackR2_mod_as_raw_, 1}, {"_ProTrackR2_mod_duration", (DL_FUNC) &_ProTrackR2_mod_duration, 3}, {"_ProTrackR2_mod_length_", (DL_FUNC) &_ProTrackR2_mod_length_, 1}, @@ -289,23 +225,15 @@ static const R_CallMethodDef CallEntries[] = { {"_ProTrackR2_note_to_period_", (DL_FUNC) &_ProTrackR2_note_to_period_, 3}, {"_ProTrackR2_open_mod_", (DL_FUNC) &_ProTrackR2_open_mod_, 1}, {"_ProTrackR2_open_samp_", (DL_FUNC) &_ProTrackR2_open_samp_, 1}, - {"_ProTrackR2_pt_cell_", (DL_FUNC) &_ProTrackR2_pt_cell_, 4}, {"_ProTrackR2_pt_cell_bytesize", (DL_FUNC) &_ProTrackR2_pt_cell_bytesize, 0}, {"_ProTrackR2_pt_cleanup_", (DL_FUNC) &_ProTrackR2_pt_cleanup_, 0}, {"_ProTrackR2_pt_decode_compact_cell", (DL_FUNC) &_ProTrackR2_pt_decode_compact_cell, 1}, - {"_ProTrackR2_pt_eff_command_", (DL_FUNC) &_ProTrackR2_pt_eff_command_, 4}, {"_ProTrackR2_pt_encode_compact_cell", (DL_FUNC) &_ProTrackR2_pt_encode_compact_cell, 1}, {"_ProTrackR2_pt_get_PAL_hz", (DL_FUNC) &_ProTrackR2_pt_get_PAL_hz, 0}, {"_ProTrackR2_pt_init_", (DL_FUNC) &_ProTrackR2_pt_init_, 0}, - {"_ProTrackR2_pt_instr_", (DL_FUNC) &_ProTrackR2_pt_instr_, 4}, - {"_ProTrackR2_pt_note_string_", (DL_FUNC) &_ProTrackR2_pt_note_string_, 4}, {"_ProTrackR2_pt_note_string_raw_", (DL_FUNC) &_ProTrackR2_pt_note_string_raw_, 1}, {"_ProTrackR2_pt_rawcell_as_char_", (DL_FUNC) &_ProTrackR2_pt_rawcell_as_char_, 4}, - {"_ProTrackR2_pt_set_eff_command_", (DL_FUNC) &_ProTrackR2_pt_set_eff_command_, 6}, - {"_ProTrackR2_pt_set_instr_", (DL_FUNC) &_ProTrackR2_pt_set_instr_, 6}, - {"_ProTrackR2_pt_set_note_", (DL_FUNC) &_ProTrackR2_pt_set_note_, 6}, {"_ProTrackR2_render_mod_", (DL_FUNC) &_ProTrackR2_render_mod_, 4}, - {"_ProTrackR2_replace_cells_", (DL_FUNC) &_ProTrackR2_replace_cells_, 3}, {"_ProTrackR2_sample_file_format_", (DL_FUNC) &_ProTrackR2_sample_file_format_, 2}, {"_ProTrackR2_set_mod_length_", (DL_FUNC) &_ProTrackR2_set_mod_length_, 2}, {"_ProTrackR2_set_mod_name_", (DL_FUNC) &_ProTrackR2_set_mod_name_, 2}, diff --git a/src/patterns.cpp b/src/patterns.cpp index 45b3cd3..89d3d3b 100644 --- a/src/patterns.cpp +++ b/src/patterns.cpp @@ -6,7 +6,7 @@ using namespace cpp11; [[cpp11::register]] -SEXP cells_as_raw_(SEXP mod, int pattern, bool compact, bool as_pattern, +SEXP cells_as_raw_(SEXP mod, int pattern, bool compact, int row, int channel) { module_t *my_song = get_mod(mod); @@ -18,13 +18,6 @@ SEXP cells_as_raw_(SEXP mod, int pattern, bool compact, bool as_pattern, int result_size; int cell_count = MOD_ROWS*PAULA_VOICES; int offset = 0; - if (!as_pattern) { - if (channel < 0 || channel > PAULA_VOICES || - row < 0 || row > MOD_ROWS) - stop("Index out of range!"); - offset = row*PAULA_VOICES + channel; - cell_count = 1; - } pat += offset; if (compact) result_size = cell_count*4; else result_size = cell_count*sizeof(note_t); writable::raws patdat((R_xlen_t)result_size); diff --git a/src/pt_cell.cpp b/src/pt_cell.cpp index 12904c8..b5c1636 100644 --- a/src/pt_cell.cpp +++ b/src/pt_cell.cpp @@ -13,47 +13,6 @@ int pt_cell_bytesize() { return (sizeof(note_t)); } -note_t * pt_cell_internal(SEXP mod, int pattern, int channel, int row) { - module_t *my_song = get_mod(mod); - if (channel < 0 || channel >= PAULA_VOICES) - stop("Channel index out of range"); - if (row < 0 || row >= MOD_ROWS) - stop("Row index out of range"); - note_t *pat = my_song->patterns[pattern]; - note_t *cell = & pat[channel + row * PAULA_VOICES]; - return cell; -} - -[[cpp11::register]] -list pt_cell_(SEXP mod, int pattern, int channel, int row) { - note_t * cell = pt_cell_internal(mod, pattern, channel, row); - - writable::strings cellnames ({ - "param", "sample", "command", "period", "note", "note_nm" - }); - writable::list result({ - as_sexp((int)cell->param), - as_sexp((int)cell->sample), - as_sexp((int)cell->command), - as_sexp((int)cell->period), - as_sexp((int)periodToNote(cell->period)), - r_string(noteNames1[periodToNote(cell->period)]) - }); - result.attr("names") = cellnames; - return result; -} - -int cell_check_input( - list mod, integers pattern, integers channel, integers row) { - int input_size = pattern.size(); - if (input_size < 1 || - channel.size() != input_size || - row.size() != input_size || - LENGTH(mod) != input_size) - stop("All input should have the same size"); - return input_size; -} - [[cpp11::register]] integers note_to_period_(strings note, std::string empty_char, int finetune) { if (empty_char.length() != 1) @@ -83,22 +42,6 @@ integers note_to_period_(strings note, std::string empty_char, int finetune) { return result; } -[[cpp11::register]] -strings pt_note_string_( - list mod, integers pattern, integers channel, integers row) { - int input_size = cell_check_input(mod, pattern, channel, row); - - writable::strings result((R_xlen_t)pattern.size()); - - for (int i = 0; i < input_size; i++) { - note_t * note = pt_cell_internal(mod.at(i), pattern.at(i), channel.at(i), row.at(i)); - std::string notestr(noteNames1[periodToNote(note->period)]); - result.at(i) = notestr; - } - - return result; -} - [[cpp11::register]] std::string pt_note_string_raw_(raws data) { note_t * note = (note_t *)(RAW(as_sexp(data))); @@ -106,121 +49,6 @@ std::string pt_note_string_raw_(raws data) { return notestr; } -[[cpp11::register]] -SEXP pt_set_note_( - list mod, integers pattern, integers channel, integers row, strings replacement, - bool warn) { - int input_size = cell_check_input(mod, pattern, channel, row); - integers replacement_int = note_to_period_(replacement, std::string("-"), 0); - - int j = 0; - bool all_used = false; - bool recycled = false; - for (int i = 0; i < input_size; i++) { - if (j + 1 > replacement.size()) { - j = 0; - recycled = true; - } - note_t * note = pt_cell_internal(mod.at(i), pattern.at(i), channel.at(i), row.at(i)); - int rep = replacement_int.at(j); - if (rep == NA_INTEGER) rep = 0; - note->period = rep; - j++; - if (j + 1 >= replacement.size()) all_used = true; - } - if (warn) { - if (!all_used) warning("Not all replacement values are used"); - if (recycled) warning("Replacement values are recycled"); - } - return R_NilValue; -} - -[[cpp11::register]] -integers pt_instr_( - list mod, integers pattern, integers channel, integers row) { - int input_size = cell_check_input(mod, pattern, channel, row); - - writable::integers result((R_xlen_t)pattern.size()); - - for (int i = 0; i < input_size; i++) { - note_t * note = pt_cell_internal(mod.at(i), pattern.at(i), channel.at(i), row.at(i)); - result.at(i) = note->sample; - } - - return result; -} - -[[cpp11::register]] -SEXP pt_set_instr_( - list mod, integers pattern, integers channel, integers row, integers replacement, - bool warn) { - int input_size = cell_check_input(mod, pattern, channel, row); - - int j = 0; - bool all_used = false; - bool recycled = false; - for (int i = 0; i < input_size; i++) { - if (j + 1 > replacement.size()) { - j = 0; - recycled = true; - } - note_t * note = pt_cell_internal(mod.at(i), pattern.at(i), channel.at(i), row.at(i)); - note->sample = replacement.at(j); - j++; - if (j + 1 >= replacement.size()) all_used = true; - } - if (warn) { - if (!all_used) warning("Not all replacement values are used"); - if (recycled) warning("Replacement values are recycled"); - } - return R_NilValue; -} - -[[cpp11::register]] -raws pt_eff_command_( - list mod, integers pattern, integers channel, integers row) { - int input_size = cell_check_input(mod, pattern, channel, row); - - writable::raws result((R_xlen_t)2*pattern.size()); - - for (int i = 0; i < input_size; i++) { - note_t * note = pt_cell_internal(mod.at(i), pattern.at(i), channel.at(i), row.at(i)); - result.at(i*2) = note->command; - result.at(i*2 + 1) = note->param; - } - result.attr("class") = "pt2command"; - return result; -} - -[[cpp11::register]] -SEXP pt_set_eff_command_( - list mod, integers pattern, integers channel, integers row, raws replacement, - bool warn) { - int input_size = cell_check_input(mod, pattern, channel, row); - - if (replacement.size() % 2 != 0) - stop("Replacement value should consist of a multitude of 2 raws."); - int j = 0; - bool all_used = false; - bool recycled = false; - for (int i = 0; i < input_size; i++) { - if (j*2 + 1 > replacement.size()) { - j = 0; - recycled = true; - } - note_t * note = pt_cell_internal(mod.at(i), pattern.at(i), channel.at(i), row.at(i)); - note->command = replacement.at(j*2); - note->param = replacement.at(j*2 + 1); - j++; - if (j*2 + 1 >= replacement.size()) all_used = true; - } - if (warn) { - if (!all_used) warning("Not all replacement values are used"); - if (recycled) warning("Replacement values are recycled"); - } - return R_NilValue; -} - SEXP pt_cell_as_char_internal( note_t *cell, int offset, strings padding, strings empty, list sformat) { if (padding.size() < 1 || empty.size() < 1) @@ -286,14 +114,6 @@ SEXP pt_cell_as_char_internal( return result_r; } -SEXP pt_cell_as_char_( - SEXP mod, int pattern, int channel, int row, strings padding, - strings empty_char, list sformat) { - note_t * cell = pt_cell_internal(mod, pattern, channel, row); - - return pt_cell_as_char_internal(cell, 0, padding, empty_char, sformat); -} - [[cpp11::register]] strings pt_rawcell_as_char_(raws pattern, strings padding, strings empty_char, list sformat) { note_t * cell = (note_t *)RAW(as_sexp(pattern)); @@ -338,80 +158,3 @@ void pt_encode_compact_cell_internal(note_t * source, uint8_t * dest, uint32_t n cellCompacter(source, dest, n_notes); return; } - -[[cpp11::register]] -raws celllist_to_raw_(list celllist, bool compact) { - int size_out = celllist.size(); - if (compact) size_out *= 4; - else size_out *= sizeof(note_t); - - writable::raws data_out((R_xlen_t)size_out); - uint8_t * celldst = (uint8_t *)RAW(as_sexp(data_out)); - int nr = integers(celllist.attr("celldim"))[0]; - int nc = integers(celllist.attr("celldim"))[1]; - for (int i = 0; i < celllist.size(); i++) { - SEXP element = celllist.at(i); - if (!Rf_inherits(element, "pt2cell")) stop("Invalid pt2celllist."); - if (TYPEOF(element) == RAWSXP) { - stop("Raw to raw is not implemented in C++. Contact package maintainer if you see this error"); - } else { - - list cell = list(element); - SEXP mod = cell["mod"]; - module_t *my_song = get_mod(mod); - note_t * pat = my_song->patterns[integers(cell["i"]).at(0)]; - pat += (integers(cell["k"]).at(0) + integers(cell["j"]).at(0)*PAULA_VOICES); - if (compact) { - pt_encode_compact_cell_internal(pat, celldst, 1); - celldst += 4; - } else { - memcpy(celldst, pat, sizeof(note_t)); - celldst += sizeof(note_t); - } - } - } - data_out.attr("class") = "pt2celllist"; - data_out.attr("celldim") = writable::integers({nr, nc}); - data_out.attr("compact_notation") = compact; - return data_out; -} - -[[cpp11::register]] -r_string replace_cells_(list pattern, integers_matrix<> idx, raws replacement) { - if (idx.slice_size() < 1L) - stop("Need at least one element to replace"); - if ((uint32_t)replacement.size() < sizeof(note_t) || - replacement.size() % sizeof(note_t) != 0) - stop("Insufficient replacement data"); - - module_t *my_song = get_mod(pattern["mod"]); - uint32_t i = integers(pattern["i"]).at(0); - if (i > MAX_PATTERNS) stop("Index out of range"); - note_t * pat_base = my_song->patterns[i]; - note_t * source = (note_t *)RAW(replacement); - - uint32_t m = 0; // replacement index - bool recycled = false; - bool unused = true; - for (int32_t l = 0; l < idx.slice_size(); l++) { - if (m == 0 && l != 0) recycled = true; - uint32_t j = idx(l, 0); - uint32_t k = idx(l, 1); - if (j >= MOD_ROWS || k >= PAULA_VOICES) - stop("Cell index out of range"); - note_t * target = pat_base + j * PAULA_VOICES + k; - note_t * src = source + m; - memcpy(target, src, sizeof(note_t)); - m++; - if ((int)(m * sizeof(note_t)) >= replacement.size()) { - m = 0; // Recycle replacement values; - unused = false; - } - } - - if (unused) { - return "Not all replacement values used"; - } else if (recycled) { - return "Replacement values are recycled"; - } else return ""; -} diff --git a/tests/testthat/test_misc.R b/tests/testthat/test_misc.R index 7cdbdf7..75249a1 100644 --- a/tests/testthat/test_misc.R +++ b/tests/testthat/test_misc.R @@ -7,9 +7,11 @@ test_that("Can add a 100th pattern to a mod", { }) }) -test_that("Commands can be extracted", { +test_that("Commands can be extracted and assigned", { expect_no_error({ comm <- pt2_command(mod$patterns[[1]][]) pt2_command(comm) + comm[] + comm[[1]] <- "111" }) }) \ No newline at end of file diff --git a/tests/testthat/test_sample.R b/tests/testthat/test_sample.R index 28af2c5..a6bd6a0 100644 --- a/tests/testthat/test_sample.R +++ b/tests/testthat/test_sample.R @@ -74,3 +74,9 @@ test_that("You can select a subset of samples", { mod$samples[1:2] |> length() }, 2L) }) + +test_that("Sample from demo mod is valid", { + expect_true({ + pt2_validate(mod$samples[[1]]) + }) +}) From c0f4584b32ba961870e5e2342b6462391499daca Mon Sep 17 00:00:00 2001 From: pepijn-devries Date: Mon, 10 Nov 2025 17:27:39 +0100 Subject: [PATCH 6/7] fixed sample wav reader/writer --- src/pt2-clone/smploaders/pt2_load_wav.c | 9 +++++++-- src/samp_io.cpp | 2 +- tests/testthat/test_cell.R | 2 -- 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/src/pt2-clone/smploaders/pt2_load_wav.c b/src/pt2-clone/smploaders/pt2_load_wav.c index df26dd7..05eb08e 100644 --- a/src/pt2-clone/smploaders/pt2_load_wav.c +++ b/src/pt2-clone/smploaders/pt2_load_wav.c @@ -29,11 +29,13 @@ bool loadWAVSample2(uint8_t *input, uint32_t filesize, moduleSample_t * s, int8_ uint32_t xtraPtr = 0; uint32_t xtraLen = 0; uint32_t smplPtr = 0; uint32_t smplLen = 0; - uint32_t pos = 12; + uint32_t pos = 12; + if (pos > filesize) return false; uint32_t bytesRead = 0; while (bytesRead < (uint32_t)filesize-12) { uint32_t chunkID, chunkSize; + if ((pos + 8) > filesize) return false; chunkID = ((uint32_t *)(input + pos))[0]; chunkSize = ((uint32_t *)(input + pos + 4))[0]; pos += 8; @@ -58,6 +60,7 @@ bool loadWAVSample2(uint8_t *input, uint32_t filesize, moduleSample_t * s, int8_ { if (chunkSize >= 4) { + if ((pos + 4) > filesize) return false; chunkID = ((uint32_t *)(input + pos))[0]; pos += 4; if (chunkID == 0x4F464E49) // "INFO" @@ -65,6 +68,7 @@ bool loadWAVSample2(uint8_t *input, uint32_t filesize, moduleSample_t * s, int8_ bytesRead = 0; while (bytesRead < chunkSize) { + if ((pos + 8) > filesize) return false; chunkID = ((uint32_t *)(input + pos))[0]; chunkSize = ((uint32_t *)(input + pos + 4))[0]; pos += 8; @@ -105,7 +109,7 @@ bool loadWAVSample2(uint8_t *input, uint32_t filesize, moduleSample_t * s, int8_ default: break; } - bytesRead += chunkSize + (chunkSize & 1); + bytesRead += 8 + chunkSize + (chunkSize & 1); pos = endOfChunk; } @@ -114,6 +118,7 @@ bool loadWAVSample2(uint8_t *input, uint32_t filesize, moduleSample_t * s, int8_ return false; // ---- READ "fmt " CHUNK ---- + if ((fmtPtr + 18) > filesize) return false; audioFormat = ((uint16_t *)(input + fmtPtr))[0]; numChannels = ((uint16_t *)(input + fmtPtr + 2))[0]; sampleRate = ((uint32_t *)(input + fmtPtr + 4))[0]; diff --git a/src/samp_io.cpp b/src/samp_io.cpp index 0801a14..0594e38 100644 --- a/src/samp_io.cpp +++ b/src/samp_io.cpp @@ -164,7 +164,7 @@ raws sample_file_format_(SEXP input, std::string file_type) { // set ModPlug Tracker chunk (used for sample volume only in this case) wavHeader.chunkSize += sizeof (mptExtraChunk); mptExtraChunk.chunkID = 0x61727478; // "xtra" - mptExtraChunk.chunkSize = sizeof (mptExtraChunk) - 4 - 4; + mptExtraChunk.chunkSize = sizeof (mptExtraChunk) - 2*sizeof(uint32_t); // -8 because it doesn't include chunkID and chunkSize mptExtraChunk.defaultPan = 128; // 0..255 mptExtraChunk.defaultVolume = volume * 4; // 0..256 mptExtraChunk.globalVolume = 64; // 0..64 diff --git a/tests/testthat/test_cell.R b/tests/testthat/test_cell.R index 679f06c..9267f2c 100644 --- a/tests/testthat/test_cell.R +++ b/tests/testthat/test_cell.R @@ -15,5 +15,3 @@ test_that("Dash can be missing when coercing to pt2cell", { as_pt2celllist("C201A10") |> as.character() }, "C-2 01 A10") }) - -as_pt2cell("C201A10") |> as.character() \ No newline at end of file From 806a2fe89cfe39a745e975518f8d590b71ce94f3 Mon Sep 17 00:00:00 2001 From: pepijn-devries Date: Mon, 10 Nov 2025 21:21:33 +0100 Subject: [PATCH 7/7] removed redundant code --- src/samples.cpp | 20 -------------------- tests/testthat/test_io.R | 1 + 2 files changed, 1 insertion(+), 20 deletions(-) diff --git a/src/samples.cpp b/src/samples.cpp index 5e06f2e..9bfdf74 100644 --- a/src/samples.cpp +++ b/src/samples.cpp @@ -53,32 +53,12 @@ raws mod_sample_as_raw_(SEXP mod, int idx) { return mod_sample_as_raw_internal(my_song, idx); } -integers mod_sample_as_int_internal(module_t * my_song, int idx) { - moduleSample_t * samp = get_mod_sampinf_internal(my_song, idx); - int8_t *sampleData = &my_song->sampleData[samp->offset]; - uint32_t len = samp->length; - writable::integers sampledata((R_xlen_t)len); - for (uint32_t j = 0; j < len; j++) { - sampledata.at((int)j) = (int)sampleData[j]; - } - - SEXP attr = mod_sample_info_internal(my_song, idx); - sampledata.attr("sample_info") = attr; - return sampledata; -} - [[cpp11::register]] list mod_sample_info_(SEXP mod, int idx) { module_t *my_song = get_mod(mod); return mod_sample_info_internal(my_song, idx); } -[[cpp11::register]] -integers mod_sample_as_int_(SEXP mod, int idx) { - module_t *my_song = get_mod(mod); - return mod_sample_as_int_internal(my_song, idx); -} - [[cpp11::register]] logicals validate_sample_raw_(raws smp_data) { bool result = true; diff --git a/tests/testthat/test_io.R b/tests/testthat/test_io.R index f7ed59a..6e58d71 100644 --- a/tests/testthat/test_io.R +++ b/tests/testthat/test_io.R @@ -20,6 +20,7 @@ test_that("Writing raw samples will warn user", { }) test_that("Reading sample works", { + skip_if_offline() expect_no_error({ samp_raw <- pt2_read_sample(smpfile_raw) samp_iff <- pt2_read_sample(smpfile_iff)