From d558b743b0242b24c0947b66581b60eab2931748 Mon Sep 17 00:00:00 2001 From: djvill Date: Sun, 11 Sep 2016 16:38:27 -0700 Subject: [PATCH 1/5] Fixed var.col.by==group legend bug Previously, when definining both vowel and group, the wrong colors showed up in the legend if var.col.by was the same as group (the right colors showed up if var.col.by was the same as vowel). Fixed bug by changing definition of byd, such that if var.col.by==group, byd has length(unique(group)) rows and length(unique(vowel)) columns. --- R/phonR.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/phonR.R b/R/phonR.R index 1a3d1c1..d0f33cc 100644 --- a/R/phonR.R +++ b/R/phonR.R @@ -469,8 +469,12 @@ 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) + # print("gf-v") } else { byd <- by(d, d[c("v", "gf")], identity) + # print("v-gf") } ## dataframe of means. at this point each element of "byd" should have ## exactly 1 vowel and 1 grouping factor (gf) value @@ -1053,6 +1057,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)) } From 60cd43c47315ee9bf2b3080be52c07b815ee7552 Mon Sep 17 00:00:00 2001 From: djvill Date: Sun, 11 Sep 2016 18:44:14 -0700 Subject: [PATCH 2/5] Partially fixed poly.line=TRUE & var.col.by==group bug Fixed a bug with poly.line whereby all lines would be the same linetype if var.col.by had the same value as group. The issue had to do with the code setting poly.line.sty based on the value of var.sty.by regardless of the grouping variable. Introduced a bug in the legend where linetypes display on the wrong lines when var.sty.by!=NULL. --- R/phonR.R | 29 ++++++++++++++++++++++++----- 1 file changed, 24 insertions(+), 5 deletions(-) diff --git a/R/phonR.R b/R/phonR.R index d0f33cc..f21af24 100644 --- a/R/phonR.R +++ b/R/phonR.R @@ -306,12 +306,24 @@ 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] + # print("var.col.by==group") + } else { + exargs$lty <- rep(exargs$lty, length.out=num.sty)[var.sty.by] + # print("var.sty.by==group") + } 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 +390,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 @@ -448,6 +466,7 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL, d <- data.frame(f1=f1, f2=f2, v=v, gf=factor(gf, levels=unique(gf)), col.tokens=col.tokens, col.means=col.means, style=var.sty.by, lty=exargs$lty, lwd=exargs$lwd, + # style=var.sty.by, lty=poly.line.sty, lwd=exargs$lwd, ellipse.fill.col=ellipse.fill.col, ellipse.line.col=ellipse.line.col, ellipse.line.sty=ellipse.line.sty, From 8a5c85c270f47ed545041ee607359ebf4f375e4f Mon Sep 17 00:00:00 2001 From: djvill Date: Sun, 11 Sep 2016 20:16:20 -0700 Subject: [PATCH 3/5] Fixed legend.lty bug Fixed bug introduced in previous commit; legend correctly shows correct poly.line linetypes for groups when var.sty.by==vowel and var.col.by==group. --- R/phonR.R | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/R/phonR.R b/R/phonR.R index f21af24..47e317e 100644 --- a/R/phonR.R +++ b/R/phonR.R @@ -466,7 +466,6 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL, d <- data.frame(f1=f1, f2=f2, v=v, gf=factor(gf, levels=unique(gf)), col.tokens=col.tokens, col.means=col.means, style=var.sty.by, lty=exargs$lty, lwd=exargs$lwd, - # style=var.sty.by, lty=poly.line.sty, lwd=exargs$lwd, ellipse.fill.col=ellipse.fill.col, ellipse.line.col=ellipse.line.col, ellipse.line.sty=ellipse.line.sty, @@ -983,6 +982,7 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL, } else if (!(length(unique(poly.line.sty)) == 1 && poly.line.sty[1] == 0)) { legend.lty <- sapply(bym, function(i) unique(i$poly.line.sty)) + # print(legend.lty) } else { legend.lty <- unique(hull.line.sty) } @@ -998,14 +998,21 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL, } } ## handle lty specially; needed for both style & color + # print(legend.lty) + ##NEED TO DETERMINE WHICH IS THE LTY GROUP AND THEN APPLY NAS if (!is.null(legend.lty)) { if (!length(legend.style.lab)) { 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))) + } } } + # print(legend.lty) ## reconcile if (identical(legend.style.lab, legend.col.lab)) { legend.lab <- legend.col.lab @@ -1066,6 +1073,7 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL, } ## draw legend do.call(legend, legend.args) + # return(legend.args) } } From f7aab7bc2833717a07b46168b2c6ec755955ca4b Mon Sep 17 00:00:00 2001 From: djvill Date: Sun, 11 Sep 2016 20:43:40 -0700 Subject: [PATCH 4/5] Fixed legend.bgf bug Fixed a bug in the legend whereby colored boxes for vowels didn't show up in the legend if plotting poly.lines with var.col.by==vowel and var.sty.by==group. --- R/phonR.R | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/R/phonR.R b/R/phonR.R index 47e317e..a8786eb 100644 --- a/R/phonR.R +++ b/R/phonR.R @@ -319,10 +319,8 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL, if (vary.col) exargs$col <- rep(exargs$col, length.out=num.col)[var.col.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] - # print("var.col.by==group") } else { exargs$lty <- rep(exargs$lty, length.out=num.sty)[var.sty.by] - # print("var.sty.by==group") } if (vary.sty) exargs$pch <- rep(exargs$pch, length.out=num.sty)[var.sty.by] ## set defaults for token and mean plotting characters @@ -489,10 +487,8 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL, 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) - # print("gf-v") } else { byd <- by(d, d[c("v", "gf")], identity) - # print("v-gf") } ## dataframe of means. at this point each element of "byd" should have ## exactly 1 vowel and 1 grouping factor (gf) value @@ -982,7 +978,6 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL, } else if (!(length(unique(poly.line.sty)) == 1 && poly.line.sty[1] == 0)) { legend.lty <- sapply(bym, function(i) unique(i$poly.line.sty)) - # print(legend.lty) } else { legend.lty <- unique(hull.line.sty) } @@ -998,8 +993,6 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL, } } ## handle lty specially; needed for both style & color - # print(legend.lty) - ##NEED TO DETERMINE WHICH IS THE LTY GROUP AND THEN APPLY NAS if (!is.null(legend.lty)) { if (!length(legend.style.lab)) { legend.lty <- rep(legend.lty, @@ -1012,7 +1005,6 @@ plotVowels <- function(f1, f2, vowel=NULL, group=NULL, } } } - # print(legend.lty) ## reconcile if (identical(legend.style.lab, legend.col.lab)) { legend.lab <- legend.col.lab @@ -1036,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)) From 69b434f905088fab93ae4b7a1dd34db04c8f330e Mon Sep 17 00:00:00 2001 From: Daniel McCloy Date: Mon, 12 Sep 2016 11:39:40 -0700 Subject: [PATCH 5/5] add script to test legend generation --- tests/test-legend.R | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 tests/test-legend.R diff --git a/tests/test-legend.R b/tests/test-legend.R new file mode 100644 index 0000000..71cb097 --- /dev/null +++ b/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()