version 0.0-3

cran · Aug 16, 2023 · 06e8e56 · 06e8e56
1 parent b1709d8
commit 06e8e56
Show file tree

Hide file tree

Showing 34 changed files with 3,282 additions and 102 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,26 +1,28 @@
 Package: frab
 Type: Package
-Title: An Alternative Interpretation of Named Vectors
-Version: 0.0-1
+Title: How to Add Two Tables
+Version: 0.0-3
 Authors@R: person(given=c("Robin", "K. S."), family="Hankin", role = c("aut","cre"), email="hankin.robin@gmail.com", comment = c(ORCID = "0000-0001-5982-0415"))
 Maintainer: Robin K. S. Hankin <hankin.robin@gmail.com>
-Description: An alternative interpretation of named vectors as
-     generalized tables, so that c(a=1,b=2,c=3) + c(b=3,a=-1) will
-     return c(b=5,c=3).  Uses 'disordR' discipline (Hankin, 2022,
-     <doi:10.48550/ARXIV.2210.03856>).  Extraction and replacement
-     methods are provided.  The underlying mathematical structure is
-     the Free Abelian group, hence the name.
+Description: Methods to "add" two tables; also an alternative
+     interpretation of named vectors as generalized tables, so that
+     c(a=1,b=2,c=3) + c(b=3,a=-1) will return c(b=5,c=3).  Uses
+     'disordR' discipline (Hankin, 2022, <arxiv:2210.03856>).
+     Extraction and replacement methods are provided.  The underlying
+     mathematical structure is the Free Abelian group, hence the name.
+     To cite in publications please use Hankin (2023)
+     <arxiv:2307:13184>.
 License: GPL (>= 2)
 Depends: R (>= 3.5.0)
-Suggests: knitr, markdown, rmarkdown, testthat
+Suggests: knitr, markdown, rmarkdown, testthat, mvtnorm
 VignetteBuilder: knitr
 Imports: Rcpp (>= 1.0-7), mathjaxr, disordR (>= 0.9-8-1), methods
 LinkingTo: Rcpp
 URL: https://github.com/RobinHankin/frab
 BugReports: https://github.com/RobinHankin/frab
 RdMacros: mathjaxr
 NeedsCompilation: yes
-Packaged: 2023-07-19 21:37:40 UTC; rhankin
+Packaged: 2023-08-15 23:57:04 UTC; rhankin
 Author: Robin K. S. Hankin [aut, cre] (<https://orcid.org/0000-0001-5982-0415>)
 Repository: CRAN
-Date/Publication: 2023-07-20 11:20:02 UTC
+Date/Publication: 2023-08-16 09:02:35 UTC
diff --git a/MD5 b/MD5
@@ -1,34 +1,44 @@
-5061f6385aff6a83e8baad22fc5faa8d *DESCRIPTION
+c5ce79e255519bae4ff515c8d28f4f71 *DESCRIPTION
 55e0cf44c1a5c0e1ea52ca6bd526b242 *NAMESPACE
-868be7dc206df4f129d20419aad0a976 *R/RcppExports.R
-5fbaabf29578c25827e6b0e4769c9afe *R/frab.R
-61ae6ae99ef7a8c14b6b97185f446c71 *README.md
-b1870707d2b690351f4c7f515f90a24f *build/frab.pdf
-68865b88cfa1f13c38ca79af192d28ff *build/partial.rdb
-160d6dfb46956e52b633848573847aed *build/stage23.rdb
-06c8dac28c5e939c6af6592635f694e3 *build/vignette.rds
-d385e72c2f60e980006f1ec48eb3b4a1 *inst/doc/frab.R
-f787f9bf341b82267132833e40263a09 *inst/doc/frab.Rmd
-5d019a465de919645b02f3a3847cc906 *inst/doc/frab.html
-3b9e3ed50c0b8ffa0c7d5cc793a7dd4f *man/Arith.Rd
-5c51a0d12de2c5a2909271a3d1975d39 *man/Compare.Rd
-7ed1312f15bad6ae61b053f88902cd84 *man/Extract.Rd
+2f8bd80de715cde904dfc8430a47cb85 *NEWS.md
+ff2988afb5dc1fad914fc6f1b90585cf *R/RcppExports.R
+5e92e3d8d9847f5c3b0c59077d27b803 *R/frab.R
+5ea61be7cb5e3c72236773ccd15a69b0 *R/sparsetable.R
+d3efe4d379e4985a05ae467269ff8b5e *README.md
+f36a9abac32324778b7ce1aecc16cd80 *build/frab.pdf
+5b34e07bb2f5f9fac47e07ba59581ef0 *build/partial.rdb
+0ac9cace5052ba8cbcb6a029f6a8eafe *build/stage23.rdb
+ee23a57ddc61e60b2ca2b956a157605d *build/vignette.rds
+61cd24468278a2c74bea8ae24c335166 *inst/doc/frab.R
+0cff9a2f802561af620671db34a793b6 *inst/doc/frab.Rmd
+1c4110d8c1af85b8053a38022c10d268 *inst/doc/frab.html
+47a0055c494ebee78647cc56b8f5cadf *inst/frab.bib
+f0465c6b8a13269fab9d99f8aa266527 *inst/frab_arxiv.Rnw
+d29784da0b905da88244b5a5c40f2fdc *inst/read.me
+a5aac65fb29bf3430f1e7e8b7f717749 *inst/wittgenstein.Rmd
+316dd6430416f86fdc133737ce7c34af *man/Arith.Rd
+308adc135b1aad80fd826a6a9fb7ae0c *man/Compare.Rd
+190453a31e19248c587d5706c73ecb1f *man/Extract.Rd
 0e38107b0ebeccecfc57cab27e7529fd *man/figures/frab.png
-9a60484529733e2ab3c431106041f1a6 *man/frab-class.Rd
+ceaca23242a1baa9d8fd2dc3a93b6163 *man/frab-class.Rd
 300bf5b585a4b58d36105cbadb306092 *man/frab-package.Rd
-dd68f9458a0069b5023c88198550cd72 *man/frab.Rd
-d868cd2cfe4b8250f5c8b44c33a4dd6c *man/misc.Rd
+05c3919de40c5344a16a2acd78d2eb48 *man/frab.Rd
+9098c88fb16e6152646639f9c5486858 *man/misc.Rd
 2966ded66d965c0c31c9c3eca0a2a916 *man/namedvector.Rd
 680350e287b311cc55c30fed88cb9ed3 *man/pmax.Rd
 7026a022f968605cdf89f2ac997f6979 *man/print.Rd
 64ff6a2224e515d260be98513c02c97f *man/rfrab.Rd
+123d72827e9188318b9243c9cb31160c *man/sparsetable.Rd
 6f249b0f0c53fddd870854e344936e17 *man/table.Rd
 89f8675cf461379a8c0f224f4917b4b4 *man/zero.Rd
-616ea317e88c1aac6cedb199c835e5ec *src/RcppExports.cpp
-04dc8cbd76b5bcc8a858ec91dcc5a44b *src/frab.cpp
+d78e2af1f3ebf698083a133f355afd9e *src/RcppExports.cpp
+f6b5e8fed1acee228a850a03c75a9a5b *src/frab.cpp
 2d0eddd0677a2b902568cdacdbf125cb *src/frab.h
+47f31a21c0cd8fc66314309354ea187f *src/sparsetable_ops.cpp
 9e68b0a4b1df7d52541fa46fff582d29 *tests/testthat.R
-d645568bd1aa4d8ecd32857541701db4 *tests/testthat/test_aaa.R
-3ff3363c5e04cb4d05ca9809881db10c *tests/testthat/test_aab.R
-f787f9bf341b82267132833e40263a09 *vignettes/frab.Rmd
-aa694962e8901d679115abaf2386f83e *vignettes/frab.bib
+3e79d52355dae72090cf1eb0ec4b5902 *tests/testthat/test_aaa.R
+b7f4a07171618298ad285c1502062e95 *tests/testthat/test_aab.R
+6358c120726711bbe0edcd3cc4030cba *tests/testthat/test_aac.R
+a82f9f28656912b8f25fd647d5238c0c *tests/testthat/test_aad.R
+0cff9a2f802561af620671db34a793b6 *vignettes/frab.Rmd
+700ee49f464ee71ac60824b6b60955e1 *vignettes/frab.bib
diff --git a/NEWS.md b/NEWS.md
@@ -0,0 +1,15 @@
+# frab 0.0-1
+
+- initial release
+
+
+# frab 0.0-2
+
+- multiplication method
+- new arxiv preprint
+- new draft vignette in inst/
+
+# frab 0.0-3
+
+- sparsetable functionality
+- near complete test coverage
diff --git a/R/RcppExports.R b/R/RcppExports.R
@@ -9,6 +9,10 @@ c_frab_add <- function(names1, values1, names2, values2) {
     .Call(`_frab_c_frab_add`, names1, values1, names2, values2)
 }
 
+c_frab_multiply <- function(names1, values1, names2, values2) {
+    .Call(`_frab_c_frab_multiply`, names1, values1, names2, values2)
+}
+
 c_frab_pmax <- function(names1, values1, names2, values2) {
     .Call(`_frab_c_frab_pmax`, names1, values1, names2, values2)
 }
@@ -17,3 +21,35 @@ c_frab_eq <- function(names1, values1, names2, values2) {
     .Call(`_frab_c_frab_eq`, names1, values1, names2, values2)
 }
 
+sparsetable_maker <- function(M, d) {
+    .Call(`_frab_sparsetable_maker`, M, d)
+}
+
+sparsetable_add <- function(M1, d1, M2, d2) {
+    .Call(`_frab_sparsetable_add`, M1, d1, M2, d2)
+}
+
+sparsetable_overwrite <- function(M1, d1, M2, d2) {
+    .Call(`_frab_sparsetable_overwrite`, M1, d1, M2, d2)
+}
+
+sparsetable_accessor <- function(M, d, Mindex) {
+    .Call(`_frab_sparsetable_accessor`, M, d, Mindex)
+}
+
+sparsetable_setter <- function(M1, d1, M2, d2) {
+    .Call(`_frab_sparsetable_setter`, M1, d1, M2, d2)
+}
+
+sparsetable_equality <- function(M1, d1, M2, d2) {
+    .Call(`_frab_sparsetable_equality`, M1, d1, M2, d2)
+}
+
+sparsetable_asum_include <- function(M, d, n) {
+    .Call(`_frab_sparsetable_asum_include`, M, d, n)
+}
+
+sparsetable_pmax <- function(M1, d1, M2, d2) {
+    .Call(`_frab_sparsetable_pmax`, M1, d1, M2, d2)
+}
+
diff --git a/R/frab.R b/R/frab.R
@@ -8,6 +8,19 @@ setMethod("names","frab",
               return(disord(names(x@x),h=hashcal(x@x)))
           } )
 
+setReplaceMethod("names",signature(x="frab",value="disord"),
+                 function(x,value){
+                     v <- values(x)
+                     stopifnot(consistent(v,value))
+                     frab(setNames(elements(v),elements(value)))
+                 } )
+
+setReplaceMethod("names",signature(x="frab",value="character"),
+                 function(x,value){
+                     stopifnot(length(x)==1)
+                     frab(setNames(values(x),value))
+                 } )
+
 setGeneric("values",function(x){standardGeneric("values")})
 setMethod("values","frab",
           function(x){
@@ -67,6 +80,8 @@ setMethod("as.table","frab",function(x,...){structure(as.namedvector(x),dim=leng
     return(list_to_frab(x))
   } else if(is.1dtable(x)){
     return(table_to_frab(x))
+  } else if(is.sparsetable(x)){
+    return(sparsetable_to_frab(x))
   } else if(is.frab(x)){
     return(x)
   } else {
@@ -80,11 +95,16 @@ setMethod("as.table","frab",function(x,...){structure(as.namedvector(x),dim=leng
   as.frab(c_frab_add(elements(names(F1)), elements(values(F1)),
                      elements(names(F2)), elements(values(F2))))
 }
-
-`frab_multiply_numeric` <- function(e1,e2){frab(setNames(elements(values(e1)*e2),elements(names(e1))))}
-`frab_power_numeric`    <- function(e1,e2){frab(setNames(elements(values(e1)^e2),elements(names(e1))))}
-`numeric_multiply_frab` <- function(e1,e2){frab(setNames(elements(e1*values(e2)),elements(names(e2))))}
-`numeric_power_frab`    <- function(e1,e2){frab(setNames(elements(e1^values(e2)),elements(names(e2))))}
+
+`frab_multiply_frab` <- function(F1,F2){
+  as.frab(c_frab_multiply(elements(names(F1)), elements(values(F1)),
+                     elements(names(F2)), elements(values(F2))))
+}
+
+`frab_plus_numeric`     <- function(e1,e2){if(is.namedvector(e2)){return(e1+frab(e2))}else{return(frab(setNames(elements(values(e1)+e2),elements(names(e1)))))}}
+`frab_multiply_numeric` <- function(e1,e2){if(is.namedvector(e2)){stop("not defined")}else{return(frab(setNames(elements(values(e1)*e2),elements(names(e1)))))}}
+`frab_power_numeric`    <- function(e1,e2){if(is.namedvector(e2)){stop("not defined")}else{return(frab(setNames(elements(values(e1)^e2),elements(names(e1)))))}}
+`numeric_power_frab`    <- function(e1,e2){stop("<numeric> ^ <frab> not defined")}
 
 `frab_unary` <- function(e1,e2){
   switch(.Generic,
@@ -100,13 +120,14 @@ setMethod("as.table","frab",function(x,...){structure(as.namedvector(x),dim=leng
   switch(.Generic,
          "+" = frab_plus_frab(e1, e2),
          "-" = frab_plus_frab(e1, frab_negative(e2)),
+         "*" = frab_multiply_frab(e1, e2),
          stop(gettextf("binary operator %s not implemented on frabs", dQuote(.Generic)))
          ) }
 
 `frab_arith_numeric` <- function(e1,e2){ # e1 frab, e2 numeric; e2 might be a named vector.
   switch(.Generic,
-         "+" = frab_plus_frab(e1, as.frab(e2)),
-         "-" = frab_plus_frab(e1, frab_negative(as.frab(e2))),
+         "+" = frab_plus_numeric(e1, e2),
+         "-" = frab_plus_numeric(e1, -e2),
          "*" = frab_multiply_numeric(e1,e2),
          "/" = frab_multiply_numeric(e1,1/e2),
          "^" = frab_power_numeric(e1,e2),
@@ -115,10 +136,10 @@ setMethod("as.table","frab",function(x,...){structure(as.namedvector(x),dim=leng
 
 `numeric_arith_frab` <- function(e1,e2){ # e1 numeric, e2 frab; e2 _might_ be a named vector.
   switch(.Generic,
-         "+" = frab_plus_frab(as.frab(e1),  e2),
-         "-" = frab_plus_frab(as.frab(e1), -e2),
-         "*" = numeric_multiply_frab(e1,e2), 
-         "/" = numeric_multiply_frab(e1,frab_reciprocal(e2)), 
+         "+" = frab_plus_numeric( e2,e1),
+         "-" = frab_plus_numeric(-e2,e1),
+         "*" = frab_multiply_numeric(e2,e1), 
+         "/" = frab_multiply_numeric(frab_reciprocal(e2),e1),
          "^" = numeric_power_frab(e1,e2),
          stop(gettextf("binary operator %s not implemented on frabs", dQuote(.Generic)))
          ) }
@@ -137,6 +158,7 @@ setMethod("as.table","frab",function(x,...){structure(as.namedvector(x),dim=leng
 }
 
 `frab_eq_num` <- function(e1,e2){values(e1) == e2}
+`frab_ne_num` <- function(e1,e2){values(e1) != e2}
 `frab_gt_num` <- function(e1,e2){values(e1) >  e2}
 `frab_ge_num` <- function(e1,e2){values(e1) >= e2}
 `frab_lt_num` <- function(e1,e2){values(e1) <  e2}
@@ -145,6 +167,7 @@ setMethod("as.table","frab",function(x,...){structure(as.namedvector(x),dim=leng
 `frab_compare_numeric` <- function(e1,e2){  # rfrab() > 3
   switch(.Generic,
          "==" = frab_eq_num(e1, e2),
+         "!=" = frab_ne_num(e1, e2),
          ">"  = frab_gt_num(e1, e2),
          ">=" = frab_ge_num(e1, e2),
          "<"  = frab_lt_num(e1, e2),
@@ -154,6 +177,7 @@ setMethod("as.table","frab",function(x,...){structure(as.namedvector(x),dim=leng
 
 
 `num_eq_frab` <- function(e1,e2){e1 == values(e2)}
+`num_ne_frab` <- function(e1,e2){e1 != values(e2)}
 `num_gt_frab` <- function(e1,e2){e1 >  values(e2)}
 `num_ge_frab` <- function(e1,e2){e1 >= values(e2)}
 `num_lt_frab` <- function(e1,e2){e1 <  values(e2)}
@@ -162,6 +186,7 @@ setMethod("as.table","frab",function(x,...){structure(as.namedvector(x),dim=leng
 `numeric_compare_frab` <- function(e1,e2){  # 4 <= rfrab()
   switch(.Generic,
          "==" = num_eq_frab(e1, e2),
+         "!=" = num_ne_frab(e1, e2),
          ">"  = num_gt_frab(e1, e2),
          ">=" = num_ge_frab(e1, e2),
          "<"  = num_lt_frab(e1, e2),
@@ -250,6 +275,12 @@ setReplaceMethod("[",signature(x="frab",i="character",j="missing",value="numeric
                      )
                  })
 
+setReplaceMethod("[",signature(x="frab",i="character",j="missing",value="logical"),
+                 function(x,i,j,value){
+                     x[i] <- as.numeric(value)  # the meat
+                     return(x)
+                 })
+
 setReplaceMethod("[",signature(x="frab",i="disord",j="missing",value="numeric"),
                  function(x,i,j,value){
                      s <- names(x)
@@ -268,6 +299,12 @@ setReplaceMethod("[",signature(x="frab",i="disord",j="missing",value="numeric"),
                      )
                  })
 
+setReplaceMethod("[",signature(x="frab",i="disord",j="missing",value="logical"),
+                 function(x,i,j,value){
+                     x[i] <- as.numeric(value)  # the meat
+                     return(x)
+                 } )
+
 setReplaceMethod("[",signature(x="frab",i="disord",j="missing",value="frab"),
                  function(x,i,j,value){
                    stop("not currently implemented.  Idiom such as x[x<0] <- -x[x<0] is disord-compliant [and meaningful] but not yet implemented")
@@ -280,13 +317,24 @@ setReplaceMethod("[",signature(x="frab",i="disindex",j="missing",value="numeric"
                      return(frab(setNames(elements(p),names(x))))
                  } )
 
-setReplaceMethod("[",signature(x="frab",i="missing",j="missing",value="ANY"),
+setReplaceMethod("[",signature(x="frab",i="missing",j="missing",value="numeric"),
                  function(x,i,j,value){
                    v <- values(x)
-                   v[] <- value
+                   v[] <- value  # disord discipline violations trapped here
                    return(frab(setNames(v,names(x))))
                  } )
 
+setReplaceMethod("[",signature(x="frab",i="missing",j="missing",value="frab"),
+                 function(x,i,j,value){
+                   stop("x[] <- y (with x, y frabs) does not make sense; try x <- y?")
+                 } )
+
+setReplaceMethod("[",signature(x="frab",i="missing",j="missing",value="ANY"),
+                 function(x,i,j,value){
+                   stop("frab,missing,missing,ANY-method not implemented")
+                 } )
+
+
 setReplaceMethod("[",signature(x="frab",i="ANY",j="ANY",value="ANY"),
                  function(x,i,j,value){
                    stop("replacement operation not defined in this case")
@@ -323,7 +371,7 @@ setGeneric("pmin",function(...){standardGeneric("pmin")})
     } else if(nargs()<3){
     return(pmax_pair(x, ...))
   } else {
-    return(pmax_pair(x, pmax_pair(...)))
+    return(pmax_pair(x, pmax_dots(...)))
   }
 }
 
@@ -333,21 +381,41 @@ setGeneric("pmin",function(...){standardGeneric("pmin")})
   } else if(nargs()<3){
     return(pmin_pair(x, ...))
   } else {
-    return(pmin_pair(x, pmin_pair(...)))
+    return(pmin_pair(x, pmin_dots(...)))
   }
 }
 
 setMethod("pmax",signature("..."="frab"), function(...){pmax_dots(...)} )
 setMethod("pmin",signature("..."="frab"), function(...){pmin_dots(...)} )
 
 setMethod("pmax",signature("..."="ANY"),function(...,na.rm=FALSE){base::pmax(..., na.rm=na.rm)})
-setMethod("pmin",signature("..."="ANY"),function(...,na.rm=FALSE){base::pmax(..., na.rm=na.rm)})
+setMethod("pmin",signature("..."="ANY"),function(...,na.rm=FALSE){base::pmin(..., na.rm=na.rm)})
 
 setGeneric("is.na")
 setMethod("is.na","frab",function(x){which(is.na(values(x)))})
 setGeneric("is.na<-")
 setReplaceMethod("is.na",signature("frab",value="disord"),
                  function(x,value){
-                   values(x)[value] <- NA
-                   return(x)
+                   v <- values(x)
+                   is.na(v) <- value # the meat
+                   return(frab(setNames(elements(v),elements(names(x)))))
                  } )
+
+setGeneric("is.notna",function(x){standardGeneric("is.notna")})
+setMethod("is.notna","frab",function(x){which(!is.na(values(x)))})
+
+setMethod("Summary", "frab",
+          function(x, ..., na.rm=FALSE){
+            switch(.Generic,
+                   max    = max(values(x)),
+                   min    = min(values(x)),
+                   range  = c(min(values(x)),max(values(x))),
+                   sum    = sum(values(x)),
+                   stop(gettextf("Summary function %s not implemented on frabs", dQuote(.Generic)))
+                   )
+          }
+          )
+
+
+
+