Merge legend and poly.line bugfixes into master

R/phonR.R

@@ -306,12 +306,22 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL,
     ## color: use default pallete if none specified and pretty=FALSE
     if (!"col" %in% names(exargs)) exargs$col <- palette()
     ## linetypes & plotting characters
-    if (!"lty" %in% names(exargs)) exargs$lty <- seq_len(num.sty)
+    if (!"lty" %in% names(exargs)) {
+        if (all(var.col.by==as.numeric(factor(group, levels=unique(group))))) {
+            exargs$lty <- seq_len(num.col)
+        } else {
+            exargs$lty <- seq_len(num.sty)
+        }
+    }
     if (!"pch" %in% names(exargs)) exargs$pch <- seq_len(num.sty)
     if (!"lwd" %in% names(exargs)) exargs$lwd <- par("lwd")
     ## recycle user-specified colors to the length we need
     if (vary.col) exargs$col <- rep(exargs$col, length.out=num.col)[var.col.by]
-    if (vary.sty) exargs$lty <- rep(exargs$lty, length.out=num.sty)[var.sty.by]
+    if (all(var.col.by==as.numeric(factor(group, levels=unique(group))))) {
+        exargs$lty <- rep(exargs$lty, length.out=num.col)[var.col.by]
+    } else {
+        exargs$lty <- rep(exargs$lty, length.out=num.sty)[var.sty.by]
+    }
     if (vary.sty) exargs$pch <- rep(exargs$pch, length.out=num.sty)[var.sty.by]
     ## set defaults for token and mean plotting characters
     if (is.null(pch.tokens)) pch.t <- exargs$pch
@@ -378,9 +388,15 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL,
     ## polygon colors
     if (poly.line) {
         if ("lty" %in% names(poly.args)) {
-            poly.args$lty <- rep(poly.args$lty, length.out=num.sty)
-            if (vary.sty) poly.line.sty <- poly.args$lty[var.sty.by]
-            else          poly.line.sty <- poly.args$lty
+            if (all(var.sty.by==as.numeric(factor(group, levels=unique(group))))) {
+                poly.args$lty <- rep(poly.args$lty, length.out=num.sty)
+                poly.line.sty <- poly.args$lty[var.sty.by]
+            } else if (all(var.col.by==as.numeric(factor(group, levels=unique(group))))) {
+                poly.args$lty <- rep(poly.args$lty, length.out=num.col)
+                poly.line.sty <- poly.args$lty[var.col.by]
+            } else {
+                poly.line.sty <- poly.args$lty
+            }
             poly.args$lty <- NULL
         } else {
             poly.line.sty <- exargs$lty
@@ -469,6 +485,8 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL,
     }
     if (is.null(vowel) && is.null(group)) {
         byd <- list(d=d)
+    } else if (all(var.col.by==as.numeric(factor(group, levels=unique(group))))) {
+        byd <- by(d, d[c("gf","v")], identity)
     } else {
         byd <- by(d, d[c("v", "gf")], identity)
     }
@@ -980,7 +998,11 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL,
                     legend.lty <- rep(legend.lty,
                                       length.out=length(legend.col.lab))
                 } else if (length(legend.col.lab)) {
-                    legend.lty <- c(legend.lty, rep(NA, length(legend.col.lab)))
+                    if (all(var.col.by==as.numeric(factor(group,levels=unique(group))))) {
+                        legend.lty <- c(rep(NA, length(legend.style.lab)), legend.lty)
+                    } else {
+                        legend.lty <- c(legend.lty, rep(NA, length(legend.col.lab)))
+                    }
                 }
             }
             ## reconcile
@@ -1006,6 +1028,14 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL,
                     legend.brd <- legend.bgf
                     legend.col <- c(rep(par("fg"), length(legend.style.lab)),
                                     legend.col)
+                ## handle case: col.by.vowel and poly.line & sty by group
+                } else if (vary.sty && vary.col && is.null(legend.bgf) && poly.line &&
+                           all(var.sty.by==as.numeric(factor(group,levels=unique(group))))) {
+                    legend.col <- c(rep(par("fg"), length(legend.style.lab)),
+                                    legend.col)
+                    legend.bgf <- c(rep(NA, length(legend.style.lab)),
+                                    legend.col[-(1:length(legend.style.lab))])
+                    legend.brd <- legend.bgf
                 ## handle other cases
                 } else {
                     nas <- rep(NA, length(legend.style.lab))
@@ -1043,6 +1073,7 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL,
             }
             ## draw legend
             do.call(legend, legend.args)
+            # return(legend.args)
         }
     }
 
@@ -1053,6 +1084,7 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL,
     if (output != "screen") dev.off()
     ## reset graphical parameters to defaults
     par(op)
+    # return(list(byd, group, var.col.by, legend.col))
 }
 
 

tests/test-legend.R

@@ -0,0 +1,21 @@
+#!/usr/bin/env R
+
+source("../R/phonR.R")
+load("../data/indoVowels.rda")
+
+colorby <- rep(c("vowel", "subj", "gender"), each=3)
+styleby <- rep(c("vowel", "subj", "gender"), times=3)
+grouping <- c("subj", "gender", NA, "gender", NA, "subj", NA, "subj", "gender")
+
+
+cairo_pdf("test-legend-master.pdf", width=16, height=16, pointsize=12, 
+          family="Charis SIL")
+    par(mfrow=c(3, 3))
+    mapply(FUN=function(cb, sb, gr) {
+        title <- paste0("var.col.by=", cb, ", var.sty.by=", sb, ", group=", gr, collapse="")
+        plotVowels(indo$f1, indo$f2, indo$vowel, group=indo[[gr]], 
+                 var.col.by=indo[[cb]], var.sty.by=indo[[sb]], pretty=TRUE,
+                 plot.tokens=TRUE, plot.means=FALSE, ellipse.line=TRUE, 
+                 legend.kwd='bottomright', main=title)
+        }, colorby, styleby, grouping)
+dev.off()