├── .github ├── .gitignore └── workflows │ └── pkgdown.yaml ├── LICENSE ├── _pkgdown.yml ├── man ├── figures │ ├── logo.png │ ├── besag_met_missing.png │ ├── yates_oats_design.png │ ├── yates_oats_yield.png │ └── yates_oats_design_ggplot.png ├── RedGrayBlue.Rd ├── panel.outlinelevelplot.Rd ├── geom_tileborder.Rd └── desplot.Rd ├── old ├── desplot_logo.png └── desplot_logo.xcf ├── tests ├── testthat.R └── testthat │ ├── test_named_colors.R │ └── test_desplot.R ├── .gitignore ├── NAMESPACE ├── vignettes ├── desplot.bib └── desplot_examples.Rmd ├── .Rbuildignore ├── DESCRIPTION ├── LICENSE.md ├── NEWS.md ├── README.md ├── R ├── geom_tileborder.R ├── ggdesplot.R └── desplot.R └── cran-comments.md /.github/.gitignore: -------------------------------------------------------------------------------- 1 | *.html 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2023 2 | COPYRIGHT HOLDER: desplot authors 3 | -------------------------------------------------------------------------------- /_pkgdown.yml: -------------------------------------------------------------------------------- 1 | url: http://kwstat.github.io/desplot/ 2 | template: 3 | bootstrap: 5 4 | 5 | -------------------------------------------------------------------------------- /man/figures/logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kwstat/desplot/HEAD/man/figures/logo.png -------------------------------------------------------------------------------- /old/desplot_logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kwstat/desplot/HEAD/old/desplot_logo.png -------------------------------------------------------------------------------- /old/desplot_logo.xcf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kwstat/desplot/HEAD/old/desplot_logo.xcf -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(desplot) 3 | 4 | test_check("desplot") 5 | -------------------------------------------------------------------------------- /man/figures/besag_met_missing.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kwstat/desplot/HEAD/man/figures/besag_met_missing.png -------------------------------------------------------------------------------- /man/figures/yates_oats_design.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kwstat/desplot/HEAD/man/figures/yates_oats_design.png -------------------------------------------------------------------------------- /man/figures/yates_oats_yield.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kwstat/desplot/HEAD/man/figures/yates_oats_yield.png -------------------------------------------------------------------------------- /man/figures/yates_oats_design_ggplot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kwstat/desplot/HEAD/man/figures/yates_oats_design_ggplot.png -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Emacs backup files 2 | *~ 3 | \#*\# 4 | # Emacs backups of hidden files, like ".gitignore.~3~" 5 | .*.~*~ 6 | .\#* 7 | # RStudio/R GUI 8 | .Rbuildignore 9 | .RData 10 | .Rhistory 11 | .Rproj.user 12 | *.Rproj 13 | # Vignettes 14 | vignettes/*.bbl 15 | vignettes/*.log 16 | vignettes/*.md 17 | vignettes/*.pdf 18 | vignettes/*.synctex.gz 19 | vignettes/*.tex 20 | man 21 | revdep 22 | pkgdown 23 | CRAN-RELEASE 24 | docs 25 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | export(RedGrayBlue) 4 | export(StatTileBorder) 5 | export(desplot) 6 | export(geom_tileborder) 7 | export(ggdesplot) 8 | export(panel.outlinelevelplot) 9 | import(ggplot2) 10 | import(grid) 11 | import(lattice) 12 | importFrom(ggplot2,Stat) 13 | importFrom(ggplot2,ggproto) 14 | importFrom(reshape2,acast) 15 | importFrom(reshape2,melt) 16 | importFrom(rlang,.data) 17 | importFrom(stats,as.formula) 18 | importFrom(stats,formula) 19 | importFrom(stats,median) 20 | -------------------------------------------------------------------------------- /vignettes/desplot.bib: -------------------------------------------------------------------------------- 1 | 2 | @article{ryder1981field, 3 | title = {Field plans: why the biometrician finds them useful}, 4 | author = {K. Ryder}, 5 | journal = {Experimental Agriculture}, 6 | volume = 17, 7 | pages = {243--256}, 8 | year = 1981, 9 | doi={10.1017/S0014479700011601} 10 | } 11 | @article{yates1935complex, 12 | title={Complex experiments}, 13 | author={Yates, Frank}, 14 | journal={Journal of the Royal Statistical Society Suppl}, 15 | volume=2, 16 | pages={181-247}, 17 | year=1935, 18 | doi={10.2307/2983638} 19 | } 20 | -------------------------------------------------------------------------------- /man/RedGrayBlue.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/desplot.R 3 | \name{RedGrayBlue} 4 | \alias{RedGrayBlue} 5 | \title{Function to create a Red-Gray-Blue palette} 6 | \usage{ 7 | RedGrayBlue(n) 8 | } 9 | \arguments{ 10 | \item{n}{Number of colors to create} 11 | } 12 | \value{ 13 | A vector of n colors. 14 | } 15 | \description{ 16 | A function to create a Red-Gray-Blue palette. 17 | } 18 | \details{ 19 | Using gray instead of white allows missing values to appear as white 20 | (actually, transparent). 21 | } 22 | \examples{ 23 | pie(rep(1,11), col=RedGrayBlue(11)) 24 | title("RedGrayBlue(11)") 25 | } 26 | \author{ 27 | Kevin Wright 28 | } 29 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | # .Rbuildignore 2 | 3 | # Do not put "LICENSE" below. R needs to see that file. 4 | 5 | # ----- Git ----- 6 | ^.gitignore$ 7 | ^\.github$ 8 | 9 | # ----- devtools ----- 10 | ^revdep$ 11 | 12 | # ----- R ----- 13 | ^\.RData$ 14 | ^\.Rhistory$ 15 | ^cran-comments\.md$ 16 | ^README\.md$ 17 | ^$NEWS\.md$ 18 | ^notes\.Rmd$ 19 | ^notes\.md$ 20 | ^data-done$ 21 | ^data-raw$ 22 | ^data-unused$ 23 | ^figure$ 24 | ^Rplots\.pdf$ 25 | ^debug\.log$ 26 | 27 | # ----- RStudio ----- 28 | ^.*\.Rproj$ 29 | ^\.Rproj\.user$ 30 | 31 | # ----- testthat ----- 32 | ^tests/testthat/Rplots.pdf$ 33 | ^tests/testthat/.*\.png$ 34 | ^tests/testthat/.*\.html$ 35 | 36 | # ----- Travis ----- 37 | ^.travis\.yml 38 | 39 | ^_pkgdown\.yml$ 40 | ^docs$ 41 | ^pkgdown$ 42 | ^CRAN-RELEASE$ 43 | ^LICENSE\.md$ 44 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Type: Package 2 | Package: desplot 3 | Title: Plotting Field Plans for Agricultural Experiments 4 | Version: 1.11 5 | Authors@R: 6 | person("Kevin", "Wright", , "kw.stat@gmail.com", role = c("aut", "cre", "cph"), 7 | comment = c(ORCID = "0000-0002-0617-8673")) 8 | Description: A function for plotting maps of agricultural field 9 | experiments that are laid out in grids. See Ryder (1981) 10 | . 11 | License: MIT + file LICENSE 12 | URL: https://kwstat.github.io/desplot/, http://kwstat.github.io/desplot/ 13 | BugReports: https://github.com/kwstat/desplot/issues 14 | Imports: 15 | ggplot2, 16 | grid, 17 | lattice, 18 | reshape2, 19 | rlang 20 | Suggests: 21 | agridat, 22 | knitr, 23 | rmarkdown, 24 | testthat 25 | VignetteBuilder: 26 | knitr 27 | Encoding: UTF-8 28 | Language: en-US 29 | RoxygenNote: 7.3.3 30 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | # MIT License 2 | 3 | Copyright (c) 2023 desplot authors 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /.github/workflows/pkgdown.yaml: -------------------------------------------------------------------------------- 1 | # Workflow derived from https://github.com/r-lib/actions/tree/v2/examples 2 | # Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help 3 | on: 4 | push: 5 | branches: [main, master] 6 | pull_request: 7 | branches: [main, master] 8 | release: 9 | types: [published] 10 | workflow_dispatch: 11 | 12 | name: pkgdown 13 | 14 | permissions: read-all 15 | 16 | jobs: 17 | pkgdown: 18 | runs-on: ubuntu-latest 19 | # Only restrict concurrency for non-PR jobs 20 | concurrency: 21 | group: pkgdown-${{ github.event_name != 'pull_request' || github.run_id }} 22 | env: 23 | GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} 24 | permissions: 25 | contents: write 26 | steps: 27 | - uses: actions/checkout@v4 28 | 29 | - uses: r-lib/actions/setup-pandoc@v2 30 | 31 | - uses: r-lib/actions/setup-r@v2 32 | with: 33 | use-public-rspm: true 34 | 35 | - uses: r-lib/actions/setup-r-dependencies@v2 36 | with: 37 | extra-packages: any::pkgdown, local::. 38 | needs: website 39 | 40 | - name: Build site 41 | run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE) 42 | shell: Rscript {0} 43 | 44 | - name: Deploy to GitHub pages 🚀 45 | if: github.event_name != 'pull_request' 46 | uses: JamesIves/github-pages-deploy-action@v4.5.0 47 | with: 48 | clean: false 49 | branch: gh-pages 50 | folder: docs 51 | -------------------------------------------------------------------------------- /man/panel.outlinelevelplot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/desplot.R 3 | \name{panel.outlinelevelplot} 4 | \alias{panel.outlinelevelplot} 5 | \title{Panel Function for desplot} 6 | \usage{ 7 | panel.outlinelevelplot( 8 | x, 9 | y, 10 | z, 11 | subscripts, 12 | at, 13 | ..., 14 | alpha.regions = 1, 15 | out1f, 16 | out1g, 17 | out2f, 18 | out2g, 19 | dq 20 | ) 21 | } 22 | \arguments{ 23 | \item{x}{Coordinates} 24 | 25 | \item{y}{Coordinates} 26 | 27 | \item{z}{Value for filling each cell.} 28 | 29 | \item{subscripts}{For compatibility.} 30 | 31 | \item{at}{Breakpoints for the colors.} 32 | 33 | \item{...}{Other} 34 | 35 | \item{alpha.regions}{Transparency for fill colors. Not well tested.} 36 | 37 | \item{out1f}{Factor to use for outlining (level 1).} 38 | 39 | \item{out1g}{Factor to use for outlining (level 2).} 40 | 41 | \item{out2f}{Graphics parameters to use for outlining.} 42 | 43 | \item{out2g}{Graphics parameters to use for outlining.} 44 | 45 | \item{dq}{Indicator of which cells should be flagged for data quality.} 46 | } 47 | \description{ 48 | This is a panel function for \code{desplot} which fills cells with 49 | a background color and adds outlines around blocks of cells. 50 | } 51 | \details{ 52 | It does not add the text labels, numbers, or colors. 53 | 54 | The rule for determining where to draw outlines is to compare the 55 | levels of the factor used for outlining. If bordering cells have 56 | different levels of the factor, then a border is drawn. 'NA' values 57 | are ignored (otherwise, too many lines would be drawn). 58 | 59 | The code works, but is probably overkill and has not been streamlined. 60 | } 61 | \references{ 62 | None 63 | } 64 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # desplot 1.11 () 2 | 3 | * Switch to MIT license. 4 | 5 | * Documentation pages now created via Github Actions. 6 | 7 | * Fix the checking for multiple cell values when there are 2 panel factors. 8 | 9 | * New support for `aspect` with `ggdesplot()`. (P.Schmidt) 10 | 11 | * New support for named colors (P.Schmidt). 12 | 13 | # desplot 1.10 (2023-03-01) 14 | 15 | * One-row panels no longer have whitespace. Issue #9. 16 | 17 | * Replace `aes_string(x=x.string)` with `aes(x=.data[[x.string]])` etc. 18 | 19 | 20 | # desplot 1.9 (2021-10-30) 21 | 22 | * Tweaks to `ggdesplot` output. 23 | 24 | * Remove LazyData from DESCRIPTION. 25 | 26 | 27 | # desplot 1.8 (2020-10-21) 28 | 29 | * Bug fix for `dq` with multiple panels. 30 | 31 | * Use `inherits` to check class #4. 32 | 33 | 34 | # desplot 1.7 (2020-07-20) 35 | 36 | * Please use `desplot(data,formula)` instead of `desplot(formula,data)`. 37 | 38 | 39 | # desplot 1.6 (2019-09-13) 40 | 41 | * New argument `dq` for showing data quality on heatmaps. 42 | 43 | 44 | # desplot 1.5 (2019-04-04) 45 | 46 | * Beta version of `ggdesplot()` to create `ggplot2` graphics. 47 | 48 | * New argument `subset` to subset data before analysis. 49 | 50 | 51 | # desplot 1.3 (2017-10-13) 52 | 53 | * Bug fix. 54 | 55 | 56 | # desplot 1.2 (2017-07-13) 57 | 58 | * Now using `testthat` and `covr` packages. 59 | 60 | 61 | # desplot 1.1 (2016-12-18) 62 | 63 | * New function argument `midpoint="median"` uses the median to determine the midpoint for the ribbon. Previously, the midpoint was halfway between the minimum and maximum data values. 64 | 65 | 66 | # desplot 1.0 (2015-12-14) 67 | 68 | * The `desplot` package has been split off from the `agridat` package. 69 | 70 | 71 | # desplot 0.0 (2008) 72 | 73 | * Original creation of function. 74 | -------------------------------------------------------------------------------- /vignettes/desplot_examples.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Plotting field maps with the desplot package" 3 | author: "Kevin Wright" 4 | date: "`r Sys.Date()`" 5 | bibliography: desplot.bib 6 | output: 7 | rmarkdown::html_vignette: 8 | vignette: > 9 | %\VignetteIndexEntry{Plotting field maps with the desplot package} 10 | %\VignetteEngine{knitr::rmarkdown} 11 | %\VignetteEncoding{UTF-8} 12 | --- 13 | 14 | # Abstract 15 | 16 | This short note shows how to plot a field map from an agricultural experiment and why that may be useful. 17 | 18 | # R setup 19 | 20 | ```{r setup} 21 | library("knitr") 22 | knitr::opts_chunk$set(fig.align="center", fig.width=6, fig.height=6) 23 | options(width=90) 24 | ``` 25 | 26 | ## Example 1 27 | 28 | First, a plot of the experimental design of the oats data from @yates1935complex. 29 | ```{r yates} 30 | library(agridat) 31 | library(desplot) 32 | data(yates.oats) 33 | desplot(yates.oats, block ~ col+row, 34 | col=nitro, text=gen, cex=1, out1=block, 35 | out2=gen, out2.gpar=list(col = "gray50", lwd = 1, lty = 1)) 36 | ``` 37 | 38 | ## Example 2 39 | 40 | This next example is from @ryder1981field. Fit an ordinary RCB model with fixed effects for `block` and `genotype`. Plot a heatmap of the residuals. 41 | 42 | ```{r ryder} 43 | library(agridat) 44 | library(desplot) 45 | data(ryder.groundnut) 46 | gnut <- ryder.groundnut 47 | m1 <- lm(dry ~ block + gen, gnut) # Standard RCB model 48 | gnut$res <- resid(m1) 49 | desplot(gnut, res ~ col + row, text=gen, cex=1, 50 | main="ryder.groundnut residuals from RCB model") 51 | ``` 52 | Note the largest positive/negative residuals are adjacent to each other, 53 | perhaps caused by the original data values being swapped. Checking with 54 | experiment investigators (managers, data collectors, etc.) is recommended. 55 | 56 | # Infrequently asked questions 57 | 58 | ## How do I change the ordering of panels? 59 | 60 | Make sure that the panel variable is a factor and then change the levels of the factor. 61 | 62 | In the example below, the first three panels are set to the levels C1, C3, C5. The other levels remain in the same (relative) order. 63 | 64 | ```{r panelorder, eval=FALSE} 65 | library(agridat) 66 | library(desplot) 67 | data(besag.met) 68 | desplot(besag.met, yield~col*row|county, main="default county ordering") 69 | library(forcats) 70 | besag.met <- transform(besag.met, 71 | county=fct_relevel(county, c("C1","C3","C5"))) 72 | desplot(besag.met, yield~col*row|county, main="custom county ordering") 73 | ``` 74 | ## References 75 | 76 | -------------------------------------------------------------------------------- /tests/testthat/test_named_colors.R: -------------------------------------------------------------------------------- 1 | # Test Script for Named Vector Color Support - Issue #10 2 | library(desplot) 3 | 4 | # Simple test data: 2 rows x 3 columns, 3 factor levels 5 | test_data <- data.frame( 6 | row = rep(1:2, each=3), 7 | col = rep(1:3, times=2), 8 | treat = factor(rep(c("A", "B", "C"), length.out=6)) 9 | ) 10 | 11 | test_that("named colors", { 12 | # TEST 1: Named vector - forward order 13 | my_colors <- c("skyblue", "pink", "lightgreen") 14 | names(my_colors) <- c("A", "B", "C") 15 | desplot(test_data, treat ~ col*row, col.regions=my_colors, main="Test 1: Named forward", gg=FALSE) 16 | desplot(test_data, treat ~ col*row, col.regions=my_colors, main="Test 1: Named forward (gg)", gg=TRUE) 17 | 18 | # TEST 2: Named vector - reversed order (KEY TEST from issue #10) 19 | my_colors_rev <- c("skyblue", "pink", "lightgreen") 20 | names(my_colors_rev) <- c("C", "B", "A") # REVERSED! 21 | desplot(test_data, treat ~ col*row, col.regions=my_colors_rev, main="Test 2: Named reversed", gg=FALSE) 22 | desplot(test_data, treat ~ col*row, col.regions=my_colors_rev, main="Test 2: Named reversed (gg)", gg=TRUE) 23 | 24 | # TEST 3: Partial names (should warn and fallback) 25 | partial_colors <- c("red", "blue") 26 | names(partial_colors) <- c("A", "B") # Missing C 27 | expect_warning(desplot(test_data, treat ~ col*row, col.regions=partial_colors, main="Test 3: Partial names", gg=FALSE)) 28 | expect_warning(desplot(test_data, treat ~ col*row, col.regions=partial_colors, main="Test 3: Partial names (gg)", gg=TRUE)) 29 | 30 | # TEST 4: Extra names (should work, extras ignored) 31 | extra_colors <- c("purple", "orange", "brown", "yellow") 32 | names(extra_colors) <- c("A", "B", "C", "D") # D doesn't exist 33 | desplot(test_data, treat ~ col*row, col.regions=extra_colors, main="Test 4: Extra names", gg=FALSE) 34 | desplot(test_data, treat ~ col*row, col.regions=extra_colors, main="Test 4: Extra names (gg)", gg=TRUE) 35 | 36 | # TEST 5: Unnamed vector (backward compatibility) 37 | unnamed_colors <- c("coral", "cyan", "gold") 38 | desplot(test_data, treat ~ col*row, col.regions=unnamed_colors, main="Test 5: Unnamed", gg=FALSE) 39 | desplot(test_data, treat ~ col*row, col.regions=unnamed_colors, main="Test 5: Unnamed (gg)", gg=TRUE) 40 | 41 | # TEST 6: Named col.text (outline colors) 42 | text_colors <- c("red", "blue", "green") 43 | names(text_colors) <- c("C", "B", "A") # Reversed 44 | desplot(test_data, treat ~ col*row, col=treat, col.text=text_colors, main="Test 6: Named col.text", gg=FALSE) 45 | desplot(test_data, treat ~ col*row, col=treat, col.text=text_colors, main="Test 6: Named col.text (gg)", gg=TRUE) 46 | }) 47 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # desplot 2 | 3 | [![CRAN_Status_Badge](http://www.r-pkg.org/badges/version/desplot)](https://cran.r-project.org/package=desplot) 4 | [![CRAN_Downloads](https://cranlogs.r-pkg.org/badges/desplot)](https://cranlogs.r-pkg.org/badges/desplot) 5 | 6 | Homepage: https://kwstat.github.io/desplot 7 | 8 | Repository: https://github.com/kwstat/desplot 9 | 10 | `desplot` makes it easy to plot experimental designs of field trials in agriculture. 11 | 12 | ## Key features 13 | 14 | * Flexible options to customize appearance of graphic. 15 | 16 | * Stable, well-tested using lattice graphics. 17 | 18 | * Beta version using ggplot2 graphics. Note ggplot2 is about 4 times slower. 19 | 20 | ## Installation 21 | 22 | ```R 23 | # Install the released version from CRAN: 24 | install.packages("desplot") 25 | 26 | # Install the development version from GitHub: 27 | install.packages("devtools") 28 | devtools::install_github("kwstat/desplot") 29 | ``` 30 | 31 | ## Example 1 32 | 33 | This data is is from a split-plot experiment with 6 replicates. The replicates are shown by the colored regions and outlined by the thick lines. The text codes and the thin lines define the whole-plots. The nitrogen sub-plot treatments are shown by the text colors. 34 | 35 | ```R 36 | require(agridat) 37 | require(desplot) 38 | desplot(yates.oats, block ~ col+row, 39 | col=nitro, text=gen, cex=1, aspect=511/176, 40 | out1=block, out2=gen, 41 | out2.gpar=list(col = "gray50", lwd = 1, lty = 1)) 42 | ``` 43 | ![desplot](man/figures/yates_oats_design.png?raw=true) 44 | 45 | The default graphics are based on lattice. It is also possible to create graphics based on ggplot2 by adding 'gg=TRUE' to the function. This functionality is in development and the legend for the ggplot version is not as polished as the lattice version. 46 | 47 | ```R 48 | require(agridat) 49 | require(desplot) 50 | desplot(yates.oats, block ~ col+row, 51 | col=nitro, text=gen, cex=1, aspect=511/176, 52 | out1=block, out2=gen, 53 | out2.gpar=list(col = "gray50", lwd = 1, lty = 1), gg=TRUE) 54 | # note, out2.gpar is ignored 55 | ``` 56 | 57 | ![desplot](man/figures/yates_oats_design_ggplot.png?raw=true) 58 | 59 | ## Example 2 60 | 61 | Another very useful technique is to color the cells according to a continuous response variable (such as plot yield). 62 | 63 | ```R 64 | require(agridat) 65 | require(desplot) 66 | desplot(yates.oats, yield ~ col*row, 67 | col=gen, num=nitro, cex=1, out1=block, aspect=511/176) 68 | ``` 69 | ![desplot](man/figures/yates_oats_yield.png?raw=true) 70 | 71 | ## Example 3 72 | 73 | Multiple locations can be shown in a single figure. 74 | Data quality for each cell can be indicated with a slash drawn across questionable values and an X drawn across bad values. 75 | 76 | ```R 77 | require(agridat) 78 | require(desplot) 79 | bmet <- agridat::besag.met 80 | # Simulate a data quality flag 81 | bmet$flag <- sample(c("G","Q","B"), nrow(bmet), replace=TRUE, prob=c(0.8,0.1,0.1)) 82 | desplot(bmet, yield ~ col*row|county, 83 | main="besag.met", 84 | num=gen, out1=rep, dq=flag, 85 | aspect=1.0) 86 | ``` 87 | ![desplot](man/figures/besag_met_missing.png?raw=true) 88 | 89 | ### Logo note 90 | 91 | The hexagon logo for this package shows a simple experimental design layout on top of a tan (soil-color) background. 92 | 93 | -------------------------------------------------------------------------------- /R/geom_tileborder.R: -------------------------------------------------------------------------------- 1 | # geom_tileborder.R 2 | 3 | if(0){ 4 | ggplot(agridat::besag.met, aes(x=col, y=row)) + 5 | facet_wrap( ~ county) + 6 | geom_tile(aes(fill=yield)) + 7 | geom_tileborder(aes(group=1, grp=rep), lwd=1.5, lineend="round") + 8 | geom_tileborder(aes(group=1, grp=block), color="yellow", lwd=0.5) 9 | 10 | desplot(yield~col*row|county, agridat::besag.met, out1=rep, out2=block) 11 | ggdesplot(yield~col*row|county, agridat::besag.met, out1=rep, out2=block) 12 | } 13 | 14 | #' Borders between tiles 15 | #' 16 | #' `geom_tileborder` draws a border between tiles of different classes. 17 | #' The required aesthetics are `aes(x,y,grp)`, where `grp` is the grouping 18 | #' classification that separates tiles. 19 | #' 20 | #' Note, we cannot use `aes(group)` because it groups the interaction of 21 | #' ALL discrete variables including facets. Since we do not want to draw 22 | #' a border between facets, we had to define a new aesthetic. 23 | #' See: # http://ggplot2.tidyverse.org/reference/aes_group_order.html 24 | #' 25 | #' Also, we do not want to split the data into separate groups for each level 26 | #' of `grp`, so we need to include `aes(group=1)`. 27 | #' 28 | #' @inheritParams ggplot2::layer 29 | #' @inheritParams ggplot2::geom_segment 30 | #' @import ggplot2 31 | #' @export 32 | #' 33 | #' @examples 34 | #' dd <- data.frame( 35 | #' x=c(1,2,1,2,3,1,2,1,2,3), 36 | #' y=c(2,2,2,2,2,1,1,1,1,1), 37 | #' loc=factor(c(1,1,2,2,2,1,1,2,2,2)), 38 | #' rep=factor(c(2,2,1,2,3,1,1,1,2,3))) 39 | #' library(ggplot2) 40 | #' ggplot(dd, aes(x=x, y=y)) + 41 | #' facet_wrap( ~ loc) + 42 | #' geom_tile(aes(fill=rep)) + 43 | #' geom_tileborder(aes(group=1, grp=rep), lwd=1.5) 44 | #' # Compare to lattice version of desplot 45 | #' # desplot::desplot(rep ~ x*y|loc, data=dd, out1=rep) 46 | #' 47 | geom_tileborder<- function(mapping = NULL, data = NULL, geom = "segment", 48 | position = "identity", na.rm = TRUE, 49 | show.legend = NA, 50 | inherit.aes = TRUE, ...) { 51 | ggplot2::layer( 52 | geom = geom, 53 | stat = StatTileBorder, 54 | data = data, 55 | mapping = mapping, 56 | position = position, 57 | show.legend = show.legend, 58 | inherit.aes = inherit.aes, 59 | params = list(na.rm = na.rm, ...) 60 | ) 61 | } 62 | 63 | 64 | #' @rdname geom_tileborder 65 | #' @format NULL 66 | #' @usage NULL 67 | #' @importFrom ggplot2 ggproto Stat 68 | #' @export 69 | StatTileBorder <- 70 | ggplot2::ggproto("StatTileBorder", 71 | ggplot2::Stat, 72 | required_aes=c("x","y","grp"), 73 | compute_group = function(data, scales) { 74 | # print(data) # so we can see the data groups 75 | #cat("hello\n") 76 | calc_borders(data$x, data$y, data$grp) 77 | }) 78 | 79 | #' @noRd 80 | #' @importFrom reshape2 acast melt 81 | calc_borders <- function(x,y,grp){ 82 | # x,y: coordinates for tiles in a heatmap 83 | # grp: class identifier for each tile 84 | # Create a data frame with all line segments needed to draw borders between 85 | # tiles in different grp. 86 | # Note, NA values in grp are not considered a separate class, because we 87 | # do NOT want to outline missing values in the heatmap. 88 | 89 | # Create a matrix with the class membership in each cell. 90 | # Note, the 'mat' matrix is upside down from the levelplot 91 | dat <- data.frame(x=x, y=y, grp=grp) 92 | mat <- reshape2::acast(dat, y ~ x, value.var="grp") 93 | 94 | # Since 'mat' could be 1 row or column, surround it with NAs 95 | mat <- cbind(NA, rbind(NA, mat, NA), NA) 96 | 97 | # Find cells with top borders 98 | top <- mat[2:nrow(mat)-1, ] != mat[2:nrow(mat), ] 99 | top <- reshape2::melt(top) 100 | top <- top[!(top$value==FALSE | is.na(top$value)),] 101 | names(top) <- c('y','x','grp') 102 | # line segments above each cell 103 | top <- transform(top, x=x-.5, xend=x+.5, y=y+.5, yend=y+.5) 104 | 105 | # Find cells with right borders 106 | right <- mat[ , 2:ncol(mat)-1] != mat[ , 2:ncol(mat)] 107 | right <- reshape2::melt(right) 108 | right <- right[!(right$value==FALSE | is.na(right$value)),] 109 | names(right) <- c('y','x','grp') 110 | right <- transform(right, x=x+.5, xend=x+.5, y=y-.5, yend=y+.5) 111 | 112 | segs <- rbind(top,right) 113 | segs[,c("x","y","xend","yend")] 114 | if(nrow(segs)>0) segs else NULL 115 | } 116 | -------------------------------------------------------------------------------- /cran-comments.md: -------------------------------------------------------------------------------- 1 | # desplot 1.10 2 | 3 | ## test environments 4 | 5 | * local R 4.2.2 Windows 10 6 | * WinBuilder devel 7 | * Rhub Windows Server 2022, R-devel, 64 bit 8 | 9 | R CMD check results: OK 10 | 11 | ## Downstream dependencies 12 | 13 | * agridat 14 | * FieldHub 15 | * grapesAgri1 16 | 17 | Checked OK 18 | 19 | 20 | # desplot 1.9 21 | 22 | ## test environments 23 | 24 | * local R 4.1.1 Windows 10 25 | * Rhub Windows Server 2008 R2 SP1, R-devel, 32/64 bit 26 | * Rhub Ubuntu Linux 20.04.1 LTS, R-release, GCC 27 | * Rhub Fedora Linux, R-devel, clang, gfortran 28 | * WinBuilder devel 29 | 30 | ## R CMD check results 31 | 32 | OK 33 | 34 | One NOTE: 35 | 36 | ``` 37 | Found the following (possibly) invalid URLs: 38 | URL: https://doi.org/10.2307/2983638 39 | From: inst/doc/desplot_examples.html 40 | Status: 403 41 | Message: Forbidden 42 | ``` 43 | 44 | This URL works fine in a web browser. Please advise if changes are needed. 45 | 46 | ## Downstream dependencies 47 | 48 | * agridat 49 | * grapesAgri1 50 | 51 | Checked OK. 52 | 53 | 54 | # desplot 1.8 55 | 56 | ## test environments 57 | 58 | * local R 4.0.3 Windows 10 59 | * WinBuilder devel 60 | * Rhub Windows Server 2008 R2 SP1, R-devel, 32/64 bit 61 | * Rhub Ubuntu Linux 16.04 LTS, R-release, GCC 62 | * Rhub Fedora Linux, R-devel, clang, gfortran 63 | 64 | ## R CMD check results 65 | 66 | One NOTE: 67 | 68 | ``` 69 | Found the following (possibly) invalid URLs: 70 | URL: https://doi.org/10.2307/2983638 71 | From: inst/doc/desplot_examples.html 72 | Status: 403 73 | Message: Forbidden 74 | ``` 75 | 76 | This URL works fine in a web browser. Please advise if changes are needed. 77 | 78 | ## Downstream dependencies 79 | 80 | Reverse suggests: agridat 81 | 82 | Checked OK. 83 | 84 | 85 | # desplot 1.7 86 | 87 | ## test environments 88 | 89 | * local R 4.0.2 Windows 10 90 | * Rhub Ubuntu Linux 16.04, R-release 91 | * Rhub Windows Server 2008, R-devel 92 | * Rhub Fedora Linux, R-devel 93 | 94 | ## R CMD check results 95 | 96 | Status: OK 97 | 98 | ## Downstream dependencies 99 | 100 | Reverse suggests: agridat 101 | 102 | Checked OK. 103 | 104 | 105 | # desplot 1.6 106 | 107 | ## test environments 108 | 109 | * local R 3.6.1 Windows 7 110 | * win-builder R 3.6.1 111 | * win-builder R 3.5.3 112 | * R-hub Debian Linux, R-devel, GCC 113 | 114 | ## R CMD check results 115 | 116 | One NOTE: 117 | 118 | ``` 119 | Found the following (possibly) invalid URLs: 120 | URL: https://doi.org/10.2307/2983638 121 | From: inst/doc/desplot_examples.html 122 | Status: 403 123 | Message: Forbidden 124 | ``` 125 | 126 | This URL works fine in a web browser. Please advise if changes are needed. 127 | 128 | ## Downstream dependencies 129 | 130 | Reverse suggests: agridat 131 | 132 | Checked OK. 133 | 134 | 135 | 136 | # desplot 1.5 137 | 138 | ## test environments 139 | 140 | * local R 3.5.3 Windows 7 141 | * win-builder R 3.6.0 alpha 142 | * win-builder R 3.5.3 143 | 144 | ## R CMD check results 145 | 146 | One NOTE: 147 | 148 | Found the following (possibly) invalid URLs: 149 | URL: https://doi.org/10.2307/2983638 150 | From: inst/doc/desplot_examples.html 151 | Status: 403 152 | Message: Forbidden 153 | 154 | This URL works fine in a web browser. Please advise if changes are needed. 155 | 156 | ## Downstream dependencies 157 | 158 | Reverse suggests: agridat 159 | 160 | Checked OK. 161 | 162 | 163 | 164 | # desplot 1.3 165 | 166 | ## test environments 167 | 168 | * local R 3.4.2 Windows 7 169 | * win-builder r-release 3.4.2 170 | * win-builder r-devel 171 | 172 | ## R CMD check results 173 | 174 | There were no ERRORs, WARNINGs, or NOTEs. 175 | 176 | 177 | 178 | # desplot 1.2 179 | 180 | ## test environments 181 | 182 | * local R 3.4.0 Windows 7 183 | * win-builder R 3.4.1 184 | * win-builder r-devel 185 | 186 | ## R CMD check results 187 | 188 | There were no ERRORs, WARNINGs, or NOTEs. 189 | 190 | 191 | 192 | # desplot 1.1 193 | 194 | ## test environments 195 | 196 | * local R 3.3.2 on Windows 7 197 | * win-builder R 3.3.2 198 | * R-hub Debian Linux, R-devel, GCC 199 | 200 | ## R CMD check results 201 | 202 | There were no ERRORs, WARNINGs, or NOTEs. 203 | 204 | 205 | 206 | # desplot 1.0 207 | 208 | This is a new package submission. The functions in this package are being 209 | split off from the 'agridat' package so that the latter can be a data-only 210 | package. 211 | 212 | ## test environments 213 | 214 | * local R 3.2.3 on Windows 7 215 | * win-builder release 216 | * win-builder devel 217 | 218 | ## R CMD check results 219 | 220 | There were no ERRORs, WARNINGs, or NOTEs. 221 | 222 | 223 | -------------------------------------------------------------------------------- /man/geom_tileborder.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/geom_tileborder.R 3 | \docType{data} 4 | \name{geom_tileborder} 5 | \alias{geom_tileborder} 6 | \alias{StatTileBorder} 7 | \title{Borders between tiles} 8 | \usage{ 9 | geom_tileborder( 10 | mapping = NULL, 11 | data = NULL, 12 | geom = "segment", 13 | position = "identity", 14 | na.rm = TRUE, 15 | show.legend = NA, 16 | inherit.aes = TRUE, 17 | ... 18 | ) 19 | } 20 | \arguments{ 21 | \item{mapping}{Set of aesthetic mappings created by \code{\link[ggplot2:aes]{aes()}}. If specified and 22 | \code{inherit.aes = TRUE} (the default), it is combined with the default mapping 23 | at the top level of the plot. You must supply \code{mapping} if there is no plot 24 | mapping.} 25 | 26 | \item{data}{The data to be displayed in this layer. There are three 27 | options: 28 | 29 | If \code{NULL}, the default, the data is inherited from the plot 30 | data as specified in the call to \code{\link[ggplot2:ggplot]{ggplot()}}. 31 | 32 | A \code{data.frame}, or other object, will override the plot 33 | data. All objects will be fortified to produce a data frame. See 34 | \code{\link[ggplot2:fortify]{fortify()}} for which variables will be created. 35 | 36 | A \code{function} will be called with a single argument, 37 | the plot data. The return value must be a \code{data.frame}, and 38 | will be used as the layer data. A \code{function} can be created 39 | from a \code{formula} (e.g. \code{~ head(.x, 10)}).} 40 | 41 | \item{geom}{The geometric object to use to display the data for this layer. 42 | When using a \verb{stat_*()} function to construct a layer, the \code{geom} argument 43 | can be used to override the default coupling between stats and geoms. The 44 | \code{geom} argument accepts the following: 45 | \itemize{ 46 | \item A \code{Geom} ggproto subclass, for example \code{GeomPoint}. 47 | \item A string naming the geom. To give the geom as a string, strip the 48 | function name of the \code{geom_} prefix. For example, to use \code{geom_point()}, 49 | give the geom as \code{"point"}. 50 | \item For more information and other ways to specify the geom, see the 51 | \link[ggplot2:layer_geoms]{layer geom} documentation. 52 | }} 53 | 54 | \item{position}{A position adjustment to use on the data for this layer. This 55 | can be used in various ways, including to prevent overplotting and 56 | improving the display. The \code{position} argument accepts the following: 57 | \itemize{ 58 | \item The result of calling a position function, such as \code{position_jitter()}. 59 | This method allows for passing extra arguments to the position. 60 | \item A string naming the position adjustment. To give the position as a 61 | string, strip the function name of the \code{position_} prefix. For example, 62 | to use \code{position_jitter()}, give the position as \code{"jitter"}. 63 | \item For more information and other ways to specify the position, see the 64 | \link[ggplot2:layer_positions]{layer position} documentation. 65 | }} 66 | 67 | \item{na.rm}{If \code{FALSE}, the default, missing values are removed with 68 | a warning. If \code{TRUE}, missing values are silently removed.} 69 | 70 | \item{show.legend}{logical. Should this layer be included in the legends? 71 | \code{NA}, the default, includes if any aesthetics are mapped. 72 | \code{FALSE} never includes, and \code{TRUE} always includes. 73 | It can also be a named logical vector to finely select the aesthetics to 74 | display. To include legend keys for all levels, even 75 | when no data exists, use \code{TRUE}. If \code{NA}, all levels are shown in legend, 76 | but unobserved levels are omitted.} 77 | 78 | \item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics, 79 | rather than combining with them. This is most useful for helper functions 80 | that define both data and aesthetics and shouldn't inherit behaviour from 81 | the default plot specification, e.g. \code{\link[ggplot2:annotation_borders]{annotation_borders()}}.} 82 | 83 | \item{...}{Other arguments passed on to \code{\link[ggplot2:layer]{layer()}}'s \code{params} argument. These 84 | arguments broadly fall into one of 4 categories below. Notably, further 85 | arguments to the \code{position} argument, or aesthetics that are required 86 | can \emph{not} be passed through \code{...}. Unknown arguments that are not part 87 | of the 4 categories below are ignored. 88 | \itemize{ 89 | \item Static aesthetics that are not mapped to a scale, but are at a fixed 90 | value and apply to the layer as a whole. For example, \code{colour = "red"} 91 | or \code{linewidth = 3}. The geom's documentation has an \strong{Aesthetics} 92 | section that lists the available options. The 'required' aesthetics 93 | cannot be passed on to the \code{params}. Please note that while passing 94 | unmapped aesthetics as vectors is technically possible, the order and 95 | required length is not guaranteed to be parallel to the input data. 96 | \item When constructing a layer using 97 | a \verb{stat_*()} function, the \code{...} argument can be used to pass on 98 | parameters to the \code{geom} part of the layer. An example of this is 99 | \code{stat_density(geom = "area", outline.type = "both")}. The geom's 100 | documentation lists which parameters it can accept. 101 | \item Inversely, when constructing a layer using a 102 | \verb{geom_*()} function, the \code{...} argument can be used to pass on parameters 103 | to the \code{stat} part of the layer. An example of this is 104 | \code{geom_area(stat = "density", adjust = 0.5)}. The stat's documentation 105 | lists which parameters it can accept. 106 | \item The \code{key_glyph} argument of \code{\link[ggplot2:layer]{layer()}} may also be passed on through 107 | \code{...}. This can be one of the functions described as 108 | \link[ggplot2:draw_key]{key glyphs}, to change the display of the layer in the legend. 109 | }} 110 | } 111 | \description{ 112 | `geom_tileborder` draws a border between tiles of different classes. 113 | The required aesthetics are `aes(x,y,grp)`, where `grp` is the grouping 114 | classification that separates tiles. 115 | } 116 | \details{ 117 | Note, we cannot use `aes(group)` because it groups the interaction of 118 | ALL discrete variables including facets. Since we do not want to draw 119 | a border between facets, we had to define a new aesthetic. 120 | See: # http://ggplot2.tidyverse.org/reference/aes_group_order.html 121 | 122 | Also, we do not want to split the data into separate groups for each level 123 | of `grp`, so we need to include `aes(group=1)`. 124 | } 125 | \examples{ 126 | dd <- data.frame( 127 | x=c(1,2,1,2,3,1,2,1,2,3), 128 | y=c(2,2,2,2,2,1,1,1,1,1), 129 | loc=factor(c(1,1,2,2,2,1,1,2,2,2)), 130 | rep=factor(c(2,2,1,2,3,1,1,1,2,3))) 131 | library(ggplot2) 132 | ggplot(dd, aes(x=x, y=y)) + 133 | facet_wrap( ~ loc) + 134 | geom_tile(aes(fill=rep)) + 135 | geom_tileborder(aes(group=1, grp=rep), lwd=1.5) 136 | # Compare to lattice version of desplot 137 | # desplot::desplot(rep ~ x*y|loc, data=dd, out1=rep) 138 | 139 | } 140 | \keyword{datasets} 141 | -------------------------------------------------------------------------------- /man/desplot.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/desplot.R, R/ggdesplot.R 3 | \name{desplot} 4 | \alias{desplot} 5 | \alias{ggdesplot} 6 | \title{Plot the layout/data of a field experiment.} 7 | \usage{ 8 | desplot( 9 | data, 10 | form = formula(NULL ~ x + y), 11 | num = NULL, 12 | num.string = NULL, 13 | col = NULL, 14 | col.string = NULL, 15 | text = NULL, 16 | text.string = NULL, 17 | out1 = NULL, 18 | out1.string = NULL, 19 | out2 = NULL, 20 | out2.string = NULL, 21 | dq = NULL, 22 | dq.string = NULL, 23 | col.regions = RedGrayBlue, 24 | col.text = NULL, 25 | text.levels = NULL, 26 | out1.gpar = list(col = "black", lwd = 3), 27 | out2.gpar = list(col = "yellow", lwd = 1, lty = 1), 28 | at, 29 | midpoint = "median", 30 | ticks = FALSE, 31 | flip = FALSE, 32 | main = NULL, 33 | xlab, 34 | ylab, 35 | shorten = "abb", 36 | show.key = TRUE, 37 | key.cex, 38 | cex = 0.4, 39 | strip.cex = 0.75, 40 | aspect = NULL, 41 | subset = TRUE, 42 | gg = FALSE, 43 | ... 44 | ) 45 | 46 | ggdesplot( 47 | data, 48 | form = formula(NULL ~ x + y), 49 | num = NULL, 50 | num.string = NULL, 51 | col = NULL, 52 | col.string = NULL, 53 | text = NULL, 54 | text.string = NULL, 55 | out1 = NULL, 56 | out1.string = NULL, 57 | out2 = NULL, 58 | out2.string = NULL, 59 | dq = NULL, 60 | dq.string = NULL, 61 | col.regions = RedGrayBlue, 62 | col.text = NULL, 63 | text.levels = NULL, 64 | out1.gpar = list(col = "black", lwd = 3), 65 | out2.gpar = list(col = "yellow", lwd = 1, lty = 1), 66 | at, 67 | midpoint = "median", 68 | ticks = FALSE, 69 | flip = FALSE, 70 | main = NULL, 71 | xlab, 72 | ylab, 73 | shorten = "abb", 74 | show.key = TRUE, 75 | key.cex, 76 | cex = 0.4, 77 | strip.cex = 0.75, 78 | aspect = NULL, 79 | subset = TRUE, 80 | gg = FALSE, 81 | ... 82 | ) 83 | } 84 | \arguments{ 85 | \item{data}{A data frame.} 86 | 87 | \item{form}{A formula like \code{yield~x*y|location}. Note x,y are numeric.} 88 | 89 | \item{num}{Bare name (no quotes) of the column of the data to use 90 | as a factor for number-coding the text in each cell.} 91 | 92 | \item{num.string}{String name of the column of the data to use 93 | as a factor for number-coding the text in each cell.} 94 | 95 | \item{col}{Bare name (no quotes) of the column of the data to use 96 | for color-coding the text shown in each cell.} 97 | 98 | \item{col.string}{String name of the column of the data to use 99 | for color-coding the text shown in each cell.} 100 | 101 | \item{text}{Bare name (no quotes) of the column of the data to use 102 | for the actual text shown in each cell.} 103 | 104 | \item{text.string}{String name of the column of the data to use 105 | for the actual text shown in each cell.} 106 | 107 | \item{out1}{Bare name (no quotes) of the column of the data to use 108 | for first-level outlining around blocks of cells.} 109 | 110 | \item{out1.string}{String name of the column of the data to use 111 | for first-level outlining around blocks of cells.} 112 | 113 | \item{out2}{Bare name (no quotes) of the column of the data to use 114 | for second-level outlining around blocks of cells.} 115 | 116 | \item{out2.string}{String name of the column of the data to use 117 | for second-level outlining around blocks of cells.} 118 | 119 | \item{dq}{Bare name (no quotes) of the column of the data to use 120 | for indicating bad data quality with diagonal lines. 121 | This can either be a numeric vector or a factor/text. 122 | Cells with 1/"Q"/"Questionable" have one diagonal line. 123 | Cells with 2/"B"/"Bad","S","Suppressed" have crossed diagonal lines.} 124 | 125 | \item{dq.string}{String name of the column of the data to use 126 | for indicating bad data quality with diagonal lines.} 127 | 128 | \item{col.regions}{Colors for the fill color of cells.} 129 | 130 | \item{col.text}{Vector of colors for text strings.} 131 | 132 | \item{text.levels}{Character strings to use instead of default 'levels'.} 133 | 134 | \item{out1.gpar}{A list of graphics parameters for first-level outlining. 135 | Can either be an ordinary \code{list()} or a call to \code{gpar()} from the 136 | \code{grid} package.} 137 | 138 | \item{out2.gpar}{Graphics parameters for second-level of outlining.} 139 | 140 | \item{at}{Breakpoints for the color ribbon. Use this instead of 'zlim'. 141 | Note: using 'at' causes 'midpoint' to be set to NULL.} 142 | 143 | \item{midpoint}{Method to find midpoint of the color ribbon. 144 | One of 'midrange', 'median, or a numeric value.} 145 | 146 | \item{ticks}{If TRUE, show tick marks along the bottom and left sides.} 147 | 148 | \item{flip}{If TRUE, vertically flip the image.} 149 | 150 | \item{main}{Main title.} 151 | 152 | \item{xlab}{Label for x axis.} 153 | 154 | \item{ylab}{Label for y axis.} 155 | 156 | \item{shorten}{Method for shortening text in the key, either 'abb', 'sub', 'no', or FALSE.} 157 | 158 | \item{show.key}{If TRUE, show the key on the left side. (This is not the ribbon.)} 159 | 160 | \item{key.cex}{Left legend cex.} 161 | 162 | \item{cex}{Expansion factor for text/number in each cell.} 163 | 164 | \item{strip.cex}{Strip cex.} 165 | 166 | \item{aspect}{Aspect ratio. 167 | To get a map of a field with a true aspect ratio include 'aspect=ylen/xlen'. 168 | For lattice, 'ylen' is the vertical length of the field and 'xlen' 169 | is the horizontal length of the field. 170 | For ggplot2, 'ylen' is the vertical length of each cell/plot and 'xlen' 171 | is the horizontal length of each plot.} 172 | 173 | \item{subset}{An expression that evaluates to logical index vector for subsetting the data.} 174 | 175 | \item{gg}{If TRUE, desplot() switches to ggdesplot().} 176 | 177 | \item{...}{Other.} 178 | } 179 | \value{ 180 | A lattice or ggplot2 object 181 | } 182 | \description{ 183 | Use this function to plot the layout of a rectangular lattice 184 | field experiment and also the observed data values. 185 | } 186 | \details{ 187 | To create the plot using lattice graphics: 188 | 1. \code{desplot(...)}. 189 | 190 | To create the plot using ggplot2 graphics, use one of the following: 191 | 1. \code{ggdesplot(...)}. 192 | 2. \code{desplot(..., gg=TRUE)}. 193 | 3. \code{options(desplot.gg=TRUE); desplot(...)}. 194 | Method 3 is useful to modify all results from existing scripts. 195 | 196 | The lattice version is complete, mature, and robust. 197 | The ggplot2 version is incomplete. The legend can only show colors, 198 | and some function arguments are ignored. 199 | In general, lattice graphics are about 4-5 times faster than ggplot2 graphics. 200 | Not all lattice parameters are passed down to \code{xyplot}, but it 201 | is possible to make almost any change to the plot by assigning the 202 | desplot object to a variable and then edit the object by hand or use 203 | \code{update} to modify the object. Then print it manually. See the 204 | first example below. 205 | 206 | Use \code{col.regions} to specify fill colors. This can either be a vector 207 | of colors or a function that produces a vector of colors. If the response 208 | variable is a factor and \code{col.regions} is a \emph{function}, it will 209 | be ignored and the cells are filled with default light-colored backgrounds 210 | and a key is placed on the left. If the response variable is 211 | \emph{numeric}, the cells are colored according to \code{col.regions}, and 212 | a ribbon key is placed on the right. 213 | 214 | Use \code{shorten='abb'} (this is default) to shorten the cell text to 2 215 | characters using the \code{abbreviate} function 216 | Use \code{shorten='sub'} to use a 3-character substring. 217 | Use \code{shorten='no'} or \code{shorten=FALSE} for no shortening. 218 | 219 | Note that two sub-plots with identical levels of the split-plot factor can 220 | be adjacent to each other by virtue of appearing in different whole-plots. 221 | To correctly outline the split-plot factor, simply concatenate the 222 | whole-plot factor and sub-plot factor together. 223 | 224 | To call this function inside another function, you can hack like this: 225 | vr <- "yield"; vx <- "x"; vy <- "y"; 226 | eval(parse(text=paste("desplot(", vr, "~", vx, "*", vy, ", data=yates.oats)"))) 227 | } 228 | \examples{ 229 | if(require(agridat)){ 230 | 231 | # Show how to customize any feature. Here: make the strips bigger. 232 | data(besag.met) 233 | d1 <- desplot(besag.met, 234 | yield ~ col*row|county, 235 | main="besag.met", 236 | out1=rep, out2=block, out2.gpar=list(col="white"), strip.cex=2) 237 | d1 <- update(d1, par.settings = list(layout.heights=list(strip=2))) 238 | print(d1) 239 | 240 | data(yates.oats) 241 | # Show experiment layout in true aspect 242 | # Field width = 4 plots * 44 links = 176 links 243 | # Field length = 18 plots * 28.4 links = 511 links 244 | # With lattice, the aspect ratio is y/x for the entire field 245 | desplot(yates.oats, 246 | yield ~ col+row, 247 | out1=block, out2=gen, aspect=511/176) 248 | # With ggplot, the aspect ratio is y/x for each cell 249 | ggdesplot(yates.oats, 250 | yield ~ col+row, 251 | out1=block, out2=gen, aspect=28.4/44) 252 | 253 | desplot(yates.oats, 254 | block ~ col+row, 255 | col=nitro, text=gen, cex=1, out1=block, 256 | out2=gen, out2.gpar=list(col = "gray50", lwd = 1, lty = 1)) 257 | 258 | } 259 | } 260 | \references{ 261 | K. Ryder (1981). 262 | Field plans: why the biometrician finds them useful. 263 | \emph{Experimental Agriculture}, 17, 243--256. 264 | } 265 | \author{ 266 | Kevin Wright 267 | } 268 | -------------------------------------------------------------------------------- /tests/testthat/test_desplot.R: -------------------------------------------------------------------------------- 1 | 2 | require(desplot) 3 | 4 | # ---------------------------------------------------------------------------- 5 | # create data for tests 6 | 7 | dat0 <- data.frame(loc = c('loc1','loc1','loc1','loc1', 8 | 'loc2','loc2','loc2','loc2','loc2','loc2'), 9 | x=c(1,2,1,2, 1,2,3,1,2,3), 10 | y=c(1,1,2,2, 1,1,1,2,2,2), 11 | rep=c('R1','R1','R2','R2',' R1','R2','R3','R1','R2','R3'), 12 | yield=c(9.29,11.20,9.36,9.89,8.47,9.17,8.86,10.48,10.22,11.29), 13 | trt1=c('Treat1','Treat2','Treat2','Treat1', 14 | 'Trt1','Trt2','Trt1','Trt2','Trt1','Trt2'), 15 | trt2=c('Hybrid1','Hybrid1','Hybrid2','Hybrid2','Hybrid1', 16 | 'Hybrid2','Hybrid3','Hybrid1','Hybrid2','Hybrid3'), 17 | trt3=c("A","A","B","B","A","A","A","A","A","A"), 18 | dq=c(0,0,0,1,2)) 19 | dat3 <- data.frame( 20 | yield = 7:1, 21 | x = c(5, 6, 1, 3, 4, 5, 5), 22 | y = c(2, 3, 1, 2, 3, 1, 2), 23 | loc = c("L1", "L1", "L2", "L2", "L2", "L2", "L2"), 24 | block = c("B1","B1", "B1","B1","B2","B2","B2")) 25 | 26 | require(agridat) 27 | data(yates.oats, package="agridat") 28 | oats35 <- yates.oats 29 | oats35$dq <- rep(c(0,0,0,0,0,0,0,0,1,2), length=72) 30 | # ---------------------------------------------------------------------------- 31 | 32 | # aspect ratio 33 | #data(yates.oats) 34 | 35 | # Show experiment layout in true aspect 36 | # Field width = 4 plots * 44 links = 176 links 37 | # Field length = 18 plots * 28.4 links = 511 links 38 | test_that("aspect ratio", { 39 | # With lattice, the aspect ratio is y/x for the entire field 40 | expect_silent(desplot(yates.oats, yield ~ col+row, aspect=511/176)) 41 | # With ggplot, the aspect ratio is y/x for each cell 42 | expect_silent(ggdesplot(yates.oats, yield ~ col+row, aspect=28.4/44)) 43 | }) 44 | 45 | 46 | ## --------------------------------------------------------------------------- 47 | 48 | # col.regions, at, midpoint 49 | 50 | test_that("num,col,text", { 51 | expect_silent({ 52 | desplot(oats35, ~col+row|block, cex=1, num=gen) 53 | desplot(oats35, ~col+row|block, cex=1, col=gen) 54 | desplot(oats35, ~col+row|block, cex=1, text=gen) 55 | desplot(oats35, ~col+row|block, cex=1, num=gen,col=nitro) 56 | desplot(oats35, ~col+row|block, cex=1, text=gen,col=nitro) 57 | }) 58 | }) 59 | 60 | test_that("function cleanup checks variables", { 61 | expect_error( desplot(oats35, yield~col+row, num=junk) ) 62 | expect_error( desplot(oats35, yield~col+row, col=junk) ) 63 | expect_error( desplot(oats35, yield~col+row, text=junk) ) 64 | expect_error( desplot(oats35, yield~col+row, out1=junk) ) 65 | expect_error( desplot(oats35, yield~col+row, out2=junk) ) 66 | }) 67 | 68 | 69 | test_that("shorten", { 70 | expect_silent({ 71 | desplot(oats35, block~col+row, text=gen, cex=1) # default shorten='abb' 72 | desplot(oats35, block~col+row, text=gen, cex=1, shorten='abb') 73 | desplot(oats35, block~col+row, text=gen, cex=1, shorten='sub') 74 | desplot(oats35, block~col+row, text=gen, cex=1, shorten='no') 75 | desplot(oats35, block~col+row, text=gen, cex=1, shorten='none') 76 | desplot(oats35, block~col+row, text=gen, cex=1, shorten=FALSE) 77 | }) 78 | }) 79 | 80 | test_that("out1,out2,out1.gpar,out2.gpar", { 81 | expect_silent({ 82 | desplot(oats35, yield~col+row, out1=block) 83 | desplot(oats35, yield~col+row, out2=block) 84 | desplot(oats35, yield~col+row, out1=block, out2=gen) 85 | desplot(oats35, yield~col+row, 86 | out1=block, out1.gpar=list(col="white",lwd=2)) 87 | desplot(oats35, yield~col+row, 88 | out2=block, out2.gpar=list(col="deeppink",lwd=2)) 89 | desplot(dat3, yield ~ x*y|loc, out1=block, out2=block) # no outline available 90 | # note, the following line gives a warning, I think because there are 91 | # no combinations of L1 & B2 ??? 92 | # desplot(dat3, yield ~ x*y|loc, out1=block, gg=TRUE) 93 | }) 94 | }) 95 | 96 | test_that("dq", { 97 | expect_silent({ 98 | desplot(oats35, block~col+row, out1=block, dq=dq) 99 | desplot(oats35, block~col+row|block, out1=block, dq=dq) 100 | }) 101 | }) 102 | 103 | test_that("strip.cex", { 104 | expect_silent({ 105 | desplot(dat0, yield ~ x+y|loc, strip.cex=1.5) 106 | }) 107 | }) 108 | 109 | test_that("text.levels", { 110 | expect_silent({ 111 | desplot(oats35, block~col+row, col="nitro", 112 | text="gen", cex=1, text.levels=c('V','G','M')) 113 | }) 114 | }) 115 | 116 | test_that("key.cex, show.key", { 117 | expect_silent({ 118 | desplot( dat0, ~ x+y|loc, 119 | text=trt1, key.cex=1, shorten='none') 120 | desplot( dat0, ~ x+y|loc, 121 | text=trt1, cex=.8, shorten='none', show.key=FALSE) 122 | }) 123 | }) 124 | 125 | test_that("text,xlab,ylab", { 126 | expect_silent({ 127 | desplot(dat0, rep ~ x+y|loc, 128 | main="title", xlab="xlab", ylab="ylab") 129 | }) 130 | }) 131 | 132 | test_that("tick,flip", { 133 | expect_silent({ 134 | desplot(oats35, yield~col+row, tick=TRUE) 135 | desplot(oats35, yield~col+row, tick=TRUE, flip=TRUE) 136 | }) 137 | }) 138 | 139 | test_that("other arguments via ...", { 140 | expect_silent({ 141 | desplot(dat0, rep ~ x+y|loc) 142 | desplot(dat0, rep ~ x+y|loc, aspect=1) 143 | }) 144 | }) 145 | 146 | test_that("subset", { 147 | expect_silent({ 148 | desplot(oats35, ~col+row|block, 149 | subset = block %in% c("B1","B2"), cex=1, num=gen) 150 | }) 151 | }) 152 | 153 | ## --------------------------------------------------------------------------- 154 | 155 | test_that("If a cell has multiple observations, issue a warning.",{ 156 | # No panel factor 157 | dat0 <- expand.grid(col=1:2, row=1:2) 158 | dat0$y <- rnorm(nrow(dat0)) 159 | dat0 <- rbind(dat0, dat0[1,]) # Create one cell that has 2 observations 160 | 161 | # One panel factor 162 | dat1 <- expand.grid(state=c("S1","S2"), col=1:2, row=1:2) 163 | dat1$y <- rnorm(nrow(dat1)) 164 | dat1 <- rbind(dat1, dat1[1,]) # Create one cell that has 2 observations 165 | 166 | # Two panel factors 167 | dat2 <- expand.grid(state=c("S1","S2"), loc=c("L1","L2","L3"), col=1:2, row=1:2) 168 | dat2$y <- rnorm(nrow(dat2)) 169 | dat2 <- rbind(dat2, dat2[1,]) # Create one cell that has 2 observations 170 | 171 | expect_warning( desplot(dat0, y~col*row) ) 172 | expect_warning( desplot(dat1, y~col*row|state) ) 173 | expect_warning( desplot(dat2, y~col*row|state*loc) ) 174 | }) 175 | 176 | 177 | # ---------------------------------------------------------------------------- 178 | 179 | 180 | desplot(dat0, yield ~ x+y|loc, col.regions=terrain.colors) 181 | 182 | desplot(dat0, ~ x+y|loc, 183 | text=trt2, col=trt1, cex=1, 184 | col.text=c('red','black','blue','plum'), 185 | text.levels=c('A','B','C')) 186 | 187 | 188 | 189 | 190 | oats34 <- oats35 191 | # create a row of missing values in the field to test .addLevels 192 | oats34[which(oats34$row==16),'yield'] <- NA 193 | desplot(oats34, yield~col+row, tick=TRUE) 194 | desplot(oats34, yield~col+row|block, tick=TRUE) 195 | 196 | # Text over continuous colors 197 | desplot(oats35, yield~col+row, 198 | out1=block, text=gen, cex=1, 199 | xlab="x axis", ylab="y axis", ticks=TRUE) 200 | 201 | # Test 'at' and 'col.regions' for the ribbon 202 | RedYellowBlue <- 203 | colorRampPalette(c("#D73027", "#F46D43", "#FDAE61", "#FEE090", "#FFFFBF", 204 | "#E0F3F8", "#ABD9E9", "#74ADD1", "#4575B4")) 205 | eightnum <- function(x) { 206 | x <- x[!is.na(x)] 207 | st <- grDevices::boxplot.stats(x)$stats 208 | # eps <- .Machine$double.eps 209 | eps <- 10^(log10(127.4)-6) 210 | c(min(x)-eps, st[1:2], st[3]-eps, st[3]+eps, st[4:5], max(x)+eps) 211 | } 212 | 213 | desplot(oats35, yield~col+row, col.regions=RedYellowBlue(7)) 214 | # extreme values barely visible on ribbon 215 | desplot(oats35, yield~col+row, at=eightnum(oats35$yield), midpoint=NULL) 216 | 217 | # fails 218 | #desplot(oats35, yield~col+row, col.regions=RedYellowBlue(7), 219 | # at=eightnum(oats35$yield)) 220 | 221 | # Midpoint options 222 | # mean=103.97 223 | # median=102.5 224 | # middle of range =113.5 225 | desplot(oats35, yield~col+row) # default is median 226 | desplot(oats35, yield~col+row, midpoint="median") # same as default 227 | desplot(oats35, yield~col+row, midpoint=102.5) # same as default 228 | desplot(oats35, yield~col+row, midpoint="midrange") 229 | desplot(oats35, yield~col+row, midpoint=NULL) # same as midrange 230 | desplot(oats35, yield~col+row, midpoint=113.5) # same as midrange 231 | desplot(oats35, yield~col+row, midpoint=103.97) # custom, mean 232 | desplot(oats35, yield~col+row, midpoint=0) # nonsensical low 233 | desplot(oats35, yield~col+row, midpoint=200) # nonsensical hi 234 | 235 | # Remove the ribbon completely 236 | dd <- desplot(oats35, yield ~ col+row) 237 | dd 238 | dd$legend$right=NULL 239 | dd 240 | 241 | # What if the response is character? Treat it like a factor 242 | oats35$genchar <- as.character(oats35$gen) 243 | desplot(oats35, gen~col+row, col=block, num=nitro, cex=1, out1=block) 244 | desplot(oats35, genchar~col+row, col=block, num=nitro, cex=1, out1=block) 245 | 246 | # Show actual yield values 247 | desplot(oats35, block~col+row, text=yield, shorten='no') 248 | 249 | desplot(oats35, block~col+row, col=nitro, text=gen, cex=1, out1=block) 250 | desplot(oats35, block~col+row, col=nitro, text=gen, cex=1, out1=block, out2=gen) 251 | desplot(oats35, block~col+row, num="gen", col="nitro", cex=1) 252 | 253 | desplot(oats35, nitro~col+row, text="gen", cex=.9) 254 | desplot(oats35, nitro~col+row) 255 | desplot(oats35, nitro~col+row|block, text="gen", cex=.9) 256 | 257 | 258 | desplot(oats35, nitro~col+row|block, text="gen", cex=1) 259 | desplot(oats35, block~col+row|block, col="nitro", text="gen", cex=1) 260 | 261 | # Test cases with 1 or 2 rows or columns 262 | 263 | dmet <- agridat::besag.met 264 | 265 | desplot(dmet, yield~col*row|county, out1=rep, out2=block, tick=TRUE) 266 | 267 | # Create new data in which C1 has one row, C2 two rows 268 | # C4 has one column, C5 two columns 269 | dmet2 <- dmet 270 | dmet2 <- subset(dmet2, !(county=="C1" & row<18)) 271 | dmet2 <- subset(dmet2, !(county=="C2" & row<17)) 272 | dmet2 <- subset(dmet2, !(county=="C4" & col<11)) 273 | dmet2 <- subset(dmet2, !(county=="C5" & col<10)) 274 | 275 | desplot(dmet2, yield~col*row|county, tick=TRUE) 276 | # fixme 277 | desplot(dmet2, yield~col*row|county, out1=rep, out2=block, tick=TRUE) 278 | 279 | # Another midpoint example with strong difference between midpoint styles. 280 | if(FALSE){ 281 | library(agridat) 282 | # The high outlier makes most of the field look red 283 | desplot(wiedemann.safflower.uniformity, yield~col*row, 284 | flip=TRUE, tick=TRUE, aspect =99/165, # true aspect 285 | main="wiedemann.safflower.uniformity - midpoint='midrange'", 286 | midpoint=NULL) # same as "midrange" 287 | # Using the median balances the blue/red colors better 288 | desplot(wiedemann.safflower.uniformity, yield~col*row, 289 | flip=TRUE, tick=TRUE, aspect =99/165, # true aspect 290 | main="wiedemann.safflower.uniformity - midpoint='median'", 291 | midpoint="median") 292 | desplot(wiedemann.safflower.uniformity, yield~col*row, 293 | flip=TRUE, tick=TRUE, aspect =99/165, # true aspect 294 | main="wiedemann.safflower.uniformity - eightnum", 295 | at=eightnum(wiedemann.safflower.uniformity$yield)) 296 | 297 | } 298 | 299 | # Test for issue #9. First panel has only 1 row. 300 | dat1row <- data.frame( 301 | var = letters[1:9], 302 | block = as.factor(c(1, 1, 1, 2, 2, 2,2,2,2)), 303 | row = c(rep(1L,6),2,2,2), 304 | col = c(1:6,4,5,6) 305 | ) 306 | desplot(data = dat1row, 307 | tick=TRUE, 308 | form = var ~ col + row | block) 309 | 310 | # ---------------------------------------------------------------------------- 311 | # ---------------------------------------------------------------------------- 312 | 313 | 314 | 315 | # ggdesplot 316 | test_that("ggdesplot", { 317 | expect_silent({ 318 | ggdesplot(oats35, ~ col+row|block, cex=1, num=gen) 319 | }) 320 | } ) 321 | 322 | -------------------------------------------------------------------------------- /R/ggdesplot.R: -------------------------------------------------------------------------------- 1 | # ggdesplot.R 2 | 3 | # Currently the "outline" and "text" do not have guides. 4 | # Perhaps this can be used for multiple scales: 5 | # https://github.com/eliocamp/ggnewscale 6 | 7 | if(0){ 8 | 9 | # multiple legends 10 | # https://stackoverflow.com/questions/18394391/r-custom-legend-for-multiple-layer-ggplot#18395012 11 | 12 | # perfect example for desplot, but no facets 13 | # https://stackoverflow.com/questions/25704567/overlay-ggplot-grouped-tiles-with-polygon-border-depending-on-extra-factor 14 | 15 | # https://stackoverflow.com/questions/36156387/how-to-make-a-custom-ggplot2-geom-with-multiple-geometries 16 | 17 | # https://stackoverflow.com/questions/11846295/how-to-add-different-lines-for-facets#11847210 18 | 19 | } 20 | 21 | if(0){ 22 | libs(agridat) 23 | ggdesplot(besag.met, ~ col*row|county) 24 | ggdesplot(besag.met, ~ col*row|county, col=block) 25 | ggdesplot(besag.met, ~ col*row|county, num=block) 26 | ggdesplot(besag.met, ~ col*row|county, text=block) 27 | 28 | ggdesplot(besag.met, rep ~ col*row|county) 29 | ggdesplot(besag.met, rep ~ col*row|county, col=block, cex=.8) 30 | ggdesplot(besag.met, rep ~ col*row|county, num=block, cex=.8) 31 | ggdesplot(besag.met, rep ~ col*row|county, text=block, cex=.8) 32 | 33 | ggdesplot(besag.met, yield ~ col*row|county, out1=rep) 34 | ggdesplot(besag.met, yield ~ col*row|county, out2=block) 35 | ggdesplot(besag.met, yield ~ col*row|county, out1=rep, out2=block) 36 | 37 | ggdesplot(besag.met, rep ~ col*row|county, ticks=TRUE) 38 | ggdesplot(besag.met, rep ~ col*row|county, ticks=TRUE, flip=TRUE) 39 | 40 | ggdesplot(besag.met, rep ~ col*row|county, out1=rep, ticks=TRUE, 41 | main="besag.met", xlab="column", ylab="row") 42 | 43 | ggdesplot(besag.met, rep ~ col*row|county, out1=rep, show.key=FALSE) 44 | ## col.regions=RedGrayBlue, col.text=NULL, text.levels=NULL, 45 | ## out1.gpar=list(col="black", lwd=3), 46 | ## out2.gpar=list(col="yellow", lwd=1, lty=1), 47 | ## at, midpoint="median", 48 | ## shorten='abb', 49 | ## key.cex, # left legend cex 50 | ## strip.cex=.75, 51 | 52 | } 53 | 54 | # Note: To avoid a similar note from the CMD check about .data, 55 | # use #' @importFrom rlang .data 56 | 57 | #' @import ggplot2 58 | #' @importFrom stats as.formula formula median 59 | #' @importFrom rlang .data 60 | #' @export 61 | #' @rdname desplot 62 | ggdesplot <- function(data, 63 | form=formula(NULL ~ x + y), 64 | num=NULL, num.string=NULL, 65 | col=NULL, col.string=NULL, 66 | text=NULL, text.string=NULL, 67 | out1=NULL, out1.string=NULL, 68 | out2=NULL, out2.string=NULL, 69 | dq=NULL, dq.string=NULL, 70 | col.regions=RedGrayBlue, col.text=NULL, text.levels=NULL, 71 | out1.gpar=list(col="black", lwd=3), 72 | out2.gpar=list(col="yellow", lwd=1, lty=1), 73 | at, midpoint="median", 74 | ticks=FALSE, flip=FALSE, 75 | main=NULL, xlab, ylab, 76 | shorten='abb', 77 | show.key=TRUE, 78 | key.cex, # left legend cex 79 | cex=.4, # cell cex 80 | strip.cex=.75, 81 | aspect=NULL, # aspect ratio for true-scale field maps 82 | subset=TRUE, gg=FALSE, ...){ 83 | 84 | # Would be nice to remove this code someday, maybe 2022? 85 | if(inherits(data, "formula")) { 86 | # Old style: desplot(form, data) 87 | # Use data name for default title. Do this BEFORE subset! 88 | if(missing(main)) main <- deparse(substitute(form)) 89 | tmp <- form 90 | form <- data 91 | data <- tmp 92 | message("Please use desplot(data,form) instead of desplot(form,data)") 93 | } else { 94 | # New style: desplot(data, form) 95 | # Use data name for default title. Do this BEFORE subset! 96 | if(missing(main)) main <- deparse(substitute(data)) 97 | } 98 | 99 | 100 | # subset, based on subset() function 101 | ix <- if (missing(subset)) 102 | rep_len(TRUE, nrow(data)) 103 | else { 104 | e <- substitute(subset) 105 | ix <- eval(e, data, parent.frame()) 106 | if (!is.logical(ix)) 107 | stop("'subset' must be logical") 108 | ix & !is.na(ix) 109 | } 110 | data <- data[ix, ] 111 | data <- droplevels(data) # In case the user called with subset(obj, ...) 112 | 113 | 114 | # Using 'at' overrides 'midpoint' 115 | if(!missing(at) && !is.null(midpoint)) 116 | midpoint <- NULL 117 | 118 | if(!missing(at) && is.vector(col.regions) && 119 | ( length(at) != length(col.regions)+1 ) ) 120 | stop("Length of 'at' must be 1 more than length of 'col.regions'\n") 121 | 122 | # Assume num.string contains the name of a column in data. 123 | # If num.string is NULL, then get its value by converting 'num' 124 | # from a bare name to a string. We MUST do this here 125 | # so that if we switch from desplot to ggdesplot, we can pass 126 | # arguments as strings. 127 | mc <- as.list(match.call()) 128 | 129 | if(is.null(num.string)){ 130 | if("num" %in% names(mc)) { # user did supply argument 131 | if(!is.character(mc$num) & !is.null(mc$num)) { # it is a bare name 132 | num.string <- deparse(substitute(num)) # evaluate to string 133 | } 134 | } 135 | } 136 | 137 | if(is.null(col.string)){ 138 | if("col" %in% names(mc)) { 139 | if(!is.character(mc$col) & !is.null(mc$col)) { 140 | col.string <- deparse(substitute(col)) 141 | } 142 | } 143 | } 144 | 145 | if(is.null(text.string)){ 146 | if("text" %in% names(mc)) { 147 | if(!is.character(mc$text) & !is.null(mc$text)) { 148 | text.string <- deparse(substitute(text)) 149 | } 150 | } 151 | } 152 | 153 | if(is.null(out1.string)){ 154 | if("out1" %in% names(mc)) { 155 | if(!is.character(mc$out1) & !is.null(mc$out1)) { 156 | out1.string <- deparse(substitute(out1)) 157 | } 158 | } 159 | } 160 | 161 | if(is.null(out2.string)){ 162 | if("out2" %in% names(mc)) { 163 | if(!is.character(mc$out2) & !is.null(mc$out2)) { 164 | out2.string <- deparse(substitute(out2)) 165 | } 166 | } 167 | } 168 | 169 | if(is.null(dq.string)){ 170 | if("dq" %in% names(mc)) { 171 | if(!is.character(mc$dq) & !is.null(mc$dq)) { 172 | dq.string <- deparse(substitute(dq)) 173 | } 174 | } 175 | } 176 | 177 | dn <- names(data) 178 | checkvars <- function(x, dn){ 179 | if(!is.null(x) && !is.element(x, dn)) 180 | stop("Could not find '", x,"' in the data frame.") 181 | } 182 | checkvars(num.string, dn) 183 | checkvars(col.string, dn) 184 | checkvars(text.string, dn) 185 | checkvars(out1.string, dn) 186 | checkvars(out2.string, dn) 187 | checkvars(dq.string, dn) 188 | 189 | has.num <- !is.null(num.string) 190 | has.col <- !is.null(col.string) 191 | has.text <- !is.null(text.string) 192 | has.out1 <- !is.null(out1.string) 193 | has.out2 <- !is.null(out2.string) 194 | has.dq <- !is.null(dq.string) 195 | if(has.num & has.text) stop("Specify either 'num' or 'text'. Not both.") 196 | 197 | # Split a formula like: resp~x*y|cond into a list of text strings called 198 | # resp, xy (vector like 'x' '*' 'y') , cond ('cond' could be a vector) 199 | ff <- latticeParseFormula(form, data) 200 | ff <- list(resp = ff$left.name, 201 | xy = strsplit(ff$right.name, " ")[[1]], 202 | cond = names(ff$condition)) 203 | if(length(ff$resp)==0L) ff$resp <- NULL 204 | 205 | fill.string <- ff$resp 206 | x.string <- ff$xy[1] 207 | y.string <- ff$xy[3] 208 | panel.string <- ff$cond[1] 209 | 210 | # If ticks are requested, add axis labels 211 | if (missing(xlab)) 212 | xlab <- ifelse(ticks, x.string, "") 213 | if (missing(ylab)) 214 | ylab <- ifelse(ticks, y.string, "") 215 | 216 | if(has.col){ 217 | data[[col.string]] <- factor(data[[col.string]]) # In case it is numeric 218 | } else { 219 | # We still need a column for color to pass to aes( color=.data[[col.string]] ) 220 | col.string="no_color" 221 | data[[col.string]] <- factor(1) 222 | } 223 | 224 | # Determine what fills the cells: nothing, character/factor, or numeric 225 | if(is.null(fill.string)) fill.type="none" 226 | else if (is.factor(data[[fill.string]])) 227 | fill.type <- "factor" 228 | else if (is.character(data[[fill.string]])){ 229 | data[[fill.string]] <- as.factor(data[[fill.string]]) 230 | fill.type <- "factor" 231 | } else { 232 | fill.type <- "num" 233 | } 234 | 235 | # Now get the fill values/length 236 | if(fill.type=="none") { 237 | fill.val <- rep(1, nrow(data)) 238 | fill.n <- 1 239 | # Hack. We need something to plot, call it .const 240 | form <- as.formula(paste(".const", form[[1]], deparse(form[[2]]), sep="")) 241 | data[['.const']] <- fill.val 242 | } else if(fill.type=="num"){ 243 | fill.val <- data[[fill.string]] 244 | } else { # character/factor 245 | fill.val <- data[[fill.string]] 246 | fill.n <- nlevels(fill.val) 247 | } 248 | 249 | # Define fill colors and 'at' (if not given by the user) 250 | # at = # cut points for region colors 251 | if(fill.type=="none") { 252 | col.regions <- "transparent" 253 | at <- c(0.5,1.5) 254 | } else if(fill.type=="factor"){ 255 | # If col.regions is a function, switch to default fill colors 256 | if(is.function(col.regions)) 257 | col.regions <- c("#E6E6E6","#FFD9D9","#FFB2B2","#FFD7B2","#FDFFB2", 258 | "#D9FFB2","#B2D6FF","#C2B2FF","#F0B2FF","#A6FFC9", 259 | "#FF8C8C","#B2B2B2","#FFBD80","#BFFF80","#80BAFF", 260 | "#9980FF","#E680FF","#D0D192","#59FF9C","#FFA24D", 261 | "#FBFF4D","#4D9FFF","#704DFF","#DB4DFF","#808080", 262 | "#9FFF40","#C9CC3D") 263 | # Handle named vectors for col.regions 264 | if(!is.null(names(col.regions))) { 265 | fill.levels <- levels(fill.val) 266 | matched_colors <- col.regions[fill.levels] 267 | # Check if all levels were matched 268 | if(any(is.na(matched_colors))) { 269 | missing_levels <- fill.levels[is.na(matched_colors)] 270 | warning("col.regions: Not all factor levels found in provided names. ", 271 | "Missing: ", paste(missing_levels, collapse=", "), 272 | ". Falling back to positional matching.") 273 | col.regions <- rep(col.regions, length=fill.n) 274 | } else { 275 | col.regions <- as.vector(matched_colors) 276 | } 277 | } else { 278 | col.regions <- rep(col.regions, length=fill.n) 279 | } 280 | at <- c((0:fill.n)+.5) 281 | } else if(fill.type=="num") { 282 | if(missing(at) && is.null(midpoint)){ 283 | nbins <- 15 284 | if(is.function(col.regions)) col.regions <- col.regions(nbins) 285 | # Use lel = lattice:::extend.limits to move breakpoints past ends of fill.val 286 | zrng <- lel(range(as.numeric(fill.val), finite = TRUE)) 287 | at <- seq(zrng[1], zrng[2], length.out = 16) 288 | } 289 | if(missing(at) && midpoint=="median"){ # default case for continuous data 290 | if(is.function(col.regions)) { 291 | nbins <- 15 292 | col.regions <- col.regions(nbins) 293 | } else { 294 | nbins <- length(col.regions) 295 | } 296 | med <- median(fill.val, na.rm=TRUE) 297 | radius <- max(max(fill.val, na.rm=TRUE)-med, 298 | med-min(fill.val, na.rm=TRUE)) + .Machine$double.eps 299 | zrng <- lel(range(c(med-radius, med+radius))) 300 | brks <- seq(zrng[1], zrng[2], length.out = nbins+1) 301 | binno <- as.numeric(cut(fill.val, breaks=brks)) # bin number for each fill.val 302 | # select only 'col.regions' and 'at' values we actually need 303 | minbin <- min(binno, na.rm=TRUE); maxbin <- max(binno, na.rm=TRUE) 304 | col.regions <- col.regions[minbin:maxbin] 305 | at <- brks[minbin:(maxbin+1)] 306 | } 307 | if(missing(at) && midpoint=="midrange"){ # halfway between min & max 308 | if(is.function(col.regions)) { 309 | nbins <- 15 310 | col.regions <- col.regions(nbins) 311 | } else { 312 | nbins <- length(col.regions) 313 | } 314 | med <- median(range(fill.val, na.rm=TRUE)) 315 | radius <- max(max(fill.val, na.rm=TRUE)-med, 316 | med-min(fill.val, na.rm=TRUE)) + .Machine$double.eps 317 | zrng <- lel(range(c(med-radius, med+radius))) 318 | brks <- seq(zrng[1], zrng[2], length.out = nbins+1) 319 | binno <- as.numeric(cut(fill.val, breaks=brks)) # bin number for each fill.val 320 | # select only 'col.regions' and 'at' values we actually need 321 | minbin <- min(binno, na.rm=TRUE); maxbin <- max(binno, na.rm=TRUE) 322 | col.regions <- col.regions[minbin:maxbin] 323 | at <- brks[minbin:(maxbin+1)] 324 | } 325 | if(missing(at) && is.numeric(midpoint)){ 326 | if(is.function(col.regions)) { 327 | nbins <- 15 328 | col.regions <- col.regions(nbins) 329 | } else { 330 | nbins <- length(col.regions) 331 | } 332 | radius <- max(max(fill.val, na.rm=TRUE)-midpoint, 333 | midpoint-min(fill.val, na.rm=TRUE)) + .Machine$double.eps 334 | zrng <- lel(range(c(midpoint-radius, midpoint+radius))) 335 | brks <- seq(zrng[1], zrng[2], length.out = nbins+1) 336 | binno <- as.numeric(cut(fill.val, breaks=brks)) # bin number for each fill.val 337 | # select only col.regions and at we actually need 338 | minbin <- min(binno, na.rm=TRUE); maxbin <- max(binno, na.rm=TRUE) 339 | col.regions <- col.regions[minbin:maxbin] 340 | at <- brks[minbin:(maxbin+1)] 341 | } 342 | if(!missing(at)){ 343 | # user specified 'at' and 'col.regions' 344 | nbins <- length(at)-1 345 | if(is.function(col.regions)) col.regions <- col.regions(nbins) 346 | } 347 | 348 | } # end fill.type 349 | # comment: the Fields package defines breakpoints so that the first and last 350 | # bins have their midpoints at the minimum and maximum values in z 351 | # https://www.image.ucar.edu/~nychka/Fields/Help/image.plot.html 352 | 353 | # Text colors 354 | if(is.null(col.text)) 355 | col.text <- c("black", "red3", "darkorange2", "chartreuse4", 356 | "deepskyblue4", "blue", "purple4", "darkviolet", "maroon") 357 | 358 | # Change x/y from factor to numeric if needed. Add missing x,y levels. 359 | fac2num <- function(x) as.numeric(levels(x))[x] 360 | if(is.factor(data[[x.string]])) data[[x.string]] <- fac2num(data[[x.string]]) 361 | if(is.factor(data[[y.string]])) data[[y.string]] <- fac2num(data[[y.string]]) 362 | data <- .addLevels(data, x.string, y.string, panel.string) 363 | 364 | # Check for multiple values 365 | if(is.null(panel.string)){ 366 | tt <- table(data[[x.string]], data[[y.string]]) 367 | } else { 368 | tt <- table(data[[x.string]], data[[y.string]], data[[panel.string]]) 369 | } 370 | if(any(tt>1)) 371 | warning("There are multiple data for each x/y/panel combination") 372 | 373 | # Calculate 'lr' rows in legend, 'lt' legend text strings 374 | lr <- 0 375 | lt <- NULL 376 | 377 | if(has.out1){ # out1 378 | lr <- lr + 1 379 | lt <- c(lt, out1.string) 380 | } 381 | if(has.out2){ # out2 382 | lr <- lr + 1 383 | lt <- c(lt, out2.string) 384 | } 385 | if(has.out1 | has.out2) lr <- lr + 1 # blank line 386 | 387 | if(fill.type=="factor") { # fill 388 | lt.fill <- levels(fill.val) 389 | lr <- lr + 2 + fill.n 390 | lt <- c(lt, lt.fill) 391 | } 392 | 393 | if(has.num) { # number 394 | num.val <- factor(data[[num.string]]) 395 | lt.num <- levels(num.val) 396 | num.n <- length(lt.num) 397 | lr <- lr + 2 + num.n 398 | lt <- c(lt, lt.num) 399 | } 400 | 401 | # fixme, col.val not used anywhere 402 | if(has.col) { # color 403 | col.val <- data[[col.string]] 404 | lt.col <- levels(col.val) 405 | col.n <- length(lt.col) 406 | lr <- lr + 2 + col.n 407 | lt <- c(lt, lt.col) 408 | # Handle named vectors for col.text 409 | if(!is.null(names(col.text))) { 410 | matched_colors <- col.text[lt.col] 411 | # Check if all levels were matched 412 | if(any(is.na(matched_colors))) { 413 | missing_levels <- lt.col[is.na(matched_colors)] 414 | warning("col.text: Not all factor levels found in provided names. ", 415 | "Missing: ", paste(missing_levels, collapse=", "), 416 | ". Falling back to positional matching.") 417 | if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n) 418 | } else { 419 | col.text <- as.vector(matched_colors) 420 | } 421 | } else { 422 | if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n) 423 | } 424 | } else { 425 | col.val <- rep(1, nrow(data)) # No color specified, use black by default 426 | } 427 | 428 | if(has.text) { # text 429 | text.val <- factor(data[[text.string]]) # In case it is not a factor 430 | lt.text <- levels(text.val) 431 | text.n <- length(lt.text) 432 | lr <- lr + 2 + text.n 433 | lt <- c(lt, lt.text) 434 | } 435 | 436 | # Set up short version of text 437 | if(has.text & is.null(text.levels)){ 438 | if(shorten=='no' | shorten=='none' | (is.logical(shorten) && !shorten)) 439 | text.levels <- lt.text 440 | else if (shorten=='abb') 441 | text.levels <- abbreviate(lt.text, 2, method='both') 442 | else if (shorten=='sub') 443 | text.levels <- substring(lt.text, 1, 3) 444 | } else { 445 | # Nothing. Why is this here? 446 | } 447 | 448 | # We might not have a key, even though it was requested 449 | if (lr==0) show.key <- FALSE 450 | 451 | # In function call we use 'list' instead of 'gpar' because gpar is not 452 | # exported from grid, so now fixup the class for out1.gpar, out2.gpar 453 | #if(class(out1.gpar) != "gpar") class(out1.gpar) <- "gpar" 454 | #if(class(out2.gpar) != "gpar") class(out2.gpar) <- "gpar" 455 | class(out1.gpar) <- "gpar" 456 | class(out2.gpar) <- "gpar" 457 | 458 | # Cell text 459 | if(has.text) { 460 | data$cell.text <- text.levels[as.numeric(text.val)] 461 | } else if(has.num) { 462 | data$cell.text <- as.numeric(num.val) 463 | } else if(has.col) { 464 | data$cell.text <- rep("x", length=nrow(data)) 465 | } 466 | 467 | # Data quality flag 468 | if(has.dq) { 469 | data$dq.val <- factor(data[[dq.string]]) 470 | levels(data$dq.val) <- list("0"=c("0","G","Good"), 471 | "1"=c("1","Q","Questionable"), 472 | "2"=c("2","B","Bad","S","Suppressed")) 473 | data$dq.val <- as.numeric(as.character(data$dq.val)) 474 | } 475 | 476 | # --------------- build the plot --------------- 477 | 478 | #out <- ggplot(data, aes_string(x=x.string, y=y.string)) 479 | out <- ggplot(data, aes(x=.data[[x.string]], y=.data[[y.string]])) 480 | 481 | if(!is.null(panel.string)) 482 | out <- out + 483 | facet_wrap(panel.string, scales="free") 484 | 485 | if(fill.type=="num") 486 | out <- out + 487 | #geom_tile(aes_string(fill = fill.string)) + 488 | geom_tile(aes(fill = .data[[fill.string]])) + 489 | scale_fill_gradientn(colours=col.regions, guide="colorbar") 490 | 491 | if(fill.type=="factor") 492 | out <- out + 493 | #geom_tile(aes_string(fill = fill.string)) + 494 | geom_tile(aes(fill = .data[[fill.string]])) + 495 | scale_fill_manual(values=col.regions) 496 | 497 | if(has.out1) 498 | out <- out + 499 | #geom_tileborder(aes_string(group=1, grp=out1.string), 500 | geom_tileborder(aes(group=1, grp=.data[[out1.string]]), 501 | lineend="round", 502 | color=out1.gpar$col, 503 | lwd=out1.gpar$lwd, 504 | linetype=if(is.null(out1.gpar$lty)) 1 else out1.gpar$lty) 505 | 506 | if(has.out2) 507 | out <- out + 508 | #geom_tileborder(aes_string(group=1, grp=out2.string), 509 | geom_tileborder(aes(group=1, grp=.data[[out2.string]]), 510 | color=out2.gpar$col, 511 | lwd=out2.gpar$lwd, 512 | linetype=if(is.null(out2.gpar$lty)) 1 else out2.gpar$lty) 513 | # use '4*cex' so that cex in lattice/ggplot2 is roughly the same size 514 | if(has.text|has.num|has.col) # cell text 515 | #out = out + geom_text(aes_string(x.string, y.string, 516 | out = out + geom_text(aes(x=.data[[x.string]], y=.data[[y.string]], 517 | label=.data[["cell.text"]], color=.data[[col.string]]), 518 | size=4*cex) + 519 | scale_color_manual(values=col.text) 520 | 521 | if(has.dq) { 522 | # Data quality indicator 523 | 524 | # draw diagonal line from lower-left to upper-right 525 | data$x1l = data[[x.string]]-.5 526 | data$x1r = data[[x.string]]+.5 527 | data$y1l = data[[y.string]]-.5 528 | data$y1r = data[[y.string]]+.5 529 | # need to use aes_string to prevent CRAN check 530 | # "no visible binding for global variable" 531 | # Same for data[data$dq.val ,] instead of subset 532 | out <- out + 533 | geom_segment(data=data[data$dq.val >= 1L, ], 534 | #aes_string(x="x1l", xend="x1r", y="y1l", yend="y1r"), 535 | aes(x=.data[["x1l"]], xend=.data[["x1r"]], y=.data[["y1l"]], yend=.data[["y1r"]]), 536 | color="black") 537 | # draw diagonal line from upper-left to lower-right 538 | data$y1l = data[[y.string]]+.5 539 | data$y1r = data[[y.string]]-.5 540 | out <- out + 541 | geom_segment(data=data[data$dq.val >= 2L, ], 542 | #aes_string(x="x1l", xend="x1r", y="y1l", yend="y1r"), 543 | aes(x=.data[["x1l"]], xend=.data[["x1r"]], y=.data[["y1l"]], yend=.data[["y1r"]]), 544 | color="black") 545 | } 546 | 547 | if(!show.key) 548 | out <- out + theme(legend.position="none") 549 | 550 | # axis labels 551 | out <- out + 552 | ggtitle(main) + 553 | theme(plot.title = element_text(hjust = 0.5)) + # center title 554 | xlab(xlab) + 555 | ylab(ylab) 556 | 557 | if(flip) 558 | out <- out + scale_y_reverse() 559 | 560 | # remove axis ticks and labels 561 | if(!ticks) 562 | out <- out + 563 | theme(axis.text.x=element_blank(), 564 | axis.text.y=element_blank(), 565 | axis.ticks=element_blank()) 566 | 567 | # Apply aspect ratio if specified 568 | # Both lattice and ggplot2 use aspect as height/width ratio 569 | if(!is.null(aspect)) { 570 | out <- out + coord_fixed(ratio = aspect, expand = FALSE) 571 | } else { 572 | out <- out + coord_cartesian(expand = FALSE) # no extra space between facet heatmaps 573 | } 574 | 575 | # blank theme 576 | out <- out + 577 | theme(axis.line = element_line(colour = "black"), # left/bottom border 578 | panel.grid.major = element_blank(), 579 | panel.grid.minor = element_blank(), 580 | panel.border = element_rect(fill = NA, colour = "black"), # top/right 581 | panel.background = element_blank(), 582 | panel.spacing = unit(0, "lines"), # space between panels 583 | strip.text = element_text(size = 11 * strip.cex) 584 | ) 585 | 586 | out 587 | } 588 | -------------------------------------------------------------------------------- /R/desplot.R: -------------------------------------------------------------------------------- 1 | # desplot.R 2 | 3 | # ---------------------------------------------------------------------------- 4 | 5 | #' Function to create a Red-Gray-Blue palette 6 | #' 7 | #' A function to create a Red-Gray-Blue palette. 8 | #' 9 | #' Using gray instead of white allows missing values to appear as white 10 | #' (actually, transparent). 11 | #' 12 | #' @param n Number of colors to create 13 | #' @return A vector of n colors. 14 | #' @author Kevin Wright 15 | #' 16 | #' @examples 17 | #' pie(rep(1,11), col=RedGrayBlue(11)) 18 | #' title("RedGrayBlue(11)") 19 | #' @export 20 | RedGrayBlue <- colorRampPalette(c("firebrick", "lightgray", "#375997")) 21 | 22 | # ---------------------------------------------------------------------------- 23 | 24 | #' Plot the layout/data of a field experiment. 25 | #' 26 | #' Use this function to plot the layout of a rectangular lattice 27 | #' field experiment and also the observed data values. 28 | #' 29 | #' To create the plot using lattice graphics: 30 | #' 1. \code{desplot(...)}. 31 | #' 32 | #' To create the plot using ggplot2 graphics, use one of the following: 33 | #' 1. \code{ggdesplot(...)}. 34 | #' 2. \code{desplot(..., gg=TRUE)}. 35 | #' 3. \code{options(desplot.gg=TRUE); desplot(...)}. 36 | #' Method 3 is useful to modify all results from existing scripts. 37 | #' 38 | #' The lattice version is complete, mature, and robust. 39 | #' The ggplot2 version is incomplete. The legend can only show colors, 40 | #' and some function arguments are ignored. 41 | #' In general, lattice graphics are about 4-5 times faster than ggplot2 graphics. 42 | 43 | #' Not all lattice parameters are passed down to \code{xyplot}, but it 44 | #' is possible to make almost any change to the plot by assigning the 45 | #' desplot object to a variable and then edit the object by hand or use 46 | #' \code{update} to modify the object. Then print it manually. See the 47 | #' first example below. 48 | #' 49 | #' Use \code{col.regions} to specify fill colors. This can either be a vector 50 | #' of colors or a function that produces a vector of colors. If the response 51 | #' variable is a factor and \code{col.regions} is a \emph{function}, it will 52 | #' be ignored and the cells are filled with default light-colored backgrounds 53 | #' and a key is placed on the left. If the response variable is 54 | #' \emph{numeric}, the cells are colored according to \code{col.regions}, and 55 | #' a ribbon key is placed on the right. 56 | #' 57 | #' Use \code{shorten='abb'} (this is default) to shorten the cell text to 2 58 | #' characters using the \code{abbreviate} function 59 | #' Use \code{shorten='sub'} to use a 3-character substring. 60 | #' Use \code{shorten='no'} or \code{shorten=FALSE} for no shortening. 61 | #' 62 | #' Note that two sub-plots with identical levels of the split-plot factor can 63 | #' be adjacent to each other by virtue of appearing in different whole-plots. 64 | #' To correctly outline the split-plot factor, simply concatenate the 65 | #' whole-plot factor and sub-plot factor together. 66 | #' 67 | #' To call this function inside another function, you can hack like this: 68 | #' vr <- "yield"; vx <- "x"; vy <- "y"; 69 | #' eval(parse(text=paste("desplot(", vr, "~", vx, "*", vy, ", data=yates.oats)"))) 70 | #' 71 | #' @param data A data frame. 72 | #' 73 | #' @param form A formula like \code{yield~x*y|location}. Note x,y are numeric. 74 | #' 75 | #' @param num Bare name (no quotes) of the column of the data to use 76 | #' as a factor for number-coding the text in each cell. 77 | #' 78 | #' @param num.string String name of the column of the data to use 79 | #' as a factor for number-coding the text in each cell. 80 | #' 81 | #' @param col Bare name (no quotes) of the column of the data to use 82 | #' for color-coding the text shown in each cell. 83 | #' 84 | #' @param col.string String name of the column of the data to use 85 | #' for color-coding the text shown in each cell. 86 | #' 87 | #' @param text Bare name (no quotes) of the column of the data to use 88 | #' for the actual text shown in each cell. 89 | #' 90 | #' @param text.string String name of the column of the data to use 91 | #' for the actual text shown in each cell. 92 | #' 93 | #' @param out1 Bare name (no quotes) of the column of the data to use 94 | #' for first-level outlining around blocks of cells. 95 | #' 96 | #' @param out1.string String name of the column of the data to use 97 | #' for first-level outlining around blocks of cells. 98 | #' 99 | #' @param out2 Bare name (no quotes) of the column of the data to use 100 | #' for second-level outlining around blocks of cells. 101 | #' 102 | #' @param out2.string String name of the column of the data to use 103 | #' for second-level outlining around blocks of cells. 104 | #' 105 | #' @param dq Bare name (no quotes) of the column of the data to use 106 | #' for indicating bad data quality with diagonal lines. 107 | #' This can either be a numeric vector or a factor/text. 108 | #' Cells with 1/"Q"/"Questionable" have one diagonal line. 109 | #' Cells with 2/"B"/"Bad","S","Suppressed" have crossed diagonal lines. 110 | #' 111 | #' @param dq.string String name of the column of the data to use 112 | #' for indicating bad data quality with diagonal lines. 113 | #' 114 | #' @param col.regions Colors for the fill color of cells. 115 | #' 116 | #' @param col.text Vector of colors for text strings. 117 | #' 118 | #' @param text.levels Character strings to use instead of default 'levels'. 119 | #' 120 | #' @param out1.gpar A list of graphics parameters for first-level outlining. 121 | #' Can either be an ordinary \code{list()} or a call to \code{gpar()} from the 122 | #' \code{grid} package. 123 | #' 124 | #' @param out2.gpar Graphics parameters for second-level of outlining. 125 | #' 126 | #' @param at Breakpoints for the color ribbon. Use this instead of 'zlim'. 127 | #' Note: using 'at' causes 'midpoint' to be set to NULL. 128 | #' 129 | #' @param midpoint Method to find midpoint of the color ribbon. 130 | #' One of 'midrange', 'median, or a numeric value. 131 | #' 132 | #' @param ticks If TRUE, show tick marks along the bottom and left sides. 133 | #' 134 | #' @param flip If TRUE, vertically flip the image. 135 | #' 136 | #' @param main Main title. 137 | #' 138 | #' @param xlab Label for x axis. 139 | #' 140 | #' @param ylab Label for y axis. 141 | #' 142 | #' @param shorten Method for shortening text in the key, either 'abb', 'sub', 'no', or FALSE. 143 | #' 144 | #' @param show.key If TRUE, show the key on the left side. (This is not the ribbon.) 145 | #' 146 | #' @param key.cex Left legend cex. 147 | #' 148 | #' @param cex Expansion factor for text/number in each cell. 149 | #' 150 | #' @param strip.cex Strip cex. 151 | #' 152 | #' @param aspect Aspect ratio. 153 | #' To get a map of a field with a true aspect ratio include 'aspect=ylen/xlen'. 154 | #' For lattice, 'ylen' is the vertical length of the field and 'xlen' 155 | #' is the horizontal length of the field. 156 | #' For ggplot2, 'ylen' is the vertical length of each cell/plot and 'xlen' 157 | #' is the horizontal length of each plot. 158 | #' 159 | #' @param subset An expression that evaluates to logical index vector for subsetting the data. 160 | #' 161 | #' @param gg If TRUE, desplot() switches to ggdesplot(). 162 | #' 163 | #' @param ... Other. 164 | #' 165 | #' @return A lattice or ggplot2 object 166 | #' 167 | #' @author Kevin Wright 168 | #' 169 | #' @references 170 | #' 171 | #' K. Ryder (1981). 172 | #' Field plans: why the biometrician finds them useful. 173 | #' \emph{Experimental Agriculture}, 17, 243--256. 174 | #' 175 | #' @import grid 176 | #' @import lattice 177 | #' @importFrom reshape2 acast melt 178 | #' @importFrom stats as.formula formula median 179 | #' @export 180 | #' @rdname desplot 181 | #' 182 | #' @examples 183 | #' if(require(agridat)){ 184 | #' 185 | #' # Show how to customize any feature. Here: make the strips bigger. 186 | #' data(besag.met) 187 | #' d1 <- desplot(besag.met, 188 | #' yield ~ col*row|county, 189 | #' main="besag.met", 190 | #' out1=rep, out2=block, out2.gpar=list(col="white"), strip.cex=2) 191 | #' d1 <- update(d1, par.settings = list(layout.heights=list(strip=2))) 192 | #' print(d1) 193 | #' 194 | #' data(yates.oats) 195 | #' # Show experiment layout in true aspect 196 | #' # Field width = 4 plots * 44 links = 176 links 197 | #' # Field length = 18 plots * 28.4 links = 511 links 198 | #' # With lattice, the aspect ratio is y/x for the entire field 199 | #' desplot(yates.oats, 200 | #' yield ~ col+row, 201 | #' out1=block, out2=gen, aspect=511/176) 202 | #' # With ggplot, the aspect ratio is y/x for each cell 203 | #' ggdesplot(yates.oats, 204 | #' yield ~ col+row, 205 | #' out1=block, out2=gen, aspect=28.4/44) 206 | #' 207 | #' desplot(yates.oats, 208 | #' block ~ col+row, 209 | #' col=nitro, text=gen, cex=1, out1=block, 210 | #' out2=gen, out2.gpar=list(col = "gray50", lwd = 1, lty = 1)) 211 | #' 212 | #' } 213 | desplot <- function(data, 214 | form=formula(NULL ~ x + y), 215 | num=NULL, num.string=NULL, 216 | col=NULL, col.string=NULL, 217 | text=NULL, text.string=NULL, 218 | out1=NULL, out1.string=NULL, 219 | out2=NULL, out2.string=NULL, 220 | dq=NULL, dq.string=NULL, 221 | col.regions=RedGrayBlue, col.text=NULL, text.levels=NULL, 222 | out1.gpar=list(col="black", lwd=3), 223 | out2.gpar=list(col="yellow", lwd=1, lty=1), 224 | at, midpoint="median", 225 | ticks=FALSE, flip=FALSE, 226 | main=NULL, xlab, ylab, 227 | shorten='abb', 228 | show.key=TRUE, 229 | key.cex, # left legend cex 230 | cex=.4, # cell cex 231 | strip.cex=.75, 232 | aspect=NULL, 233 | subset=TRUE, gg=FALSE, ...){ 234 | 235 | # Would be nice to remove this code someday, maybe 2022? 236 | if(inherits(data, "formula")) { 237 | # Old style: desplot(form, data) 238 | # Use data name for default title. Do this BEFORE subset! 239 | if(missing(main)) main <- deparse(substitute(form)) 240 | tmp <- form 241 | form <- data 242 | data <- tmp 243 | message("Please use desplot(data,form) instead of desplot(form,data)") 244 | } else { 245 | # New style: desplot(data, form) 246 | # Use data name for default title. Do this BEFORE subset! 247 | if(missing(main)) main <- deparse(substitute(data)) 248 | } 249 | 250 | # subset, based on subset() function 251 | ix <- if (missing(subset)) 252 | rep_len(TRUE, nrow(data)) 253 | else { 254 | e <- substitute(subset) 255 | ix <- eval(e, data, parent.frame()) 256 | if (!is.logical(ix)) 257 | stop("'subset' must be logical") 258 | ix & !is.na(ix) 259 | } 260 | data <- data[ix, ] 261 | data <- droplevels(data) # In case the user called with subset(obj, ...) 262 | 263 | # Using 'at' overrides 'midpoint' 264 | if(!missing(at) && !is.null(midpoint)) 265 | midpoint <- NULL 266 | 267 | if(!missing(at) && is.vector(col.regions) && 268 | ( length(at) != length(col.regions)+1 ) ) 269 | stop("Length of 'at' must be 1 more than length of 'col.regions'\n") 270 | 271 | # Assume num.string contains the name/string of a column in data. 272 | # If num.string is NULL, then get its value by converting 'num' 273 | # from a bare name to a string. We MUST do this here 274 | # so that if we switch from desplot to ggdesplot, we can pass 275 | # arguments as strings. 276 | mc <- as.list(match.call()) 277 | 278 | if(is.null(num.string)){ 279 | if("num" %in% names(mc)) { # user did supply argument 280 | if(!is.character(mc$num) & !is.null(mc$num)) { # it is a bare name 281 | num.string <- deparse(substitute(num)) # evaluate to string 282 | } 283 | } 284 | } 285 | 286 | if(is.null(col.string)){ 287 | if("col" %in% names(mc)) { 288 | if(!is.character(mc$col) & !is.null(mc$col)) { 289 | col.string <- deparse(substitute(col)) 290 | } 291 | } 292 | } 293 | 294 | if(is.null(text.string)){ 295 | if("text" %in% names(mc)) { 296 | if(!is.character(mc$text) & !is.null(mc$text)) { 297 | text.string <- deparse(substitute(text)) 298 | } 299 | } 300 | } 301 | 302 | if(is.null(out1.string)){ 303 | if("out1" %in% names(mc)) { 304 | if(!is.character(mc$out1) & !is.null(mc$out1)) { 305 | out1.string <- deparse(substitute(out1)) 306 | } 307 | } 308 | } 309 | 310 | if(is.null(out2.string)){ 311 | if("out2" %in% names(mc)) { 312 | if(!is.character(mc$out2) & !is.null(mc$out2)) { 313 | out2.string <- deparse(substitute(out2)) 314 | } 315 | } 316 | } 317 | 318 | if(is.null(dq.string)){ 319 | if("dq" %in% names(mc)) { 320 | if(!is.character(mc$dq) & !is.null(mc$dq)) { 321 | dq.string <- deparse(substitute(dq)) 322 | } 323 | } 324 | } 325 | 326 | if(gg | isTRUE(options()$desplot.gg)) { 327 | #if (!requireNamespace("ggplot2")) 328 | # stop("You must first install the ggplot2 package: install.packages('ggplot2')") 329 | out <- ggdesplot(form=form, data=data, 330 | num.string=num.string, col.string=col.string, 331 | text.string=text.string, 332 | out1.string=out1.string, out2.string=out2.string, 333 | dq.string=dq.string, 334 | col.regions=col.regions, col.text=col.text, 335 | out1.gpar=out1.gpar, out2.gpar=out2.gpar, 336 | at=at, midpoint=midpoint, 337 | ticks=ticks, flip=flip, main=main, xlab=xlab, ylab=ylab, 338 | shorten=shorten, show.key=show.key, 339 | key.cex=key.cex, cex=cex, strip.cex=strip.cex, 340 | subset=subset, ...) 341 | return(out) 342 | } 343 | 344 | dn <- names(data) 345 | checkvars <- function(x, dn){ 346 | if(!is.null(x) && !is.element(x, dn)) 347 | stop("Could not find '", x,"' in the data frame.") 348 | } 349 | checkvars(num.string, dn) 350 | checkvars(col.string, dn) 351 | checkvars(text.string, dn) 352 | checkvars(out1.string, dn) 353 | checkvars(out2.string, dn) 354 | checkvars(dq.string, dn) 355 | 356 | has.num <- !is.null(num.string) 357 | has.col <- !is.null(col.string) 358 | has.text <- !is.null(text.string) 359 | has.out1 <- !is.null(out1.string) 360 | has.out2 <- !is.null(out2.string) 361 | has.dq <- !is.null(dq.string) 362 | if(has.num & has.text) stop("Specify either 'num' or 'text'. Not both.") 363 | 364 | 365 | # Split a formula like: resp~x*y|cond into a list of text strings called 366 | # resp, xy (vector like 'x' '*' 'y') , cond ('cond' could be a vector) 367 | ff <- latticeParseFormula(form, data) 368 | ff <- list(resp = ff$left.name, 369 | xy = strsplit(ff$right.name, " ")[[1]], 370 | cond = names(ff$condition)) 371 | if(length(ff$resp)==0L) ff$resp <- NULL 372 | 373 | fill.string <- ff$resp 374 | x.string <- ff$xy[1] 375 | y.string <- ff$xy[3] 376 | panel.string <- ff$cond[1] 377 | 378 | # If ticks are requested, add axis labels 379 | if (missing(xlab)) 380 | xlab <- ifelse(ticks, x.string, "") 381 | if (missing(ylab)) 382 | ylab <- ifelse(ticks, y.string, "") 383 | 384 | # Determine what fills the cells: nothing, character/factor, or numeric 385 | if(is.null(fill.string)) fill.type="none" 386 | else if (is.factor(data[[fill.string]])) 387 | fill.type <- "factor" 388 | else if (is.character(data[[fill.string]])){ 389 | data[[fill.string]] <- as.factor(data[[fill.string]]) 390 | fill.type <- "factor" 391 | } else { 392 | fill.type <- "num" 393 | } 394 | 395 | # Now get the fill values/length 396 | if(fill.type=="none") { 397 | fill.val <- rep(1, nrow(data)) 398 | fill.n <- 1 399 | # Hack. We need something to plot, call it .const 400 | form <- as.formula(paste(".const", form[[1]], deparse(form[[2]]), sep="")) 401 | data[['.const']] <- fill.val 402 | } else if(fill.type=="num"){ 403 | fill.val <- data[[fill.string]] 404 | } else { # character/factor 405 | fill.val <- data[[fill.string]] 406 | fill.n <- nlevels(fill.val) 407 | } 408 | 409 | # Define fill colors and 'at' (if not given by the user) 410 | # at = # cut points for region colors 411 | if(fill.type=="none") { 412 | col.regions <- "transparent" 413 | at <- c(0.5,1.5) 414 | } else if(fill.type=="factor"){ 415 | # If col.regions is a function, switch to default fill colors 416 | if(is.function(col.regions)) 417 | col.regions <- c("#E6E6E6","#FFD9D9","#FFB2B2","#FFD7B2","#FDFFB2", 418 | "#D9FFB2","#B2D6FF","#C2B2FF","#F0B2FF","#A6FFC9", 419 | "#FF8C8C","#B2B2B2","#FFBD80","#BFFF80","#80BAFF", 420 | "#9980FF","#E680FF","#D0D192","#59FF9C","#FFA24D", 421 | "#FBFF4D","#4D9FFF","#704DFF","#DB4DFF","#808080", 422 | "#9FFF40","#C9CC3D") 423 | # Handle named vectors for col.regions 424 | if(!is.null(names(col.regions))) { 425 | fill.levels <- levels(fill.val) 426 | matched_colors <- col.regions[fill.levels] 427 | # Check if all levels were matched 428 | if(any(is.na(matched_colors))) { 429 | missing_levels <- fill.levels[is.na(matched_colors)] 430 | warning("col.regions: Not all factor levels found in provided names. ", 431 | "Missing: ", paste(missing_levels, collapse=", "), 432 | ". Falling back to positional matching.") 433 | col.regions <- rep(col.regions, length=fill.n) 434 | } else { 435 | col.regions <- as.vector(matched_colors) 436 | } 437 | } else { 438 | col.regions <- rep(col.regions, length=fill.n) 439 | } 440 | at <- c((0:fill.n)+.5) 441 | } else if(fill.type=="num") { 442 | if(missing(at) && is.null(midpoint)){ 443 | nbins <- 15 444 | if(is.function(col.regions)) col.regions <- col.regions(nbins) 445 | # Use lel = lattice:::extend.limits to move breakpoints past ends of fill.val 446 | zrng <- lel(range(as.numeric(fill.val), finite = TRUE)) 447 | at <- seq(zrng[1], zrng[2], length.out = 16) 448 | } 449 | if(missing(at) && midpoint=="median"){ # default case for continuous data 450 | if(is.function(col.regions)) { 451 | nbins <- 15 452 | col.regions <- col.regions(nbins) 453 | } else { 454 | nbins <- length(col.regions) 455 | } 456 | med <- median(fill.val, na.rm=TRUE) 457 | radius <- max(max(fill.val, na.rm=TRUE)-med, 458 | med-min(fill.val, na.rm=TRUE)) + .Machine$double.eps 459 | zrng <- lel(range(c(med-radius, med+radius))) 460 | brks <- seq(zrng[1], zrng[2], length.out = nbins+1) 461 | binno <- as.numeric(cut(fill.val, breaks=brks)) # bin number for each fill.val 462 | # select only 'col.regions' and 'at' values we actually need 463 | minbin <- min(binno, na.rm=TRUE); maxbin <- max(binno, na.rm=TRUE) 464 | col.regions <- col.regions[minbin:maxbin] 465 | at <- brks[minbin:(maxbin+1)] 466 | } 467 | if(missing(at) && midpoint=="midrange"){ # halfway between min & max 468 | if(is.function(col.regions)) { 469 | nbins <- 15 470 | col.regions <- col.regions(nbins) 471 | } else { 472 | nbins <- length(col.regions) 473 | } 474 | med <- median(range(fill.val, na.rm=TRUE)) 475 | radius <- max(max(fill.val, na.rm=TRUE)-med, 476 | med-min(fill.val, na.rm=TRUE)) + .Machine$double.eps 477 | zrng <- lel(range(c(med-radius, med+radius))) 478 | brks <- seq(zrng[1], zrng[2], length.out = nbins+1) 479 | binno <- as.numeric(cut(fill.val, breaks=brks)) # bin number for each fill.val 480 | # select only 'col.regions' and 'at' values we actually need 481 | minbin <- min(binno, na.rm=TRUE); maxbin <- max(binno, na.rm=TRUE) 482 | col.regions <- col.regions[minbin:maxbin] 483 | at <- brks[minbin:(maxbin+1)] 484 | } 485 | if(missing(at) && is.numeric(midpoint)){ 486 | if(is.function(col.regions)) { 487 | nbins <- 15 488 | col.regions <- col.regions(nbins) 489 | } else { 490 | nbins <- length(col.regions) 491 | } 492 | radius <- max(max(fill.val, na.rm=TRUE)-midpoint, 493 | midpoint-min(fill.val, na.rm=TRUE)) + .Machine$double.eps 494 | zrng <- lel(range(c(midpoint-radius, midpoint+radius))) 495 | brks <- seq(zrng[1], zrng[2], length.out = nbins+1) 496 | binno <- as.numeric(cut(fill.val, breaks=brks)) # bin number for each fill.val 497 | # select only col.regions and at we actually need 498 | minbin <- min(binno, na.rm=TRUE); maxbin <- max(binno, na.rm=TRUE) 499 | col.regions <- col.regions[minbin:maxbin] 500 | at <- brks[minbin:(maxbin+1)] 501 | } 502 | if(!missing(at)){ 503 | # user specified 'at' and 'col.regions' 504 | nbins <- length(at)-1 505 | if(is.function(col.regions)) col.regions <- col.regions(nbins) 506 | } 507 | 508 | } # end fill.type 509 | 510 | # Text colors 511 | if(is.null(col.text)) 512 | col.text <- c("black", "red3", "darkorange2", "chartreuse4", 513 | "deepskyblue4", "blue", "purple4", "darkviolet", "maroon") 514 | 515 | # Change x/y from factor to numeric if needed. Add missing x,y levels. 516 | fac2num <- function(x) as.numeric(levels(x))[x] 517 | if(is.factor(data[[x.string]])) data[[x.string]] <- fac2num(data[[x.string]]) 518 | if(is.factor(data[[y.string]])) data[[y.string]] <- fac2num(data[[y.string]]) 519 | #data <- .addLevels(data, x.string, y.string, panel.string) 520 | 521 | # Check for multiple values for each cell. 522 | if(is.null(ff$cond)) { 523 | # no factor for panels 524 | tt <- table(data[[x.string]], data[[y.string]]) 525 | } else if(length(ff$cond) == 1L) { 526 | # one conditioning factor 527 | tt <- table(data[[x.string]], data[[y.string]], data[[ff$cond[1]]]) 528 | } else if(length(ff$cond)==2L) { 529 | # two conditioning factors 530 | tt <- table(data[[x.string]], data[[y.string]], data[[ff$cond[1]]], data[[ff$cond[2]]]) 531 | } else { 532 | message("Not checking for multiple data for each x/y/panel combination") 533 | tt <- NULL 534 | } 535 | if(any(tt>1)) 536 | warning("There are multiple data for each x/y/panel combination") 537 | 538 | # lr = legend row count 539 | # lt = legend text strings 540 | lr <- 0 541 | lt <- NULL 542 | 543 | # should I add a legend line for dq ? 544 | 545 | if(has.out1){ # out1 546 | lr <- lr + 1 547 | lt <- c(lt, out1.string) 548 | } 549 | if(has.out2){ # out2 550 | lr <- lr + 1 551 | lt <- c(lt, out2.string) 552 | } 553 | if(has.out1 | has.out2) lr <- lr + 1 # blank line 554 | 555 | if(fill.type=="factor") { # fill 556 | lt.fill <- levels(fill.val) 557 | lr <- lr + 2 + fill.n 558 | lt <- c(lt, lt.fill) 559 | } 560 | 561 | if(has.num) { # number 562 | num.val <- factor(data[[num.string]]) 563 | lt.num <- levels(num.val) 564 | num.n <- length(lt.num) 565 | lr <- lr + 2 + num.n 566 | lt <- c(lt, lt.num) 567 | } 568 | 569 | if(has.col) { # color 570 | col.val <- factor(data[[col.string]]) # In case it is numeric 571 | lt.col <- levels(col.val) 572 | col.n <- length(lt.col) 573 | lr <- lr + 2 + col.n 574 | lt <- c(lt, lt.col) 575 | # Handle named vectors for col.text 576 | if(!is.null(names(col.text))) { 577 | matched_colors <- col.text[lt.col] 578 | # Check if all levels were matched 579 | if(any(is.na(matched_colors))) { 580 | missing_levels <- lt.col[is.na(matched_colors)] 581 | warning("col.text: Not all factor levels found in provided names. ", 582 | "Missing: ", paste(missing_levels, collapse=", "), 583 | ". Falling back to positional matching.") 584 | if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n) 585 | } else { 586 | col.text <- as.vector(matched_colors) 587 | } 588 | } else { 589 | if(length(col.text) < col.n) col.text <- rep(col.text, length=col.n) 590 | } 591 | } else { 592 | col.val <- rep(1, nrow(data)) # No color specified, use black by default 593 | } 594 | 595 | if(has.text) { # text 596 | text.val <- factor(data[[text.string]]) # In case it is not a factor 597 | lt.text <- levels(text.val) 598 | text.n <- length(lt.text) 599 | lr <- lr + 2 + text.n 600 | lt <- c(lt, lt.text) 601 | } 602 | 603 | # Set up short version of text 604 | if(has.text & is.null(text.levels)){ 605 | if(shorten=='no' | shorten=='none' | (is.logical(shorten) && !shorten)) 606 | text.levels <- lt.text 607 | else if (shorten=='abb') 608 | text.levels <- abbreviate(lt.text, 2, method='both') 609 | else if (shorten=='sub') 610 | text.levels <- substring(lt.text, 1, 3) 611 | } else { 612 | # Nothing. Why is this here? 613 | } 614 | 615 | # We might not have a key, even though it was requested 616 | if (lr==0) show.key <- FALSE 617 | 618 | # In function call we use 'list' instead of 'gpar' because gpar is not 619 | # exported from grid, so now change the class for out1.gpar, out2.gpar 620 | #if(class(out1.gpar) != "gpar") class(out1.gpar) <- "gpar" 621 | class(out1.gpar) <- "gpar" 622 | #if(class(out2.gpar) != "gpar") class(out2.gpar) <- "gpar" 623 | class(out2.gpar) <- "gpar" 624 | 625 | # ----- Now we can actually set up the legend grobs ----- 626 | if(show.key) { 627 | longstring <- lt[which.max(nchar(lt))] 628 | if(missing(key.cex)) { 629 | if(lr < 30) key.cex <- 1 630 | else if(lr < 40) key.cex <- .75 631 | else key.cex <- 0.5 632 | } 633 | 634 | foo <- frameGrob(layout = grid.layout(nrow = lr, ncol = 2, 635 | heights = unit(rep(key.cex, lr), "lines"), 636 | widths = unit(c(1,1), c("cm","strwidth"), 637 | data=list(NULL, longstring)))) 638 | 639 | offset <- 1 640 | 641 | if(has.out1){ # outline 642 | foo <- placeGrob(foo, linesGrob(x = unit(c(.2, .8), "npc"), 643 | y = unit(.5, "npc"), 644 | gp=out1.gpar), 645 | row = offset, col = 1) 646 | foo <- placeGrob(foo, textGrob(label = out1.string, gp=gpar(cex=key.cex)), 647 | row = offset, col = 2) 648 | offset <- offset + 1 649 | } 650 | if(has.out2){ 651 | foo <- placeGrob(foo, linesGrob(x=c(.2,.8), y=.5, gp=out2.gpar), 652 | row = offset, col = 1) 653 | foo <- placeGrob(foo, textGrob(label = out2.string, gp=gpar(cex=key.cex)), 654 | row = offset, col = 2) 655 | offset <- offset + 1 656 | } 657 | if(has.out1 | has.out2) offset <- offset + 1 # blank line 658 | 659 | if(fill.type=='factor') { # fill 660 | foo <- placeGrob(foo, textGrob(label = fill.string, gp=gpar(cex=key.cex)), 661 | row = offset, col = 2) 662 | for(kk in 1:fill.n){ 663 | foo <- placeGrob(foo, rectGrob(width = 0.6, 664 | gp = gpar(col="#FFFFCC", 665 | fill=col.regions[kk], cex=key.cex)), 666 | row = offset + kk, col = 1) 667 | foo <- placeGrob(foo, textGrob(label = lt.fill[kk], 668 | gp=gpar(cex=key.cex)), 669 | row = offset+kk, col = 2) 670 | } 671 | offset <- offset + 1 + fill.n + 1 672 | } 673 | 674 | if(has.num) { # number 675 | foo <- placeGrob(foo, textGrob(label = num.string, gp=gpar(cex=key.cex)), 676 | row = offset, col = 2) 677 | for(kk in 1:num.n){ 678 | foo <- placeGrob(foo, textGrob(label = kk, gp=gpar(cex=key.cex)), 679 | row = offset + kk, col = 1) 680 | foo <- placeGrob(foo, textGrob(label = lt.num[kk], gp=gpar(cex=key.cex)), 681 | row = offset + kk, col = 2) 682 | } 683 | offset <- offset + 1 + num.n + 1 684 | } 685 | 686 | if(has.col) { # color 687 | foo <- placeGrob(foo, textGrob(label = col.string, gp=gpar(cex=key.cex)), 688 | row = offset, col = 2) 689 | for(kk in 1:col.n){ 690 | foo <- placeGrob(foo, pointsGrob(.5,.5, pch=19, # 19 = solid circle 691 | gp=gpar(col=col.text[kk], 692 | cex=key.cex)), 693 | row = offset + kk, col = 1) 694 | foo <- placeGrob(foo, textGrob(label = lt.col[kk], gp=gpar(cex=key.cex)), 695 | row = offset + kk, col = 2) 696 | } 697 | offset <- offset + 1 + col.n + 1 698 | } 699 | 700 | if(has.text) { # text 701 | foo <- placeGrob(foo, textGrob(label = text.string, gp=gpar(cex=key.cex)), 702 | row = offset, col = 2) 703 | for(kk in 1:text.n){ 704 | foo <- placeGrob(foo, textGrob(label = text.levels[kk], 705 | gp=gpar(cex=key.cex)), 706 | row = offset + kk, col = 1) 707 | foo <- placeGrob(foo, textGrob(label = lt.text[kk], gp=gpar(cex=key.cex)), 708 | row = offset + kk, col = 2) 709 | } 710 | offset <- offset + 1 + text.n + 1 711 | } 712 | 713 | } else foo <- NULL 714 | 715 | # Cell text 716 | if(has.text) { 717 | cell.text <- text.levels[as.numeric(text.val)] 718 | } else if(has.num) { 719 | cell.text <- as.numeric(num.val) 720 | } else if(has.col) { 721 | cell.text <- rep("+", length=nrow(data)) 722 | } 723 | 724 | # Data quality flag 725 | if(has.dq) { 726 | dq.val <- as.factor(data[[dq.string]]) 727 | levels(dq.val) <- list("0"=c("0","G","Good"), 728 | "1"=c("1","Q","Questionable"), 729 | "2"=c("2","B","Bad","S","Suppressed")) 730 | dq.val <- as.numeric(as.character(dq.val)) 731 | } else dq.val <- NULL 732 | 733 | out1.val <- if(has.out1) data[[out1.string]] else NULL 734 | out2.val <- if(has.out2) data[[out2.string]] else NULL 735 | 736 | out <- 737 | levelplot(form, 738 | data=data, 739 | out1f=out1.val, out1g=out1.gpar, 740 | out2f=out2.val, out2g=out2.gpar, 741 | dq=dq.val, 742 | flip=flip, 743 | col.regions=col.regions, 744 | colorkey = if(fill.type=="num") TRUE else FALSE, 745 | as.table=TRUE, 746 | at=at, 747 | legend=if(show.key) list(left=list(fun=foo)) else list(), 748 | main=main, 749 | xlab=xlab, 750 | ylab=ylab, 751 | scales=list(relation='free', # Different scales for each panel 752 | draw=ticks # Don't draw panel axes 753 | ), 754 | prepanel = prepanel.desplot, 755 | panel=function(x, y, z, subscripts, groups, ..., 756 | out1f, out1g, out2f, out2g, dq){ 757 | # Fill the cells and outline 758 | panel.outlinelevelplot(x, y, z, subscripts, at, ..., 759 | out1f=out1f, out1g=out1g, 760 | out2f=out2f, out2g=out2g, 761 | dq=dq) 762 | 763 | # Numbers, colors, or text 764 | if(has.num|has.text|has.col) 765 | panel.text(x[subscripts], y[subscripts], 766 | cell.text[subscripts], 767 | cex=cex, 768 | col=col.text[as.numeric(col.val[subscripts])]) 769 | }, 770 | strip=strip.custom(par.strip.text=list(cex=strip.cex)), ...) 771 | 772 | # Use 'update' for any other modifications 773 | #if(!show.key) out <- update(out, legend=list(left=NULL)) 774 | 775 | return(out) 776 | } 777 | 778 | prepanel.desplot <- function (x, y, subscripts, flip, ...) { 779 | # based on lattice:::prepanel.default.levelplot 780 | pad <- lattice.getOption("axis.padding")$numeric 781 | 782 | # Note: x and y are NOT factors 783 | 784 | if (length(subscripts) > 0) { 785 | x <- x[subscripts] 786 | y <- y[subscripts] 787 | 788 | ux <- sort(unique(x[is.finite(x)])) 789 | if ((ulen <- length(ux)) < 2) 790 | #xlim <- ux + c(-1, 1) 791 | xlim <- ux + c(-0.5, 0.5) 792 | else { 793 | diffs <- diff(as.numeric(ux))[c(1, ulen - 1)] 794 | xlim <- c(ux[1] - diffs[1]/2, ux[ulen] + diffs[2]/2) 795 | } 796 | uy <- sort(unique(y[is.finite(y)])) 797 | if ((ulen <- length(uy)) < 2) 798 | #ylim <- uy + c(-1, 1) 799 | ylim <- uy + c(-0.5, 0.5) 800 | else { 801 | diffs <- diff(as.numeric(uy))[c(1, ulen - 1)] 802 | ylim <- c(uy[1] - diffs[1]/2, uy[ulen] + diffs[2]/2) 803 | } 804 | 805 | # This is returned 806 | ret <- list(xlim = lel(xlim, prop = -pad/(1 + 2 * pad)), 807 | ylim = lel(ylim, prop = -pad/(1 + 2 * pad)), 808 | dx = length(ux), 809 | dy = length(uy)) 810 | if(flip) ret$ylim <- rev(ret$ylim) 811 | 812 | ret 813 | } 814 | else { 815 | # This is the value of the prepanel.null() function 816 | list(xlim = rep(NA_real_, 2), ylim = rep(NA_real_, 2), dx = NA_real_, 817 | dy = NA_real_) 818 | } 819 | } 820 | 821 | #' Panel Function for desplot 822 | #' 823 | #' This is a panel function for \code{desplot} which fills cells with 824 | #' a background color and adds outlines around blocks of cells. 825 | #' 826 | #' It does not add the text labels, numbers, or colors. 827 | #' 828 | #' The rule for determining where to draw outlines is to compare the 829 | #' levels of the factor used for outlining. If bordering cells have 830 | #' different levels of the factor, then a border is drawn. 'NA' values 831 | #' are ignored (otherwise, too many lines would be drawn). 832 | #' 833 | #' The code works, but is probably overkill and has not been streamlined. 834 | #' 835 | #' @param x Coordinates 836 | #' 837 | #' @param y Coordinates 838 | #' 839 | #' @param z Value for filling each cell. 840 | #' 841 | #' @param subscripts For compatibility. 842 | #' 843 | #' @param at Breakpoints for the colors. 844 | #' 845 | #' @param ... Other 846 | #' 847 | #' @param alpha.regions Transparency for fill colors. Not well tested. 848 | #' 849 | #' @param out1f Factor to use for outlining (level 1). 850 | #' 851 | #' @param out1g Factor to use for outlining (level 2). 852 | #' 853 | #' @param out2f Graphics parameters to use for outlining. 854 | #' 855 | #' @param out2g Graphics parameters to use for outlining. 856 | #' 857 | #' @param dq Indicator of which cells should be flagged for data quality. 858 | #' 859 | #' @export 860 | #' @references 861 | #' None 862 | #' 863 | panel.outlinelevelplot <- function(x, y, z, subscripts, at, 864 | ..., 865 | alpha.regions = 1, 866 | out1f, out1g, out2f, out2g, 867 | dq) { 868 | # Derived from lattice::panel.levelplot 869 | dots=list(...) 870 | col.regions=dots$col.regions 871 | 872 | # parent function forces x,y to be numeric, not factors 873 | 874 | if (length(subscripts) == 0L) return() 875 | 876 | dq <- dq[subscripts] 877 | x <- x[subscripts] 878 | y <- y[subscripts] 879 | z <- as.numeric(z) 880 | zcol <- level.colors(z, at, col.regions, colors = TRUE) 881 | 882 | zlim <- range(z, finite = TRUE) 883 | z <- z[subscripts] 884 | zcol <- zcol[subscripts] 885 | 886 | ux <- sort(unique(x[!is.na(x)])) 887 | bx <- if (length(ux) > 1L) { # breakpoints 888 | c(3 * ux[1] - ux[2], ux[-length(ux)] + ux[-1], 889 | 3 * ux[length(ux)] - ux[length(ux) - 1])/2 890 | } else ux + c(-0.5, 0.5) 891 | lx <- diff(bx) # lengths? I think this is same as rep(1, length(ux)) 892 | cx <- (bx[-1] + bx[-length(bx)])/2 # centers 893 | 894 | uy <- sort(unique(y[!is.na(y)])) 895 | by <- if (length(uy) > 1) { 896 | c(3 * uy[1] - uy[2], uy[-length(uy)] + uy[-1], 897 | 3 * uy[length(uy)] - uy[length(uy) - 1])/2 898 | } else uy + c(-0.5, 0.5) 899 | ly <- diff(by) 900 | cy <- (by[-1] + by[-length(by)])/2 901 | 902 | idx <- match(x, ux) 903 | idy <- match(y, uy) 904 | 905 | # Fill the cells with background color 906 | grid.rect(x = cx[idx], y = cy[idy], 907 | width=lx[idx], 908 | height = ly[idy], 909 | default.units = "native", 910 | gp = gpar(fill = zcol, lwd = 1e-05, 911 | col="transparent", 912 | alpha = alpha.regions)) 913 | 914 | # Data quality indicator 915 | gp=list(col="black", lwd=1) 916 | class(gp) <- "gpar" 917 | # draw diagonal line from lower-left to upper-right 918 | xd=x[dq >= 1L] 919 | yd=y[dq >= 1L] 920 | if(length(xd)>0) grid.segments(x0=xd-.5, y0=yd-.5, 921 | x1=xd+.5, y1=yd+.5, 922 | default.units="native", gp=gp) 923 | # draw diagonal line from upper-left to lower-right 924 | xd=x[dq >= 2L] 925 | yd=y[dq >= 2L] 926 | if(length(xd)>0) grid.segments(x0=xd-.5, y0=yd+.5, 927 | x1=xd+.5, y1=yd-.5, 928 | default.units="native", gp=gp) 929 | 930 | # Outline factor 1 931 | if(!is.null(out1f)){ 932 | bb <- calc_borders(x, y, as.character(out1f[subscripts])) 933 | if(!is.null(bb) && nrow(bb)>0) { 934 | grid.segments(x0 = bb$x, y0=bb$y, x1=bb$xend, y1=bb$yend, 935 | default.units="native", gp=out1g) 936 | } 937 | } 938 | 939 | # Outline factor 2 940 | if(!is.null(out2f)){ 941 | bb <- calc_borders(x, y, as.character(out2f[subscripts])) 942 | if(!is.null(bb) && nrow(bb)>0){ 943 | grid.segments(x0 = bb$x, y0=bb$y, x1=bb$xend, y1=bb$yend, 944 | default.units="native", gp=out2g) 945 | } 946 | } 947 | 948 | return() 949 | } 950 | 951 | #' @noRd 952 | .addLevels <- function(dat, xvar='x', yvar='y', locvar=NULL){ 953 | # For each loc, we want x/y coords to be complete. 954 | # NO: 1,2,4. YES: 1,2,3,4. 955 | # Add one NA datum for each missing x and each missing y 956 | # This does NOT completely fill in the rectangle (as needed by asreml) 957 | 958 | ## # Original values 959 | ## ox <- dat[[xvar]] 960 | ## oy <- dat[[yvar]] 961 | 962 | ## if( is.factor(ox) | is.factor(oy) ) 963 | ## stop("FIXME: ", xvar, " or ", yvar, " are factors.") 964 | 965 | ## if(is.null(locvar)) { 966 | ## loclevs <- factor("1") # hack alert 967 | ## } else { 968 | ## oloc <- factor(dat[[locvar]]) # In case loc is character 969 | ## loclevs <- levels(oloc) 970 | ## } 971 | 972 | ## for(loc.i in loclevs){ 973 | 974 | ## if(is.null(locvar)){ 975 | ## ux <- sort(unique(ox)) 976 | ## uy <- sort(unique(oy)) 977 | ## } else { 978 | ## ux <- sort(unique(ox[oloc==loc.i])) 979 | ## uy <- sort(unique(oy[oloc==loc.i])) 980 | ## } 981 | ## # Add new rows and columns. Fill with missing data 982 | ## xnew <- setdiff(seq(from=min(ux), to=max(ux), by=1), ux) 983 | ## ynew <- setdiff(seq(from=min(uy), to=max(uy), by=1), uy) 984 | ## if(length(xnew) > 0){ 985 | ## newrows <- nrow(dat) + 1:length(xnew) 986 | ## dat[newrows, xvar] <- xnew # R creates these rows 987 | ## if(!is.null(locvar)) 988 | ## dat[newrows, locvar] <- rep(loc.i, length(xnew)) 989 | ## } 990 | ## if(length(ynew) > 0){ 991 | ## browser() 992 | ## newrows <- nrow(dat) + 1:length(ynew) 993 | ## dat[newrows, yvar] <- ynew 994 | ## if(!is.null(locvar)) 995 | ## dat[newrows, locvar] <- rep(loc.i, length(ynew)) 996 | ## } 997 | ## } 998 | 999 | # The old code above assumed locvar was character/factor, but still worked 1000 | # if locvar was numeric because R was coercing the data when assigning the 1001 | # locvar to the new row. BUT, if dat was a tibble, then the coercion was 1002 | # not working. The code below fixes that problem so that now locvar is 1003 | # allowed to be numeric. Also slightly cleaner. 1004 | 1005 | if( is.factor(dat[[xvar]]) | is.factor(dat[[yvar]]) ) 1006 | stop("FIXME: ", xvar, " or ", yvar, " are factors.") 1007 | 1008 | if(is.null(locvar)) { 1009 | # If there is no location variable, we use "1" as the location level 1010 | uniquelocs <- "1" 1011 | } else { 1012 | oloc <- dat[[locvar]] 1013 | uniquelocs <- unique( oloc ) 1014 | } 1015 | 1016 | for(loc.i in uniquelocs){ 1017 | # Index of data rows for this loc. 1018 | if(is.null(locvar)){ 1019 | ix <- 1:nrow(dat) 1020 | } else { 1021 | ix <- which(dat[[locvar]] == loc.i) 1022 | } 1023 | 1024 | # Add rows with new x values that were missing. 1025 | ux <- unique(dat[ix, xvar]) 1026 | newx <- setdiff(seq(from=min(ux), to=max(ux), by=1), ux) 1027 | n.newx <- length(newx) 1028 | if(n.newx > 0){ 1029 | ix.new <- nrow(dat) + 1:n.newx 1030 | dat[ix.new, xvar] <- newx # R creates these rows on the fly 1031 | if(!is.null(locvar)) 1032 | dat[ix.new, locvar] <- rep(loc.i, n.newx) 1033 | } 1034 | # Same for y. 1035 | uy <- unique(dat[ix, yvar]) 1036 | newy <- setdiff(seq(from=min(uy), to=max(uy), by=1), uy) 1037 | n.newy <- length(newy) 1038 | if(n.newy > 0){ 1039 | ix.new <- nrow(dat) + 1:n.newy 1040 | dat[ix.new, yvar] <- newy 1041 | if(!is.null(locvar)) 1042 | dat[ix.new, locvar] <- rep(loc.i, n.newy) 1043 | } 1044 | } 1045 | 1046 | return(dat) 1047 | } 1048 | 1049 | #' @noRd 1050 | # lel is a very simple version of lattice:::extend.limits 1051 | lel <- function (lim, prop = lattice.getOption("axis.padding")$numeric) { 1052 | 1053 | if (lim[1] == lim[2]) 1054 | lim + 0.5 * c(-1, 1) 1055 | else { 1056 | d <- diff(as.numeric(lim)) 1057 | lim + prop * d * c(-1, 1) 1058 | } 1059 | } 1060 | --------------------------------------------------------------------------------