improved test coverage

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",

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)

NEWS.md

@@ -1,4 +1,4 @@
-ProTrackR2 v0.0.6.0012
+ProTrackR2 v0.0.6.0013
 -------------
 
  * Implemented `as_pt2cell()` and `as_pt2celllist()`

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
 }
 
@@ -96,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, ...) {

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_`)
 }

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)
 }
 
@@ -228,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)
   }
 }
 
@@ -271,17 +263,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 +279,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 +369,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")) {

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