From 2ef45ef6c7e3d8c80f3ba1cb4c11f90b8865ec75 Mon Sep 17 00:00:00 2001 From: shikokuchuo <53399081+shikokuchuo@users.noreply.github.com> Date: Mon, 9 Sep 2024 14:48:27 +0100 Subject: [PATCH] updates look() --- R/utils.R | 15 +++++++++------ man/look.Rd | 4 ++-- src/shikokuchuo.c | 20 +++++++------------- tests/testthat/test-ichimoku.R | 11 ++++++----- tests/testthat/test-mltools.R | 15 ++++++++++----- tests/testthat/test-utils.R | 6 ------ 6 files changed, 34 insertions(+), 37 deletions(-) diff --git a/R/utils.R b/R/utils.R index 4724f4da..ff8fe6a5 100644 --- a/R/utils.R +++ b/R/utils.R @@ -139,8 +139,7 @@ xts_df <- function(x, keep.attrs = FALSE) { `attributes<-`(df, c(list(names = c("index", dn2), class = "data.frame", row.names = .set_row_names(xlen)), - if (isTRUE(keep.attrs)) - .Call(ichimoku_look, x))) + if (isTRUE(keep.attrs)) look(x))) } #' Convert matrix to data.frame @@ -168,7 +167,7 @@ xts_df <- function(x, keep.attrs = FALSE) { #' @export #' matrix_df <- function(x, keep.attrs = FALSE) { - lk <- if (isTRUE(keep.attrs)) .Call(ichimoku_look, x) + lk <- if (isTRUE(keep.attrs)) look(x) dn <- dimnames(x) xlen <- dim(x)[1L] len <- dim(x)[2L] @@ -280,10 +279,10 @@ df_append <- function(old, new, key = "time", keep.attr = "timestamp") { #' @param x an object (optional). If 'x' is not supplied, \code{\link{.Last.value}} #' will be used instead. #' -#' @return For objects created by the ichimoku package, a pairlist of attributes +#' @return For objects created by the ichimoku package, a list of attributes #' specific to that data type. #' -#' For other objects, a pairlist of non-standard attributes for matrix / +#' For other objects, a list of non-standard attributes for matrix / #' data.frame / xts classes, or else invisible NULL if none are present. #' #' @details Note: autostrat list attributes may be accessed directly using @@ -310,7 +309,11 @@ df_append <- function(old, new, key = "time", keep.attr = "timestamp") { #' #' @export #' -look <- function(x = .Last.value) if (length(lk <- .Call(ichimoku_look, x))) lk +look <- function(x = .Last.value) { + attr <- attributes(.Call(ichimoku_look, x)) + is.null(attr) && return(invisible()) + attr +} #' Print More Rows of Ichimoku Objects #' diff --git a/man/look.Rd b/man/look.Rd index 8ab705d0..44cc180d 100644 --- a/man/look.Rd +++ b/man/look.Rd @@ -11,10 +11,10 @@ look(x = .Last.value) will be used instead.} } \value{ -For objects created by the ichimoku package, a pairlist of attributes +For objects created by the ichimoku package, a list of attributes specific to that data type. - For other objects, a pairlist of non-standard attributes for matrix / + For other objects, a list of non-standard attributes for matrix / data.frame / xts classes, or else invisible NULL if none are present. } \description{ diff --git a/src/shikokuchuo.c b/src/shikokuchuo.c index 17c652c9..47ad2131 100644 --- a/src/shikokuchuo.c +++ b/src/shikokuchuo.c @@ -129,20 +129,14 @@ SEXP _wmean(SEXP x, SEXP window) { // look - inspect informational attributes SEXP _look(SEXP x) { - SEXP ax, y; - PROTECT_INDEX pxi; - PROTECT_WITH_INDEX(y = R_NilValue, &pxi); - - for (ax = ATTRIB(x); ax != R_NilValue; ax = CDR(ax)) { - if (TAG(ax) != R_NamesSymbol && TAG(ax) != R_RowNamesSymbol && - TAG(ax) != R_DimSymbol && TAG(ax) != R_DimNamesSymbol && - TAG(ax) != R_ClassSymbol && TAG(ax) != xts_IndexSymbol) { - REPROTECT(y = Rf_cons(CAR(ax), y), pxi); - SET_TAG(y, TAG(ax)); - } - } - + SEXP y; + PROTECT(y = Rf_ScalarInteger(0)); + Rf_copyMostAttrib(x, y); + Rf_classgets(y, R_NilValue); + Rf_setAttrib(y, R_RowNamesSymbol, R_NilValue); + Rf_setAttrib(y, xts_IndexSymbol, R_NilValue); UNPROTECT(1); + return y; } diff --git a/tests/testthat/test-ichimoku.R b/tests/testthat/test-ichimoku.R index c20db99d..56da1fe2 100644 --- a/tests/testthat/test-ichimoku.R +++ b/tests/testthat/test-ichimoku.R @@ -66,11 +66,6 @@ test_that("print method ok", { expect_output(print(cloud[, 1L, drop = TRUE])) }) -test_that("more ok", { - expect_null(expect_invisible(more())) - expect_null(expect_invisible(more(20))) -}) - test_that("str method ok", { expect_output(expect_null(expect_invisible(str(cloud))), "(281, 12)") expect_output(str(cloud[0]), "(0, 12)") @@ -120,3 +115,9 @@ test_that(".ichimoku ok", { expect_identical(attr(.ichimoku(sample_ohlc_data), "ticker"), "sample_ohlc_data") expect_warning(.ichimoku(sample_ohlc_data, periods = c(9L, 26L, -52L)), regexp = "cloud periods invalid") }) + +test_that("internal window functions ok", { + expect_identical(.Call(ichimoku_wmin, as.numeric(1:6), 3L), c(NA, NA, 1, 2, 3, 4)) + expect_identical(.Call(ichimoku_wmax, as.numeric(1:6), 3L), c(NA, NA, 3, 4, 5, 6)) + expect_identical(.Call(ichimoku_wmean, as.numeric(1:6), 3L), c(NA, NA, 2, 3, 4, 5)) +}) diff --git a/tests/testthat/test-mltools.R b/tests/testthat/test-mltools.R index 38ae2173..d32badbf 100644 --- a/tests/testthat/test-mltools.R +++ b/tests/testthat/test-mltools.R @@ -28,16 +28,21 @@ test_that("mlgrid ok", { test_that("relative ok", { expect_output(expect_s3_class(rel <- relative(cloud), "data.frame")) expect_identical(dim(rel), c(37L, 8L)) - expect_length(expect_type(look(rel), "pairlist"), 4L) + expect_length(expect_type(look(rel), "list"), 4L) expect_silent(relative(cloud, order = TRUE, signif = 0.4, quietly = TRUE)) expect_error(relative(sample_ohlc_data), regexp = "ichimoku object") }) test_that("look ok", { - expect_length(expect_type(look(cloud), "pairlist"), 3L) - expect_length(expect_type(look(stratlist[[1L]]), "pairlist"), 4L) - expect_length(expect_type(look(grid), "pairlist"), 7L) - expect_length(expect_type(look(stratlist), "pairlist"), 2L) + expect_length(expect_type(look(cloud), "list"), 3L) + expect_length(expect_type(look(stratlist[[1L]]), "list"), 4L) + expect_length(expect_type(look(grid), "list"), 7L) + expect_length(expect_type(look(stratlist), "list"), 2L) expect_null(expect_invisible(look(sample_ohlc_data))) expect_null(expect_invisible(look())) }) + +test_that("more ok", { + expect_null(expect_invisible(more())) + expect_null(expect_invisible(more(20))) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 59d44b27..ee3e4c3e 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -41,9 +41,3 @@ test_that("df_append ok", { attr(new, "special") <- "test" expect_identical(attr(df_append(old, new, keep.attr = "special"), "special"), attr(new, "special")) }) - -test_that("internal window functions ok", { - expect_identical(.Call(ichimoku_wmin, as.numeric(1:6), 3L), c(NA, NA, 1, 2, 3, 4)) - expect_identical(.Call(ichimoku_wmax, as.numeric(1:6), 3L), c(NA, NA, 3, 4, 5, 6)) - expect_identical(.Call(ichimoku_wmean, as.numeric(1:6), 3L), c(NA, NA, 2, 3, 4, 5)) -})