Initial commit

.Rbuildignore

@@ -0,0 +1,5 @@
+^infixer\.Rproj$
+^\.Rproj\.user$
+^exclude$
+^LICENSE\.md$
+^setops\.Rproj$

.gitignore

@@ -0,0 +1,3 @@
+.Rproj.user
+.Rhistory
+.RData

DESCRIPTION

@@ -0,0 +1,12 @@
+Package: rangeops
+Title: What the Package Does (one line, title case)
+Version: 0.0.0.9000
+Authors@R: person("First", "Last", email = "first.last@example.com", role = c("aut", "cre"))
+Description: What the package does (one paragraph).
+Depends: R (>= 3.6.0)
+License: GPL-3
+Encoding: UTF-8
+LazyData: true
+RoxygenNote: 6.1.1
+Suggests: 
+    rlang

NAMESPACE

@@ -0,0 +1,51 @@
+# Generated by roxygen2: do not edit by hand
+
+export("!=<-")
+export("%!in%")
+export("%!in%<-")
+export("%!in()%")
+export("%!in()%<-")
+export("%!in(]%")
+export("%!in(]%<-")
+export("%!in[)%")
+export("%!in[)%<-")
+export("%!in[]%")
+export("%!in[]%<-")
+export("%!in{}%")
+export("%!in{}%<-")
+export("%!like%")
+export("%!like%<-")
+export("%!subset()%")
+export("%!subset(]%")
+export("%!subset[)%")
+export("%!subset[]%")
+export("%!subset{}%")
+export("%in%<-")
+export("%in()%")
+export("%in()%<-")
+export("%in(]%")
+export("%in(]%<-")
+export("%in[)%")
+export("%in[)%<-")
+export("%in[]%")
+export("%in[]%<-")
+export("%in{}%")
+export("%in{}%<-")
+export("%like%")
+export("%like%<-")
+export("%subset!=%")
+export("%subset()%")
+export("%subset(]%")
+export("%subset<%")
+export("%subset<=%")
+export("%subset==%")
+export("%subset>%")
+export("%subset>=%")
+export("%subset[)%")
+export("%subset[]%")
+export("%subset{}%")
+export("<<-")
+export("<=<-")
+export("==<-")
+export("><-")
+export(">=<-")

R/01_in.R

@@ -0,0 +1,98 @@
+#' in variants
+#'
+#' @inheritParams base::match
+#' @param value replacement value
+#'
+#' @name in_variants
+NULL
+
+#' @rdname in_variants
+#' @export
+`%in%<-` <- function (x, table, value) {
+  if(is.factor(x)){
+    # if factor we replace levels not values
+    lvls <- levels(x)
+    cond <- lvls %in% table
+    if(any(cond)){
+      # if value is function we apply it on relevant subset
+      if(inherits(value,"formula")) {
+        if (requireNamespace("rlang")) value <- rlang::as_function(value)
+        else stop("install package rlang to use `%in<-` with formula notation")
+      }
+      if(is.function(value)) value <- value(lvls[cond])
+      # replace relevant levels
+      levels(x)[cond] <- value
+    }
+  } else {
+    cond <- x %in% table
+    if(any(cond)){
+      # if value is function we apply it on relevant subset
+      if(inherits(value,"formula")) {
+        if (requireNamespace("rlang")) value <- rlang::as_function(value)
+        else stop("install package rlang to use `%in<-` with formula notation")
+      }
+      if(is.function(value)) value <- value(x[cond])
+      # replace relevant elements
+      x <- replace(x, cond, value)
+    }
+  }
+  x
+}
+
+#' @rdname in_variants
+#' @export
+`%!in%` <- function(x, table) !x %in% table
+
+# copy and paste from `%in%`, adding `!` to `cond` definition
+#' @rdname in_variants
+#' @export
+`%!in%<-` <- function (x, table, value) {
+  if(is.factor(x)){
+    # if factor we replace levels not values
+    lvls <- levels(x)
+    cond <- !lvls %in% table
+    if(any(cond)){
+      # if value is function we apply it on relevant subset
+      if(inherits(value,"formula")) {
+        if (requireNamespace("rlang")) value <- rlang::as_function(value)
+        else stop("install package rlang to use `%in<-` with formula notation")
+      }
+      if(is.function(value)) value <- value(lvls[cond])
+      # replace relevant levels
+      levels(x)[cond] <- value
+    }
+  } else {
+    cond <- !x %in% table
+    if(any(cond)){
+      # if value is function we apply it on relevant subset
+      if(inherits(value,"formula")) {
+        if (requireNamespace("rlang")) value <- rlang::as_function(value)
+        else stop("install package rlang to use `%in<-` with formula notation")
+      }
+      if(is.function(value)) value <- value(x[cond])
+      # replace relevant elements
+      x <- replace(x, cond, value)
+    }
+  }
+  x
+}
+
+# vec <- c(0, 10, 100 ,1000)
+# vec %in% 5:500 <- 42
+# vec
+# #> [1]    0   42   42 1000
+# vec %in% 42 <- c(10, 100)
+# vec
+# #> [1]    0   10  100 1000
+# vec %!in% 5:100 <- 42
+# vec
+# #> [1]  42  10 100  42
+# vec <- letters[1:4]
+# vec %in% c("a","c") <- toupper
+# vec
+# #> [1] "A" "b" "C" "d"
+# vec %in% c("A","C") <- ~paste0(.,"!!!")
+# #> Loading required namespace: rlang
+# vec
+# #> [1] "A!!!" "b"    "C!!!" "d"
+

R/02_comparison.R

@@ -0,0 +1,140 @@
+#' Comparison Operators
+#'
+#'
+#'
+#' @param e1 lhs
+#' @param e2 rhs
+#' @param value replacement value
+#'
+#' @name comparison_ops
+NULL
+
+#' @rdname comparison_ops
+#' @export
+`>=<-` <- function(e1, e2, value){
+  cond <- e1 >= e2
+  if(any(cond)) {
+    if(inherits(value,"formula")) {
+      if (requireNamespace("rlang")) value <- rlang::as_function(value)
+      else stop("install package rlang to use `%in<-` with formula notation")
+    }
+    if(is.function(value)) value <- value(e1[cond])
+    replace(e1, cond, value)
+  } else e1
+}
+
+#' @rdname comparison_ops
+#' @export
+`><-` <- function(e1, e2, value){
+  cond <- e1 > e2
+  if(any(cond)) {
+    if(inherits(value,"formula")) {
+      if (requireNamespace("rlang")) value <- rlang::as_function(value)
+      else stop("install package rlang to use `%in<-` with formula notation")
+    }
+    if(is.function(value)) value <- value(e1[cond])
+    replace(e1, cond, value)
+  } else e1
+}
+
+#' @rdname comparison_ops
+#' @export
+`<=<-` <- function(e1, e2, value){
+  cond <- e1 <= e2
+  if(any(cond)) {
+    if(inherits(value,"formula")) {
+      if (requireNamespace("rlang")) value <- rlang::as_function(value)
+      else stop("install package rlang to use `%in<-` with formula notation")
+    }
+    if(is.function(value)) value <- value(e1[cond])
+    replace(e1, cond, value)
+  } else e1
+}
+
+#' @rdname comparison_ops
+#' @export
+`<<-` <- function(e1, e2, value){
+  # this one needs extra care so standard base::`<<-` still works
+  if (missing(value))
+    eval.parent(substitute(.Primitive("<<-")(e1, e2)))
+  else {
+    cond <- e1 < e2
+    if(any(cond)) {
+      if(inherits(value,"formula")) {
+        if (requireNamespace("rlang")) value <- rlang::as_function(value)
+        else stop("install package rlang to use `%in<-` with formula notation")
+      }
+      if(is.function(value)) value <- value(e1[cond])
+      replace(e1, cond, value)
+    } else e1
+  }
+}
+
+#' @rdname comparison_ops
+#' @export
+`==<-` <- function(e1, e2, value){
+  cond <- e1 == e2
+  if(any(cond)) {
+    if(inherits(value,"formula")) {
+      if (requireNamespace("rlang")) value <- rlang::as_function(value)
+      else stop("install package rlang to use `%in<-` with formula notation")
+    }
+    if(is.function(value)) value <- value(e1[cond])
+    replace(e1, cond, value)
+  } else e1
+}
+
+#' @rdname comparison_ops
+#' @export
+`!=<-` <- function(e1, e2, value){
+  cond <- e1 != e2
+  if(any(cond)) {
+    if(inherits(value,"formula")) {
+      if (requireNamespace("rlang")) value <- rlang::as_function(value)
+      else stop("install package rlang to use `%in<-` with formula notation")
+    }
+    if(is.function(value)) value <- value(e1[cond])
+    replace(e1, cond, value)
+  } else e1
+}
+
+#' @rdname comparison_ops
+#' @export
+`%subset>=%` <- function(e1, e2) e1[e1 >= e2]
+
+#' @rdname comparison_ops
+#' @export
+`%subset>%`  <- function(e1, e2) e1[e1 > e2]
+
+#' @rdname comparison_ops
+#' @export
+`%subset<=%` <- function(e1, e2) e1[e1 <= e2]
+
+#' @rdname comparison_ops
+#' @export
+`%subset<%`  <- function(e1, e2) e1[e1 < e2]
+
+#' @rdname comparison_ops
+#' @export
+`%subset==%` <- function(e1, e2) e1[e1 == e2]
+
+#' @rdname comparison_ops
+#' @export
+`%subset!=%` <- function(e1, e2) e1[e1 != e2]
+
+# vec <- c(0, 3, 6 ,9)
+# vec >= 5 <- 10
+# vec
+# #> [1]  0  3 10 10
+# vec == 10 <- ~.*7
+# vec
+# #> [1]  0  3 70 70
+# # no value above 1000, so no stop
+# vec >= 1000 <- ~ stop()
+# # stops if condition verified
+# vec >= 5 <- ~ stop("found value superior to 5!")
+# #> Error in value(e1[cond]): found value superior to 5!
+# vec %v>=% 3
+# #> [1]  3 70 70
+# vec %v==% 70
+# #> [1] 70 70