Add filter method to get.placement()

.gitignore

@@ -1,10 +1,11 @@
-.Rproj.user
-.Rhistory
-.RData
-*~
-.DS_Store
-.svn
-mkdocs/mysoftware
-__pycache__
-*.Rcheck
-*.html
+*.Rproj
+.Rproj.user
+.Rhistory
+.RData
+*~
+.DS_Store
+.svn
+mkdocs/mysoftware
+__pycache__
+*.Rcheck
+*.html

NAMESPACE

@@ -154,15 +154,13 @@ importFrom(dplyr,bind_rows)
 importFrom(dplyr,filter)
 importFrom(dplyr,full_join)
 importFrom(dplyr,group_by)
-importFrom(dplyr,mutate)
 importFrom(dplyr,mutate_if)
-importFrom(dplyr,n)
 importFrom(dplyr,pull)
 importFrom(dplyr,rename)
 importFrom(dplyr,select)
-importFrom(dplyr,summarize)
 importFrom(jsonlite,fromJSON)
 importFrom(jsonlite,toJSON)
+importFrom(magrittr,"%<>%")
 importFrom(magrittr,"%>%")
 importFrom(methods,"slot<-")
 importFrom(methods,.hasSlot)

R/jplace.R

@@ -25,44 +25,106 @@ read.jplace <- function(file) {
         file       = filename(file)
         )
 
-    res@data <- summarize_placement(res)
+    # res@data <- summarize_placement(res)
     return(res)
 }
 
-##' @importFrom dplyr summarize
-##' @importFrom dplyr mutate
-##' @importFrom dplyr group_by
-##' @importFrom dplyr n
-summarize_placement <- function(tree) {
-    place <- get.placements(tree, by="best")
-    ids <- tibble(node = nodeIds(tree, internal.only = FALSE))
-    group_by(place, .data$node) %>% summarize(nplace=n()) %>%
-        full_join(ids, by='node') %>%
-        mutate(nplace = ifelse(is.na(.data$nplace), 0, .data$nplace))
-}
+# ##' @importFrom dplyr summarize
+# ##' @importFrom dplyr mutate
+# ##' @importFrom dplyr group_by
+# ##' @importFrom dplyr n
+# summarize_placement <- function(tree) {
+#     place <- get.placements(tree, by="max_lwr")
+#     ids <- tibble(node = nodeIds(tree, internal.only = FALSE))
+#     group_by(place, .data$node) %>% summarize(nplace=n()) %>%
+#         full_join(ids, by='node') %>%
+#         mutate(nplace = ifelse(is.na(.data$nplace), 0, .data$nplace))
+# }
+
+
+#' @method get.placements jplace
+#' @param tree jtree
+#' @param by filter methods "all","max_lwr","max_pendant",
+#' "min_likelihood","lwr","pendant","likelihood"
+#' @param filter_value a given value to filter placements.
+#' @rdname get-placements
+#' @importFrom dplyr group_by
+#' @importFrom dplyr filter
+#' @importFrom magrittr %<>%
+#' @return a dataframe of placements
+#' @export
+#'
+#' @examples
+#' \donttest{
+#' jp <- system.file("extdata", "sample.jplace", package="treeio")
+#' jplace <- read.jplace(jp)
+#' placements <- get.placements(jplace,by="all")
+#' }
+get.placements.jplace <- function(tree, by="all", filter_value = NULL,...) {
+    jplist <- c("all","max_lwr","max_pendant",
+                "min_likelihood","lwr","pendant","likelihood")
+    if(!(by %in% jplist)){
+        stop("by should be one of all,max_lwr,max_pendant,
+              min_likelihood,lwr,pendant,likelihood")
+    }
+
+    if(by %in% c("lwr","pendant","likelihood")){
+        if(!is.null(filter_value)){
+            message("Placement will be filtered by the given value...")
+        }else{
+            stop("The filter_value should be given
+             in order to filter placement by the given value.")
+        }
+
+    }
 
-##' @method get.placements jplace
-##' @param by one of 'best' and 'all'
-##' @export
-##' @rdname get-placements
-##' @importFrom dplyr group_by
-##' @importFrom dplyr filter
-get.placements.jplace <- function(tree, by="best", ...) {
     placements <- tree@placements
-    if (!'likelihood' %in% names(placements))
+
+    if (by == "all")
         return(placements)
 
-    if (by == "best") {
-        ## http://astrostatistics.psu.edu/su07/R/html/base/html/all.equal.html
-        ## due to precision, number are identical maynot be equal,
-        ## so use all.equal which can test nearly equal number
-        ## if not equals, the output is a descript string of the differences
-        placements <- group_by(placements, .data$name) %>%
-            filter(.data$likelihood == min(.data$likelihood))
+    if (by == "max_lwr") {
+        if (!'like_weight_ratio' %in% names(placements)){
+            return(placements)
+        } else{
+            placements <- group_by(placements, .data$name) %>%
+                filter(.data$like_weight_ratio == max(.data$like_weight_ratio))
+        }
+
     }
+
+    if (by == "max_pendant"){
+        if (!'pendant_length' %in% names(placements)){
+            return(placements)
+        } else{
+            placements <- group_by(placements, .data$name) %>%
+                filter(.data$pendant_length == max(.data$pendant_length))
+        }
+    }
+
+    if (by == "min_likelihood"){
+        if (!'likelihood' %in% names(placements)){
+            return(placements)
+        } else{
+            placements <- group_by(placements, .data$name) %>%
+                filter(.data$likelihood == min(.data$likelihood))
+        }
+    }
+
+    if (by == "lwr"){
+        placements %<>% filter(.data$like_weight_ratio > filter_value)
+    }
+    if (by == "pendant"){
+        placements %<>% filter(.data$pendant_length > filter_value)
+    }
+    if (by == "likelihood"){
+        placements %<>% filter(.data$likelihood < filter_value)
+    }
+
     return(placements)
 }
 
+
 getplacedf <- function(places, nm){
     ## the first column of placements maybe a matrix or one numeric vector,
     ## so when it is numeric vector, the nplaces will be 1.
@@ -96,7 +158,7 @@ getplacedf <- function(places, nm){
     name <- rep(tmpn, rep(nplaces, nmsize)) 
     places.df <- do.call("rbind", places.df)
     places.df <- data.frame(name=name, places.df, stringsAsFactors=FALSE)
-    return(places.df) 
+    return(places.df)
 }
 
 

tests/testthat/test-treedata-accessor.R

@@ -8,7 +8,7 @@ pp <- get.placements(x)
 
 test_that("access placements slot for jplace object", {
     expect_true(is(x, "jplace"))
-    expect_equal(nrow(pp), 3)
+    expect_equal(nrow(pp), 7)
     expect_equal(ncol(pp), 7)
     expect_true('likelihood' %in% names(pp))
 })