Integrate gatepoints

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: tidygate
 Type: Package
 Title: Add Gate Information to Your Tibble
-Version: 0.3.1
+Version: 0.4.0
 Authors@R: 
     c(person(given = "Stefano",
            family = "Mangiola",
@@ -12,7 +12,7 @@ Authors@R:
              role = "ctb"))
 Maintainer: Stefano Mangiola <[email protected]>
 Description: It interactively or programmatically label points within custom gates on two dimensions. 
-    The information is added to your tibble. It is based on the package 'gatepoints' from Wajid Jawaid. 
+    The information is added to your tibble. It is based on the package 'gatepoints' from Wajid Jawaid (who is also author of this package). The code of gatepoints was nto integrated in tidygate. 
     The benefits are (i) in interactive mode you can draw your gates on extensive 'ggplot'-like scatter plots; 
     (ii) you can draw multiple gates; and (iii) you can save your gates and apply the programmatically.
 License: GPL-3
@@ -28,7 +28,6 @@ Imports:
     utils,
     graphics,
     lifecycle,
-    gatepoints,
     scales,
     magrittr,
     tibble,

NAMESPACE

@@ -4,6 +4,7 @@ S3method(gate,spec_tbl_df)
 S3method(gate,tbl_df)
 S3method(gate_chr,numeric)
 S3method(gate_int,numeric)
+export(fhs)
 export(gate)
 export(gate_chr)
 export(gate_int)
@@ -14,8 +15,11 @@ importFrom(RColorBrewer,brewer.pal)
 importFrom(grDevices,colorRampPalette)
 importFrom(graphics,axis)
 importFrom(graphics,legend)
+importFrom(graphics,lines)
+importFrom(graphics,locator)
 importFrom(graphics,par)
 importFrom(graphics,plot)
+importFrom(graphics,points)
 importFrom(lifecycle,deprecate_warn)
 importFrom(magrittr,"%>%")
 importFrom(magrittr,equals)

R/fhs.R

@@ -0,0 +1,85 @@
+## Author: Wajid Jawaid
+## Email: [email protected]
+## Date: 14 November 2016
+
+##' Freehand select
+##'
+##' Freehand select function. First generate a 2D plot using R's plot function, 
+##' then select gate region by left clicking. Close polygon by right clicking.
+##' The function will return the rownames of the enclosed points by the rownames
+##' of th co-ordinates given in \code{data}.
+##' @title Freehand select
+##' @param data Data frame or matrix of co-ordinates. (x,y) co-ordinates for each
+##' point will be on rows. Rownames of selected points will be returned.
+##' @param mark Default TRUE. Predicate marking of selected points.
+##' @param names Default TRUE. If TRUE will return rownames of data frame with
+##' points within polygon. If FALSE will return logical vector.
+##' @param ... Additional parameters passed to \code{\link{points}}.
+##' @return Returns character vector of rownames of the selected points from \code{data} if
+##' names parameter is TRUE. If names is FALSE then a logical vector indicating whether points
+##' are in the polygon is returned.
+##' @author Wajid Jawaid
+##' @export
+##' @examples
+##' \dontrun{
+##' x <- cbind(1:10, 1:10)
+##' rownames(x) <- 1:10
+##' plot(x, pch = 16, col = "red")
+##' fhs(x)
+##' }
+##' @importFrom graphics locator lines points
+fhs <- function(data, mark = TRUE, names = TRUE, ...) {
+  cat("Mark region on plot.\n")
+  if (!(is.data.frame(data) || is.matrix(data))) stop("data must be a data frame or matrix")
+  if (is.null(rownames(data))) rownames(data) <- 1:nrow(data)
+  sel <- selectGate()
+  xr <- range(sel$x)
+  yr <- range(sel$y)
+  xPass <- (data[,1] > xr[1]) & (data[,1] < xr[2])
+  yPass <- (data[,2] > yr[1]) & (data[,2] < yr[2])
+  inROI <- applyGate(data[xPass & yPass,,drop=FALSE], sel)
+  if (mark) points(data[xPass & yPass,,drop=FALSE][inROI,1:2,drop=FALSE], ...)
+  cp <- rep(FALSE, nrow(data))
+  cp[xPass & yPass][inROI] <- TRUE
+  cNames <- rownames(data)[cp]
+  attr(cNames, "gate") <- attr(cp, "gate") <- sel
+  if (names) return(cNames)
+  return(cp)
+}
+
+selectGate <- function() {
+  sel <- locator(type = "l")
+  if (length(sel$x) < 3) stop("Please select at least 3 points to define a shape.")
+  numPoints <- length(sel$x)
+  lines(x = sel$x[c(1, numPoints)], y = sel$y[c(1, numPoints)])
+  sel <- as.data.frame(sel)
+  return(sel)
+}
+
+applyGate <- function(data, v) {
+  np <- nrow(data)
+  nl <- nrow(v)
+  gv <- c(v[,1], v[1,1])
+  ip <- blw <- blw1 <- blw2 <- chk <- inGate <- vector("logical", np)
+  for (i in 1:np) {
+    ip <- as.logical(abs(diff(data[i,1] <= gv)))
+    blw1 <- data[i,2] >= v[,2]
+    blw2 <- data[i,2] >= c(v[-1,2], v[1,2])
+    blw <- blw1 & blw2
+    chk <- xor(blw1, blw2)
+    for (j in (1:length(chk))[chk]) {
+      k = (j %% nl) + 1
+      ## x1 = v[j, 1]; x2 = v[k, 1]; y1 = v[j, 2]; y2 = v[k,2]
+      if ( v[j,1] != v[k, 1]) {
+        cfs <- (matrix(c(1, -v[k, 1], -1, v[j,1]), 2) / (v[j, 1] - v[k, 1])) %*%
+          c(v[c(j,k), 2])
+        py <- matrix(c(data[i, 1], 1), 1) %*% cfs
+        if (data[i, 2] > py) blw[j] <- TRUE
+      } else {
+        blw[j] <- TRUE
+      }
+    }
+    inGate[i] <- sum(ip & blw) %% 2
+  }
+  return(as.logical(inGate))
+}

R/functions_OLD.R

@@ -284,7 +284,7 @@ gate_interactive <-
     )
 
     # Loop over gates # Variable needed for recalling the attributes later
-    gate_list = map(1:how_many_gates,  ~ my_matrix %>% gatepoints::fhs(mark = TRUE, ...))
+    gate_list = map(1:how_many_gates,  ~ my_matrix %>% fhs(mark = TRUE, ...))
 
 
 

R/functions_chr_int.R

@@ -326,7 +326,7 @@ gate_interactive_chr_int <-
 
     # Loop over gates # Variable needed for recalling the attributes later
     gate_list = map(1:how_many_gates,
-                    ~ my_matrix %>% gatepoints::fhs(mark = TRUE, ...))
+                    ~ my_matrix %>% fhs(mark = TRUE, ...))
 
     # Save gate list
     temp_file = sprintf("%s.rds", tempfile())

R/gatepoints.R

@@ -1,5 +1,5 @@
 # Authors@R: person("Wajid", "Jawaid", email = "[email protected]", role = c("aut", "cre"))
-# This has been copied from https://github.com/wjawaid/gatepoints
+# This has been copied from https://github.com/wjawaid/gatepoints with the permission of the author, who is also author on tidygate
 # For allowing programmatically application of defined gates, since these functions are hidden from the package
 
 applyGate <- function(data, v) {