From d9940574f434935aa2e0e015935c878ec494981b Mon Sep 17 00:00:00 2001 From: Juan Pablo Date: Mon, 9 Dec 2024 16:18:10 -0500 Subject: [PATCH] not verifying readme update --- .Rhistory | 20 +-- NAMESPACE | 3 +- R/{seq_data_nl.R => interpolate.R} | 19 +-- R/seq_nl.R | 14 +- R/set_S4_class.R | 239 ++++++++++++++++++++++++++++ R/utils.R | 25 ++- README.Rmd | 4 +- man/{seq_data.Rd => interpolate.Rd} | 15 +- 8 files changed, 290 insertions(+), 49 deletions(-) rename R/{seq_data_nl.R => interpolate.R} (96%) create mode 100644 R/set_S4_class.R rename man/{seq_data.Rd => interpolate.Rd} (90%) diff --git a/.Rhistory b/.Rhistory index c7dd740..b546eea 100644 --- a/.Rhistory +++ b/.Rhistory @@ -1,13 +1,3 @@ -smooth_fashion, -#---- --- ---- --- ---- --- ---- --- ----- --- ----# -# Notice how we use base '2' and exponentiate as -# polynomial increases by n. You can use any base you -# like, I chose 2 because that's what I've seen others -# do, and it's the standard as far as I know. -quad_in = t^2, -quad_out = 1-(1 - t)^2, -quad_in_out = ifelse(t < 0.5, -2*t^2, 1 - 0.5*(-2*t+2)^2), #---- --- ---- --- ---- --- ---- --- ----- --- ----# cubic_in = t^3, @@ -510,3 +500,13 @@ plot(seq_data(rnorm(100,23,12),type = "step",ease = "in_out")) seq_data(rpois(100,3), type = "circle",ease = "in_out") plot(seq_data(rpois(100,3), type = "circle",ease = "in_out")) devtools::document() +devtools::document() +devtools::document() +devtools::load_all() +interpolate(daa.frame(1:10,21:30),type = "linear") +interpolate(daa.frame(1:10,21:30),type = "linear") +interpolate(data.frame(1:10,21:30),type = "linear") +summary(airquality) +interpolate(na.omit(airquality),type = "linear") +points(interpolate(na.omit(airquality),type = "bounce","in_out")) +plot(interpolate(na.omit(airquality),type = "bounce","in_out")) diff --git a/NAMESPACE b/NAMESPACE index 17bbb39..7359851 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,4 @@ # Generated by roxygen2: do not edit by hand -export(seq_data) +export(interpolate) export(seq_smooth) -importFrom(stats,approx) diff --git a/R/seq_data_nl.R b/R/interpolate.R similarity index 96% rename from R/seq_data_nl.R rename to R/interpolate.R index b05b5a7..bf3401a 100644 --- a/R/seq_data_nl.R +++ b/R/interpolate.R @@ -46,29 +46,29 @@ #' #' @examples #' # Generate a linear sequence -#' seq_data(1:10, type = "linear") +#' interpolate(1:10, type = "linear") #' #' # Generate a quadratic easing sequence -#' seq_data(rnorm(100,14,5), type = "quad", ease = "in_out") +#' interpolate(rnorm(100,14,5), type = "quad", ease = "in_out") #' #' # Generate a stepped sequence with 5 steps -#' seq_data(rpois(100,3), type = "step", step_count = 5) +#' interpolate(rpois(100,3), type = "step", step_count = 5) #' #' @note #' This function supports various easing functions commonly used in animations and graphics, as well as #' stepped sequences for discrete transitions. Invalid or unsupported inputs will result in informative #' error messages or warnings. #' -#' @importFrom stats approx +#' @seealso [func(approx)] #' @export -seq_data <- function(data, +interpolate <- function(data, type = "linear", step_count = NULL, ease = NULL){ stopifnot(is.character(type), - is.numeric(data) || is.matrix(data) || is.data.frame(data) || is.list(data)) + is.numeric(data) || is.matrix(data) || is.data.frame(data) || is.list(data) || is.sequence(data)) if(!is.null(ease)) if(!is.character(ease)) @@ -82,7 +82,7 @@ seq_data <- function(data, # Time could be any range, but it complicates comparison if # time range is not bounded. However, you can always # normalize it to be bounded from [0,1] - if (is.numeric(data)) { + if (is.numeric(data)|| is.sequence(data)) { n <- length(data) } else if (is.data.frame(data) || is.matrix(data)) { n <- nrow(data) @@ -199,9 +199,10 @@ seq_data <- function(data, #---- --- ---- --- ---- --- ---- --- ----- --- ----# circle_in = 1 - sqrt(1-t^2), circle_out = sqrt(1 - (t - 1)^2), - circle_in_out = ifelse(t < 0.5, + # Supress warnings about NA's + circle_in_out = supressWarnings({ifelse(t < 0.5, (1 - sqrt(1 - (2 * t)^2)) / 2, - 0.5 * (sqrt(1 - (-2 * t + 2)^2) + 1)), + 0.5 * (sqrt(1 - (-2 * t + 2)^2) + 1))}), #---- --- ---- --- ---- --- ---- --- ----- --- ----# back_in = 2.70158*t^3 - 1.70158*t^2, back_out = 1 + 2.70158* (t-1)^3 + 1.70158*(t-1)^2, diff --git a/R/seq_nl.R b/R/seq_nl.R index 5564b56..e5796f6 100644 --- a/R/seq_nl.R +++ b/R/seq_nl.R @@ -111,7 +111,10 @@ stopifnot(is.character(type)) ease <- match.arg(ease, c("in", "out", "in_out")) } - # Compute normalized time + # Compute normalized time (t) as the y-component + # Time could be any range, but it complicates comparison if + # time range is not bounded. However, you can always + # normalize it to be bounded from [0,1] t <- seq(0, 1, length.out = n) # Linear sequence @@ -196,9 +199,10 @@ stopifnot(is.character(type)) #---- --- ---- --- ---- --- ---- --- ----- --- ----# circle_in = 1 - sqrt(1-t^2), circle_out = sqrt(1 - (t - 1)^2), - circle_in_out = ifelse(t < 0.5, + # Supress warnings about NA's + circle_in_out = supressWarnings({ifelse(t < 0.5, (1 - sqrt(1 - (2 * t)^2)) / 2, - 0.5 * (sqrt(1 - (-2 * t + 2)^2) + 1)), + 0.5 * (sqrt(1 - (-2 * t + 2)^2) + 1))}), #---- --- ---- --- ---- --- ---- --- ----- --- ----# back_in = 2.70158*t^3 - 1.70158*t^2, back_out = 1 + 2.70158* (t-1)^3 + 1.70158*(t-1)^2, @@ -270,5 +274,7 @@ stopifnot(is.character(type)) smooth_seq <- from + smooth_fashion * (to-from) - return(smooth_seq) + Sequence(values = smooth_seq, + type = type, + ease = ease) } diff --git a/R/set_S4_class.R b/R/set_S4_class.R new file mode 100644 index 0000000..f4b7c0e --- /dev/null +++ b/R/set_S4_class.R @@ -0,0 +1,239 @@ +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Initially working on making function output an S4 object of class 'sequence' +# but it limited the number of operations and type of manipulation offered for +# S3 objects. If I want to implement the same for an S4 object, it requires a +# whole lot of typing, and some obscure code that it's not so easy to understand. +# I'm leaving this here so I can continue working on it when time permits, and +# I feel in the mood for torture. + +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Create a class for non-linear sequence +methods::setClass("Sequence", + slots = c( + values = "numeric", + type = "character", + ease = "character", + steps = "numeric" + ), + prototype = list( + values = numeric(), + type = character(), + ease = character(), + steps = numeric() + ) + ) + +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Set setter and getter for `type` slot +methods::setGeneric("type", function(x) methods::standardGeneric("type")) +methods::setGeneric("type<-", function(x,value) methods::standardGeneric("type<-")) + +# Set setter and getter for `ease` slot +methods::setGeneric("ease", function(x) methods::standardGeneric("ease")) +methods::setGeneric("ease<-", function(x,value) methods::standardGeneric("ease<-")) + +# Set setter and getter fr `values` slot +methods::setGeneric("values", function(x) methods::standardGeneric("values")) +methods::setGeneric("values<-", function(x,value) methods::standardGeneric("values<-")) + +# Set setter and getter fr `steps` slot +methods::setGeneric("steps", function(x) methods::standardGeneric("steps")) +methods::setGeneric("steps<-", function(x,value) methods::standardGeneric("steps<-")) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Type +methods::setMethod("type","Sequence",function(x) x@type) +methods::setMethod("type<-","Sequence",function(x,value){ + x@type <- value + x +}) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Ease +methods::setMethod("ease","Sequence",function(x) x@ease) +methods::setMethod("ease<-","Sequence",function(x,value){ + x@ease <- value + x +}) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Steps +methods::setMethod("steps","Sequence",function(x) x@steps) +methods::setMethod("steps<-","Sequence",function(x,value){ + x@steps <- value + x + }) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Define method for 'min' +methods::setMethod("min", "Sequence", function(x) { + min(x@values) + }) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +#Define method for 'max' +methods::setMethod("max", "Sequence", + function(x, ..., na.rm = FALSE) { + max(x@values, ..., na.rm = na.rm) + }) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Define method for 'range' +methods::setMethod("range","Sequence", + function(x, ...,na.rm = TRUE) { + range(x@values, ...,na.rm = TRUE) + }) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Define method for 'IQR' +methods::setGeneric("IQR", function(x) standardGeneric("IQR")) +methods::setMethod("IQR","Sequence", + function(x) { + stats::IQR(x@values) + }) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Define method for sum +methods::setMethod("sum", "Sequence", function(x, ...) { + sum(x@values, ...) +}) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Method for subtraction between sequence and integer vector +methods::setMethod("-", c("Sequence","integer"), + function(e1,e2) { + e1@values <- e1@values - e2 + validObject(e1) # Validate the modified object + e1 + }) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Method for subtraction between two sequences +methods::setMethod("-",c(e1 = "Sequence", e2 = "Sequence"), + function(e1, e2) { + if (length(e1@values) != length(e2@values)) { + stop("The two Sequence objects must have the same length to perform subtraction") + } + e1@values <- e1@values - e2@values + validObject(e1) # Validate the modified object + e1 + }) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Define method for diff +methods::setMethod("diff", "Sequence", function(x, ...) { + diff(x@values, ...) + }) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Method for multiplication +methods::setMethod("*", c("Sequence", "numeric"), + function(e1, e2) { + e1@values <- e1@values * e2 + validObject(e1) # Validate the object before returning + e1 + }) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Method for division +methods::setMethod("/",c("Sequence", "numeric"), + function(e1, e2) { + if (any(e2 == 0)) + stop("Division by zero is not allowed") + e1@values <- e1@values / e2 + validObject(e1) # Validate the object before returning + e1 + }) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Method for exponentiation +methods::setMethod("^",c("Sequence", "numeric"), + function(e1, e2) { + e1@values <- e1@values ^ e2 + validObject(e1) # Validate the object before returning + e1 + }) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Method for logarithm +methods::setMethod("log",("Sequence"), + function(x, base = exp(1)) { + if (any(x@values <= 0)) stop("Logarithm is undefined for non-positive values") + x@values <- log(x@values, base = base) + validObject(x) # Validate the object before returning + x + }) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +methods::setMethod( "[",c("Sequence", "integer", "missing", "ANY"), + function(x, i, j, ..., drop = TRUE) { + # Access the `values` slot of the Sequence object + value <- x@values[i] + value + }) + +methods::setMethod("[[",c("Sequence", "integer", "missing"), + function(x, i, j, ...) { + # Access the `values` slot of the Sequence object + value <- x@values[[i]] + value + }) +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +methods::setMethod("summary", "Sequence", function(object, ...) { + # Calculate summary statistics for the `values` slot + stats <- summary(object@values) + + # Combine with additional information from the object + result <- list( + Summary = stats, + Type = object@type, + Ease = object@ease + ) + + # Set a class for the output to customize print behavior + class(result) <- "summary.Sequence" + result +}) + +# Define a print method for the custom summary output +print.summary.Sequence <- function(x, ...) { + cat("Summary of Sequence Object:\n") + cat("\nType:", x$Type, "\n") + cat("Ease:", x$Ease, "\n\n") + print(x$Summary) +} +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Define method for plotting using 'xy.coords' +methods::setMethod("xy.coords",c(x = "Sequence", y = "missing", setLab = "ANY"), + function(x, y, setLab = TRUE) { + # Define x and y + x_coords <- seq_along(x@values) + y_coords <- x@values + + # Set custom labels if provided + xlab <- if (is.character(setLab)) paste(setLab, "X") else NULL + ylab <- if (is.character(setLab)) paste(setLab, "Y") else NULL + + # Return xy.coords + xy.coords(x = x_coords, y = y_coords, xlab = xlab, ylab = ylab) + }) + +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +# Define methods +methods::setMethod("show", "Sequence", function(object) { + # Display only the 'values' slot + cat("Values:\n", object@values, "\n") + + # Return 'type','ease', and 'steps' invisibly + invisible( + list(type = object@type, + ease = object@ease, + steps = object@steps) + ) + } +) + +Sequence <- function(values = numeric(), + type = character(), + ease = character(), + steps = numeric()) { + new("Sequence", values = values, type = type, ease = ease, steps = steps) +} + +#---- --- ---- --- ---- --- ---- --- ---- --- ---- --- ----# +methods::setValidity("Sequence", function(object){ + if(length(object@type) != length(object@ease)){ + "@type and @ease must be the same length" + } + if (!is.numeric(object@values)) { + return("@values must be a numeric vector") + } + if(!is.numeric(object@steps)){ + return("@steps must be a numeric vector of length 1") + } + TRUE +}) diff --git a/R/utils.R b/R/utils.R index 4396571..3df75f8 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,19 +1,3 @@ -replace_char <- function(.input_string, - old_char, - new_char, - use_regex = FALSE) { - - if (old_char == "" || is.null(old_char)) { - stop("Error: The character to replace cannot be empty.") - } - - gsub(old_char, - new_char, - .input_string, - fixed = !use_regex) - -} - join_char <- function(first, join_with = "_", second){ @@ -41,3 +25,12 @@ get_mode <- function(.x) { .x[NA_integer_] } } + +is.sequence <- function(x,...){ + + if(!inherits(x,"Sequence")) + FALSE + else { + TRUE + } +} diff --git a/README.Rmd b/README.Rmd index 78e2e4d..b3f154b 100644 --- a/README.Rmd +++ b/README.Rmd @@ -60,7 +60,7 @@ library(sequentially) points(t,lin_seq,pch = 16, cex = .75,col = "red") axis(1,tcl = 0.75,lwd = 0, family = "serif") axis(2,lwd = 0, family = "serif", las = 1) - grid(2,3,col = "gray80",lty = "dotted", lwd = 0.50) + grid(2,col = "gray80",lty = "dotted", lwd = 0.50) mtext("Linear Sequence",3,cex = 1.3, family = "serif") @@ -71,7 +71,7 @@ library(sequentially) points(t,elastic_seq,pch = 16, cex = .75,col = "red") axis(1,tcl = 0.75,lwd = 0, family = "serif") axis(2,lwd = 0, family = "serif", las = 1) - grid(2,3,col = "gray80",lty = "dotted", lwd = 0.50) + grid(2,col = "gray80",lty = "dotted", lwd = 0.50) mtext("Ease-out Elastic Sequence",3,cex = 1.3, family = "serif") ``` diff --git a/man/seq_data.Rd b/man/interpolate.Rd similarity index 90% rename from man/seq_data.Rd rename to man/interpolate.Rd index f909e63..c8e696a 100644 --- a/man/seq_data.Rd +++ b/man/interpolate.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/seq_data_nl.R -\name{seq_data} -\alias{seq_data} +\name{interpolate} +\alias{interpolate} \title{Interpolate a sequence of values with Easing or Stepping Given Data Points} \usage{ -seq_data(data, type = "linear", step_count = NULL, ease = NULL) +interpolate(data, type = "linear", step_count = NULL, ease = NULL) } \arguments{ \item{data}{Numeric vector, matrix, data frame, or list. The input data to be used for generating the sequence.} @@ -63,12 +63,15 @@ error messages or warnings. } \examples{ # Generate a linear sequence -seq_data(1:10, type = "linear") +interpolate(1:10, type = "linear") # Generate a quadratic easing sequence -seq_data(rnorm(100,14,5), type = "quad", ease = "in_out") +interpolate(rnorm(100,14,5), type = "quad", ease = "in_out") # Generate a stepped sequence with 5 steps -seq_data(rpois(100,3), type = "step", step_count = 5) +interpolate(rpois(100,3), type = "step", step_count = 5) } +\seealso{ +\link{func(approx)} +}