R/noteinfo.R

Defines functions .tabr_print2 summary.noteinfo print.noteinfo .check_noteinfo is_noteinfo as_noteinfo .asni informable .parse_info info_articulation info_annotation info_double_dotted info_single_dotted info_dotted info_bend info_slide info_slur_off info_slur_on info_duration

Documented in as_noteinfo info_annotation info_articulation info_bend info_dotted info_double_dotted info_duration informable info_single_dotted info_slide info_slur_off info_slur_on is_noteinfo

#' Note info helpers
#'
#' Functions for working with note info strings.
#'
#' If `x` is a phrase object, there are some parsing limitations such as tuplets
#' and repeats.
#'
#' @param x character, note info string normally accompanying a noteworthy
#' string for building phrase objects. `x` may also be a phrase object.
#'
#' @return character
#' @export
#' @name noteinfo
#' @seealso [valid-noteinfo()]
#'
#' @examples
#' a <- notate("t8x", "Start here")
#' notes <- "a, b, c d e f g# a r ac'e' a c' e' c' r*3 ac'e'~ ac'e'"
#' info <- paste(a, "t8x t8-. 16 4.. 16- 16 2^ 2 4. 8( 4)( 4) 8*4 1 1")
#' x <- as_music(notes, info)
#'
#' data.frame(
#'   duration = info_duration(x),
#'   slur_on = info_slur_on(x),
#'   slur_off = info_slur_off(x),
#'   slide = info_slide(x),
#'   bend = info_bend(x),
#'   dotted = info_dotted(x),
#'   dotted1 = info_single_dotted(x),
#'   dotted2 = info_double_dotted(x),
#'   annotation = info_annotation(x),
#'   articulation = info_articulation(x)
#' )
info_duration <- function(x){
  .asni(gsub("^([t0-9\\.]+).*", "\\1", .parse_info(x)))
}

#' @export
#' @rdname noteinfo
info_slur_on <- function(x){
  grepl("\\(", .parse_info(x))
}

#' @export
#' @rdname noteinfo
info_slur_off <- function(x){
  grepl("\\)", .parse_info(x))
}

#' @export
#' @rdname noteinfo
info_slide <- function(x){
  grepl("-([^->\\^_!\\.\\+]|$)", .parse_info(x))
}

#' @export
#' @rdname noteinfo
info_bend <- function(x){
  grepl("[^-;]\\^", .parse_info(x))
}

#' @export
#' @rdname noteinfo
info_dotted <- function(x){
  grepl("[^-]\\.{1,2}", .parse_info(x))
}

#' @export
#' @rdname noteinfo
info_single_dotted <- function(x){
  info_dotted(x) & !info_double_dotted(x)
}

#' @export
#' @rdname noteinfo
info_double_dotted <- function(x){
  grepl("[^-]\\.{2}", .parse_info(x))
}

#' @export
#' @rdname noteinfo
info_annotation <- function(x){
  if(inherits(x, "phrase")){
    x <- phrase_info(x, FALSE)
  } else if(inherits(x, "music")){
    x <- .uncollapse(music_info(x))
  } else {
    x <- .uncollapse(x)
  }
  y <- rep(NA_character_, length(x))
  idx <- grep(";\\^\".*\"", x)
  if(length(idx)) y[idx] <- gsub(".*;\\^\"(.*)\"", "\\1", x[idx])
  gsub("_", " ", y)
}

#' @export
#' @rdname noteinfo
info_articulation <- function(x){
  if(inherits(x, "phrase")){
    x <- phrase_info(x, FALSE)
  } else if(inherits(x, "music")){
    x <- .uncollapse(music_info(x))
  } else {
    x <- .uncollapse(x)
  }
  y <- rep(NA_character_, length(x))
  idx <- grep("-([->\\^_!\\.\\+])", x)
  if(length(idx)) y[idx] <- gsub(".*(-[->\\^_!\\.\\+]).*", "\\1", x[idx])
  idx <- grep("\\[[a-z]+\\]", x)
  if(length(idx)) y[idx] <- gsub(".*\\[([a-z]+)\\]", "\\1", x[idx])
  y
}

.parse_info <- function(x){
  if(inherits(x, "phrase")){
    phrase_info(x, FALSE, FALSE)
  } else if(inherits(x, "music")){
    .uncollapse(music_info(x))
  } else {
    .uncollapse(x)
  }
}

#' Check note info validity
#'
#' Check whether a note info string is comprised exclusively of valid note info
#' syntax.
#' `noteinfo` returns a scalar logical result indicating whether the entire set
#' contains exclusively valid entries.
#'
#' `as_noteinfo()` can be used to coerce to the `noteinfo` class.
#' Coercion will fail if the string is has any syntax that is not valid for
#' note info.
#' Using the `noteinfo` class is generally not needed by the user during
#' an interactive session, but is available and offers its own `print()` and
#' `summary()` methods for note info strings.
#' The class is often used by other functions, and functions that output a
#' note info string attach the `noteinfo` class.
#'
#' When `format = NULL`, the timestep delimiter format is inferred from the note
#' info string input. When unclear, such as with phrase objects, the default is
#' space-delimited time.
#'
#' @param x character, a note info string.
#' @param format `NULL` or character, the timestep delimiter format, `"space"`
#' or `"vector"`.
#' @param na.rm remove `NA`s.
#'
#' @return depends on the function
#' @export
#' @name valid-noteinfo
#' @seealso [noteinfo()], [valid-notes()]
#'
#' @examples
#' a <- notate("8x", "Start here")
#' x <- paste(a, "8[stacatto] 8-. 16 4.. 16- 16 2^ 2 4. 8( 4)( 4) 8*4 1 1")
#'
#' informable(x) # is it of 'noteinfo' class; a validity check for any string
#' x <- as_noteinfo(x) # coerce to 'noteinfo' class
#' is_noteinfo(x) # check for 'noteinfo' class
#' x
#'
#' summary(x)
informable <- function(x, na.rm = FALSE){
  if(is_noteinfo(x)) return(TRUE)
  if(na.rm){
    x <- x[!is.na(x)]
    if(!is.character(x)) x <- as.character(x)
  }
  x <- .uncollapse(x)
  if(!length(x) | any(x == "")) return(FALSE)
  x <- gsub("\\[[a-z]+\\]|;\\^\".*\"", "", x)
  durations <- gsub("^(t|)(\\d+|).*", "\\2", x)
  if(!all(durations %in% c(1, 2, 4, 8, 16, 32))) return(FALSE)
  x <- gsub("t\\d+|[123468\\(\\)\\.\\^x]+|-[->\\^_!\\.\\+]|-", "", x)
  if(all(x == "")) TRUE else FALSE
}

.asni <- function(x, format = NULL){
  if(is.null(format)) format <- .infer_time_format(x)
  format <- switch(format, space = "space-delimited time",
                   vector = "vectorized time")
  x <- .uncollapse(x)
  steps <- length(x)
  if(format == "space-delimited time") x <- paste(x, collapse = " ")
  attributes(x) <- list(steps = steps, format = format)
  class(x) <- unique(c("noteinfo", class(x)))
  x
}

#' @export
#' @rdname valid-noteinfo
as_noteinfo <- function(x, format = NULL){
  if(inherits(x, "noteinfo") & is.null(format)) return(x)
  .check_noteinfo(x)
  .check_format_arg(format)
  .asni(x, format)
}

#' @export
#' @rdname valid-noteinfo
is_noteinfo <- function(x){
  "noteinfo" %in% class(x)
}

.check_noteinfo <- function(x, na.rm = FALSE){
  if(!informable(x, na.rm)) stop("Invalid note info found.", call. = FALSE)
}

#' @export
print.noteinfo <- function(x, ...){
  a <- attributes(x)
  col1 <- crayon::make_style("gray50")
  col2 <- col1$bold
  if(length(as.character(x)) == 1) x <- .uncollapse(x)
  cat(col2("<Note info string>\n  Format: "), a$format, col2("\n  Values: "),
      col1(.tabr_print2(x)), "\n", sep = "")
}

#' @export
summary.noteinfo <- function(object, ...){
  a <- attributes(object)
  col1 <- crayon::make_style("gray50")
  col2 <- col1$bold
  cat(col2("<Note info string>\n  Timesteps: "), a$steps,
      col2("\n  Format: "), a$format, col2("\n  Values: "),
      col1(.tabr_print2(.uncollapse(as.character(object)))), "\n", sep = "")
}

.tabr_print2 <- function(x){
  durations <- crayon::make_style("dodgerblue")$bold
  other_info <- crayon::make_style("orange2")
  x <- gsub("^(t\\d+|\\d+|\\d+\\.+)", durations("\\1"), x)
  x <- gsub("(\\(|\\)|;\\^|\\^|x|-([->\\^_!\\.\\+]|)|\\[[a-z]+\\])",
            other_info("\\1"), x)
  paste(x, collapse = " ")
}

Try the tabr package in your browser

Any scripts or data that you put into this service are public.

tabr documentation built on Sept. 21, 2023, 5:06 p.m.