Add extract_surface()

NAMESPACE

@@ -7,6 +7,7 @@ export(exclusive_ancestors)
 export(exclusive_ancestors_ss)
 export(extract_ancestor)
 export(extract_demography)
+export(extract_surface)
 export(gglattice2d)
 export(maxabs)
 export(plot_tumor3d)

R/extract.R

@@ -9,6 +9,26 @@ altered_params = function(conf) {
     unlist() %>>% (.[. > 1]) %>>% names()
 }
 
+#' subfunction
+.extract_surface = function(mtrx, plane=c('x', 'y'), axis='z') {
+    tmpl = 'genealogy[which.%s(%s)]'
+    dplyr::group_by_(mtrx, .dots=plane) %>>%
+    dplyr::summarise_(min=sprintf(tmpl, 'min', axis),
+                      max=sprintf(tmpl, 'max', axis)) %>>%
+    {union(.$min, .$max)}
+}
+
+#' extract cells on suface
+#' @param mtrx a data.frame with (x, y, z) columns
+#' @return a string vector
+#' @rdname extract
+#' @export
+extract_surface = function(mtrx) {
+          .extract_surface(mtrx, c('x', 'y'), 'z') %>>%
+    union(.extract_surface(mtrx, c('y', 'z'), 'x')) %>>%
+    union(.extract_surface(mtrx, c('z', 'x'), 'y'))
+}
+
 #' extract demography from population data
 #' @param grouped_df a grouped_df
 #' @return a grouped data.frame

R/plot.R

@@ -41,9 +41,7 @@ plot_tumor3d = function(.data, .color='ancestor', .palette='Spectral') {
     .data[.color] = as.factor(.data[[.color]])
     num_colors = length(levels(.data[[.color]]))
     .palette = RColorBrewer::brewer.pal(num_colors, .palette)
-    thres = sphere_radius(nrow(.data)) * 0.6
     .data %>>%
-        dplyr::filter_(~sqrt(x^2 + y^2 + z^2) > thres) %>>%
         {rgl::spheres3d(.$x, .$y, .$z, color=.palette[.[[.color]]],
                         radius=1, alpha=1)}
     rgl::box3d()

R/read.R

@@ -30,7 +30,8 @@ read_conf = function(indir='.') {
 read_population = function(conf, params=NULL) {
     dplyr::group_by_(conf, .dots=c('path', params)) %>>%
     dplyr::do({
-        x = readr::read_tsv(file.path(.$path, 'population.tsv.gz'))
+        x = readr::read_tsv(file.path(.$path, 'population.tsv.gz')) %>>%
+            dplyr::mutate_(surface=~ genealogy %in% extract_surface(.))
         if (.$coord == 'hex') {
             x = trans_coord_hex(x)
         }