# This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Library General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Library General Public License for more details. # # You should have received A copy of the GNU Library General # Public License along with this library; if not, write to the # Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, # MA 02111-1307 USA # Copyrights (C) # for this R-port: # 1999 - 2008, Diethelm Wuertz, Rmetrics Foundation, GPL # Diethelm Wuertz # www.rmetrics.org # for the code accessed (or partly included) from other R-ports: # see R's copyright and license files # for the code accessed (or partly included) from contributed R-ports # and other sources # see Rmetrics's copyright file ################################################################################ # FUNCTION: DESCRIPTION: # .emptyPlot Creates an empty plot page # .subPlot Creates a sub plot # .cnvrt.coords Converts coordinates ################################################################################ .emptyPlot <- function() { # Description: # Creates an empty plot page # FUNCTION: # Plot: plot(c(0, 1), c(0, 1), type = "n", xlab = "", ylab = "", ann = TRUE, axes = FALSE) # Return Value: invisible() } # ------------------------------------------------------------------------------ # Package: TeachingDemos # Title: Demonstrations for teaching and learning # Version: 1.6 # Author: Greg Snow # Description: This package is a set of demonstration functions that can # be used in a classroom to demonstrate statistical concepts, or on your # own to better understand the concepts or the programming. # Maintainer: Greg Snow # License: Artistic-2.0 # Date: 2007-09-07 # Suggests: tcltk, lattice, tkrplot, MASS, rgl, sgeostat, mapproj # Enhances: maptools, qcc # LazyData: true # Packaged: Wed Nov 28 12:13:53 2007; hornik # ------------------------------------------------------------------------------ # Example: # plot(c(0, 1), c(0, 1)); .subPlot(hist(rnorm(100)), x = 0.5, y = 0.5) # ------------------------------------------------------------------------------ .subPlot <- function(fun, x, y = NULL, size = c(1, 1), vadj = 0.5, hadj = 0.5, pars = NULL) { # Description: # Creates a sub plot # FUNCTION: # Par: old.par <- par(no.readonly=TRUE) on.exit(par(old.par)) if(missing(x)) x <- locator(2) xy <- xy.coords(x,y) if(length(xy$x) != 2){ pin <- par('pin') tmp <- .cnvrt.coords(xy$x[1],xy$y[1],'usr')$plt x <- c( tmp$x - hadj*size[1]/pin[1], tmp$x + (1-hadj)*size[1]/pin[1] ) y <- c( tmp$y - vadj*size[2]/pin[2], tmp$y + (1-vadj)*size[2]/pin[2] ) xy <- .cnvrt.coords(x,y,'plt')$fig } else { xy <- .cnvrt.coords(xy,,'usr')$fig } par(pars) par(plt=c(xy$x,xy$y), new = TRUE) fun tmp.par <- par(no.readonly = TRUE) return(invisible(tmp.par)) } # ------------------------------------------------------------------------------ .cnvrt.coords <- function(x,y=NULL,input=c('usr','plt','fig','dev','tdev')) { # Description: # Converts Coordinates # FUNCTION: input <- match.arg(input) xy <- xy.coords(x,y) cusr <- par('usr') cplt <- par('plt') cfig <- par('fig') cdin <- par('din') comi <- par('omi') cdev <- c(comi[2]/cdin[1],(cdin[1]-comi[4])/cdin[1], comi[1]/cdin[2],(cdin[2]-comi[3])/cdin[2]) if(input=='usr'){ usr <- xy plt <- list() plt$x <- (xy$x-cusr[1])/(cusr[2]-cusr[1]) plt$y <- (xy$y-cusr[3])/(cusr[4]-cusr[3]) fig <- list() fig$x <- plt$x*(cplt[2]-cplt[1])+cplt[1] fig$y <- plt$y*(cplt[4]-cplt[3])+cplt[3] dev <- list() dev$x <- fig$x*(cfig[2]-cfig[1])+cfig[1] dev$y <- fig$y*(cfig[4]-cfig[3])+cfig[3] tdev <- list() tdev$x <- dev$x*(cdev[2]-cdev[1])+cdev[1] tdev$y <- dev$y*(cdev[4]-cdev[3])+cdev[3] return( list( usr=usr, plt=plt, fig=fig, dev=dev, tdev=tdev ) ) } if(input=='plt') { plt <- xy usr <- list() usr$x <- plt$x*(cusr[2]-cusr[1])+cusr[1] usr$y <- plt$y*(cusr[4]-cusr[3])+cusr[3] fig <- list() fig$x <- plt$x*(cplt[2]-cplt[1])+cplt[1] fig$y <- plt$y*(cplt[4]-cplt[3])+cplt[3] dev <- list() dev$x <- fig$x*(cfig[2]-cfig[1])+cfig[1] dev$y <- fig$y*(cfig[4]-cfig[3])+cfig[3] tdev <- list() tdev$x <- dev$x*(cdev[2]-cdev[1])+cdev[1] tdev$y <- dev$y*(cdev[4]-cdev[3])+cdev[3] return( list( usr=usr, plt=plt, fig=fig, dev=dev, tdev=tdev ) ) } if(input=='fig') { fig <- xy plt <- list() plt$x <- (fig$x-cplt[1])/(cplt[2]-cplt[1]) plt$y <- (fig$y-cplt[3])/(cplt[4]-cplt[3]) usr <- list() usr$x <- plt$x*(cusr[2]-cusr[1])+cusr[1] usr$y <- plt$y*(cusr[4]-cusr[3])+cusr[3] dev <- list() dev$x <- fig$x*(cfig[2]-cfig[1])+cfig[1] dev$y <- fig$y*(cfig[4]-cfig[3])+cfig[3] tdev <- list() tdev$x <- dev$x*(cdev[2]-cdev[1])+cdev[1] tdev$y <- dev$y*(cdev[4]-cdev[3])+cdev[3] return( list( usr=usr, plt=plt, fig=fig, dev=dev, tdev=tdev ) ) } if(input=='dev'){ dev <- xy fig <- list() fig$x <- (dev$x-cfig[1])/(cfig[2]-cfig[1]) fig$y <- (dev$y-cfig[3])/(cfig[4]-cfig[3]) plt <- list() plt$x <- (fig$x-cplt[1])/(cplt[2]-cplt[1]) plt$y <- (fig$y-cplt[3])/(cplt[4]-cplt[3]) usr <- list() usr$x <- plt$x*(cusr[2]-cusr[1])+cusr[1] usr$y <- plt$y*(cusr[4]-cusr[3])+cusr[3] tdev <- list() tdev$x <- dev$x*(cdev[2]-cdev[1])+cdev[1] tdev$y <- dev$y*(cdev[4]-cdev[3])+cdev[3] return( list( usr=usr, plt=plt, fig=fig, dev=dev, tdev=tdev ) ) } if(input=='tdev'){ tdev <- xy dev <- list() dev$x <- (tdev$x-cdev[1])/(cdev[2]-cdev[1]) dev$y <- (tdev$y-cdev[3])/(cdev[4]-cdev[3]) fig <- list() fig$x <- (dev$x-cfig[1])/(cfig[2]-cfig[1]) fig$y <- (dev$y-cfig[3])/(cfig[4]-cfig[3]) plt <- list() plt$x <- (fig$x-cplt[1])/(cplt[2]-cplt[1]) plt$y <- (fig$y-cplt[3])/(cplt[4]-cplt[3]) usr <- list() usr$x <- plt$x*(cusr[2]-cusr[1])+cusr[1] usr$y <- plt$y*(cusr[4]-cusr[3])+cusr[3] tdev <- list() tdev$x <- dev$x*(cdev[2]-cdev[1])+cdev[1] tdev$y <- dev$y*(cdev[4]-cdev[3])+cdev[3] return( list( usr=usr, plt=plt, fig=fig, dev=dev, tdev=tdev ) ) } } ################################################################################