diff --git a/DESCRIPTION b/DESCRIPTION index 58172ea..57b61c2 100755 --- a/DESCRIPTION +++ b/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 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, diff --git a/NAMESPACE b/NAMESPACE index fdf8205..fc5eadd 100755 --- a/NAMESPACE +++ b/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) diff --git a/R/fhs.R b/R/fhs.R new file mode 100644 index 0000000..cc6bfd4 --- /dev/null +++ b/R/fhs.R @@ -0,0 +1,85 @@ +## Author: Wajid Jawaid +## Email: wj241@cam.ac.uk +## 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)) +} diff --git a/R/functions_OLD.R b/R/functions_OLD.R index f67641a..8aec99d 100644 --- a/R/functions_OLD.R +++ b/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, ...)) diff --git a/R/functions_chr_int.R b/R/functions_chr_int.R index 38311ef..82d5a6f 100644 --- a/R/functions_chr_int.R +++ b/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()) diff --git a/R/gatepoints.R b/R/gatepoints.R index a1eb9f6..0a6ce9f 100644 --- a/R/gatepoints.R +++ b/R/gatepoints.R @@ -1,5 +1,5 @@ # Authors@R: person("Wajid", "Jawaid", email = "wj241@cam.ac.uk", 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) { diff --git a/man/fhs.Rd b/man/fhs.Rd new file mode 100644 index 0000000..c21ba94 --- /dev/null +++ b/man/fhs.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fhs.R +\name{fhs} +\alias{fhs} +\title{Freehand select} +\usage{ +fhs(data, mark = TRUE, names = TRUE, ...) +} +\arguments{ +\item{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.} + +\item{mark}{Default TRUE. Predicate marking of selected points.} + +\item{names}{Default TRUE. If TRUE will return rownames of data frame with +points within polygon. If FALSE will return logical vector.} + +\item{...}{Additional parameters passed to \code{\link{points}}.} +} +\value{ +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. +} +\description{ +Freehand select +} +\details{ +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}. +} +\examples{ +\dontrun{ +x <- cbind(1:10, 1:10) +rownames(x) <- 1:10 +plot(x, pch = 16, col = "red") +fhs(x) +} +} +\author{ +Wajid Jawaid +}