Merge pull request #45 from xiangpin/master

supporting the main plot with coord_fixed

Author: GuangchuangYu

Makefile

@@ -23,7 +23,7 @@ build2: rd
 	cd ..;\
 	R CMD build --no-build-vignettes $(PKGSRC)
 
-install: build
+install: build2
 	cd ..;\
 	R CMD INSTALL $(PKGNAME)_$(PKGVERS).tar.gz
 

NAMESPACE

@@ -39,6 +39,7 @@ importFrom(ggfun,yrange)
 importFrom(ggplot2,aes)
 importFrom(ggplot2,annotation_custom)
 importFrom(ggplot2,coord_cartesian)
+importFrom(ggplot2,coord_fixed)
 importFrom(ggplot2,element_blank)
 importFrom(ggplot2,element_text)
 importFrom(ggplot2,ggplot)

R/aplot.R

@@ -50,26 +50,35 @@ as.patchwork <- function(x,
         return(res)
     }
 
-    mp <- x$plotlist[[1]]
+    mp <- x[[1]]
     if ( length(x$plotlist) == 1) {
         return(ggplotGrob(mp))
     }
-    
+    width <- x$width
+    height <- x$height
     if(align == "x" || align == "xy"){
-        for (i in x$layout[, x$main_col]) {
+        for (ind in seq(length(x$layout[, x$main_col]))) {
+            i <- x$layout[,x$main_col][ind]
             if (is.na(i)) next
             if (i == 1) next
-            x$plotlist[[i]] <- suppressMessages(x$plotlist[[i]] + xlim2(mp))
+            x[[i]] <- suppressMessages(x[[i]] + xlim2(mp))
+            x <- adjust_coord(x, i, ind, type = "height")
         }
     }
 
     if(align == "y" || align == "xy"){
-        for (i in x$layout[x$main_row,]) {
+        for (ind in seq(length(x$layout[x$main_row,]))) {
+            i <- x$layout[x$main_row,][ind]
             if(is.na(i)) next
             if (i == 1) next
-            x$plotlist[[i]] <- suppressMessages(x$plotlist[[i]] + ylim2(mp))
+            x[[i]] <- suppressMessages(x[[i]] + ylim2(mp))
+            x <- adjust_coord(x, i, ind, type = "width")
         }
     }
+
+    if (is.coord_fixed(mp)){
+        width <- height <- NULL
+    }
 
     idx <- as.vector(x$layout)
     idx[is.na(idx)] <- x$n + 1 
@@ -104,8 +113,8 @@ as.patchwork <- function(x,
 
     pp + plot_layout(byrow=F,
                      ncol=ncol(x$layout),
-                     widths = x$width,
-                     heights= x$height,
+                     widths = width,
+                     heights= height,
                      guides = guides)
 }
 

R/method-accessor.R

@@ -1,37 +1,52 @@
 ##' @method [[ aplot
 ##' @export
 `[[.aplot` <- function(x, i){
-    x$plotlist[[i]]
+    if(inherits(i, "numeric")){
+       return(x$plotlist[[i]])
+    }
+    NextMethod()
 }
 
 ##' @method [ aplot
 ##' @export
 `[.aplot` <- function(x, i, j, ...){
-    x[[x$layout[i, j]]]
+    if (inherits(i, "numeric") && inherits(i, "numeric")){
+       return(x[[x$layout[i, j]]])
+    }
+    NextMethod()
 }
 
 ##' @method [[<- aplot
 ##' @export
 `[[<-.aplot` <- function(x, i, value){
-    if(!inherits(value, 'ggplot')){
-        stop('The value should be a ggplot object.')
+    if (inherits(i, "numeric")){
+       if(!inherits(value, 'ggplot')){
+           stop('The value should be a ggplot object.')
+       }
+       
+       x$plotlist[[i]] <- value
+       return(x)
     }
-    x$plotlist[[i]] <- value
+    x <- NextMethod(value)
     return(x)
 }
 
 
 ##' @method [<- aplot
 ##' @export
 `[<-.aplot` <- function(x, i, j, value){
-    if (!inherits(value, 'ggplot')){
-        stop('The value should be a ggplot object.')
-    }else if (is.na(x$layout[i, j])){
-        stop(paste0('The subplot which local in row ', i, 
-                    ' and col ', j, 
-                    ' is NULL, it can not be replaced.'))
+    if (inherits(i, "numeric") && inherits(i, "numeric")){
+       if (!inherits(value, 'ggplot')){
+           stop('The value should be a ggplot object.')
+       }else if (is.na(x$layout[i, j])){
+           stop(paste0('The subplot which local in row ', i, 
+                       ' and col ', j, 
+                       ' is NULL, it can not be replaced.'))
+       }
+       x[[x$layout[i, j]]] <- value
+       return(x)
     }
-    x[[x$layout[i, j]]] <- value
+    x <- NextMethod(value)
     return(x)
 }
 

R/utilities.R

@@ -19,3 +19,41 @@ is.coord_flip <- function(p) {
     inherits(p, "gg") && inherits(p$coordinates, "CoordFlip")
 }
 
+is.coord_fixed <- function(p){
+    inherits(p, "gg") && inherits(p$coordinates, "CoordFixed")
+}
+
+#' @importFrom ggplot2 coord_fixed
+adjust_coord <- function(x, i, ind, type='width'){
+    coordfixed <- is.coord_fixed(x[[1]])
+    coordfixed2 <- !is.coord_fixed(x[[i]])
+    ratio <- 1
+    if (coordfixed && coordfixed2){
+        ajustcoord <- getOption("ajust_coord", default = TRUE)
+        if (ajustcoord) ratio <- .cal_ratio(x[[i]], x[[type]][ind], type)
+        x[[i]] <- suppressMessages(x[[i]] + coord_fixed(ratio = ratio))
+
+    }
+    return(x)
+}
+
+.cal_ratio <- function(x, size, type='width'){
+    xr <- .cal_limit_range(xlim2(x)$limits)
+    yr <- .cal_limit_range(ylim2(x)$limits)
+    val <- xr / yr
+    if (type == 'width'){
+        val <- val / size
+    }else{
+        val <- val * size
+    }
+    return(val)
+}
+
+.cal_limit_range <- function(x){
+    if (inherits(x, "character")){
+        res <- length(x)
+    }else if(inherits(x, "numeric")){
+        res <- diff(x)
+    }
+    return(res)
+}