updates look()

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
 #'

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;
 
 }

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))
+})

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)))
+})

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