quadplot <-
    function(mat4,
             pointlabs = rownames(mat4),
             vertexlabs = paste(1:4),
             normalize = median(abs(c(mat4))) > 1)
{
    mat4 <- if(is.data.frame(mat4)) data.matrix(mat4) else as.matrix(mat4)
    n <- nrow(mat4)
    m <- ncol(mat4)
    if(m != 4)
        stop("Data matrix `mat4' must have four columns.")
    if(normalize)
        mat4 <- mat4 / c(mat4 %*% c(1,1,1,1))
    ## == sweep(mat4, 1, apply(mat4,1,sum), "/")

    rt3  <- 1/sqrt(3)
    rt14 <- 1/sqrt(14)
    projct <- cbind(c(0, -1,-4, 5)*(rt3*rt14),
                    c(3, -1,-1,-1)* rt3/2,
                    c(0, -3, 2, 1)* rt14)
    tetralines <- cbind(c(1,1,1,2,2,3),
                        c(2,3,4,3,4,4))

    mat3 <- (rbind(diag(4), mat4) - 1/4) %*% projct

    if(is.null(pointlabs)) pointlabs <- as.character(1:n)
    xgobi(mat3, lines = tetralines, rowlab = c(vertexlabs, pointlabs),
          resource=c("*showLines: True", "*showAxes: False"))
    invisible(mat3) # or invisible()
}
reggeom <- function(matrx=matrix(c(
  0,5780,-1156,3468,3468,3468,-867,4335,0,0,-612,4080,5440,2652,3468,3420,3468,
  0,  0,4624,3468,3468,  0,3468,0,3468,4624,2448,1020,1360,3264,3264,3456,3456,
  0,  0,   0,4624,0,0,0,0,0,0,0,0,0,0,0,0,0),
                   nrow=17,
                   ncol=3,
                   byrow=F),

      collab=c("U","V","W"),

      rowlab=c(
 "o","x1","x2","y","b","c","d","e","f","g","h","k","m","p","q","r","s"),

      colors=NULL,
      glyphs=NULL,
      erase=NULL,

      lines=matrix(c(1,6,8,1,11,7,1,1,5,6,6,15,17,8,5,9,1,9,10,
                     6,8,2,11,7,3,4,5,4,4,15,17,5,5,9,7,9,10,3),
                   nrow=19,
                   ncol=2,
                   byrow=F),

      linecolors=c("red", "yellow", "yellow", "yellow", "yellow", "yellow",
                   "orchid", "green", "green", "red", "skyblue", "skyblue",
                   "skyblue", "white", "white", "white",
                   "slateblue", "slateblue", "slateblue"),

      resources=c("*showLines: True",
                  "*showAxes: False",
                  "*showPoints: False",
                  "*XGobi*PlotWindow.height: 500",
                  "*XGobi*PlotWindow.width: 500",
                  "*XGobi*VarPanel.width: 50"),

      title="Regression Geometry",

      vgroups    = c(1,1,1),
      std        = "msd",
#      dev        = 1.5, #default is 2
      nlinkable  = NULL,
      subset     = NULL,
      display    = NULL)
{
  xgobi(matrx=matrx,
      collab=collab,
      rowlab=rowlab,
      colors=colors,
      glyphs=glyphs,
      erase=erase,
      lines=lines,
      linecolors=linecolors,
      resources=resources,
      title=title,
      vgroups=vgroups,
      std=std,
#      dev=dev,
      nlinkable=nlinkable,
      subset=subset,
      display=display)
}

## These should really match the *brushColor[0-9]  `fallback resources' in
##  XGOBISRC/src/xgobitop.h :
## [these are ok for the "Dec. 1999" version of xgobi]:
xgobi.colors.default <-
  c("DeepPink", "OrangeRed1", "DarkOrange", "Gold", "Yellow",
    "DeepSkyBlue1", "SlateBlue1", "YellowGreen",
    "MediumSpringGreen", "MediumOrchid")

if(!exists("Sys.sleep", mode = "function")) {
    warning("\n*** Your R version is outdated.\n*** Consider upgrading!!\n")
    Sys.sleep <- function(time) system(paste("sleep",time))
}

xgobi <-
function(matrx,
	 collab = dimnames(matrx)[[2]],
	 rowlab = dimnames(matrx)[[1]],
	 colors = NULL,
	 glyphs = NULL,
	 erase	= NULL,
	 lines	= NULL,
	 linecolors = NULL,
	 resources  = NULL,
	 title	= deparse(substitute(matrx)),
	 vgroups= NULL,
	 std	= "mmx",
	 nlinkable  = NULL,
	 subset = NULL,
	 display= NULL,
	 keep	= FALSE,
	 fprefix= "xgobi-")
{
    x <- if(is.expression(matrx) || is.character(matrx))
	eval(matrx) else matrx
    if(is.data.frame(x)) x <- data.matrix(x)

    if (any(is.infinite(x[!is.na(x)])))
	stop("Sorry, xgobi can't handle Inf's")

    if (!is.null(title) && !is.character(title))
        stop("title must be a character string")
    dfile <- tempfile(paste(fprefix,
                            abbreviate(gsub("[^A-Za-z0-9]","",title), 5),
                            sep=""))
    write.table(x, file = dfile, quote = FALSE,
		row.names = FALSE, col.names = FALSE)
    if(!keep) on.exit(unlink(dfile), add = TRUE)

    args <- paste("-std", std) ##, "-dev", dev)

    ## Column / Var labels ###
    if (!is.null(collab)) {
	if (!is.vector(collab) || !is.character(collab))# check data type
	    stop("The `collab' argument needs to be a character vector")
	if (!missing(collab) && length(collab) != NCOL(x))
	    stop("`collab' has wrong length (not matching NCOL(x))")
        cat(collab, file = (colfile <- paste(dfile, ".col", sep="")), sep="\n")
        if(!keep) on.exit(unlink(colfile), add = TRUE)
    }
    ## Row / Case labels ###
    if (!is.null(rowlab)) {
	if (!is.vector(rowlab) || !is.character(rowlab))
	    stop("The `rowlab' argument needs to be a character vector")
	if (!missing(rowlab) && length(rowlab) != NROW(x))
	    stop("`rowlab' has wrong length (not matching NROW(x))")
        cat(rowlab, file = (rowfile <- paste(dfile, ".row", sep="")), sep="\n")
        if(!keep) on.exit(unlink(rowfile), add = TRUE)
    }
    ## Variable groups ##
    if (!is.null(vgroups)) {
	   if (!is.vector(vgroups) || !is.numeric(vgroups))
	       stop("The `vgroups' argument needs to be a numeric vector")
	   cat(vgroups, file=(vgfile <- paste(dfile,".vgroups",sep="")), sep="\n")
           if(!keep) on.exit(unlink(vgfile), add = TRUE)
    }
    ## Colors ##
    if (!is.null(colors)) {
	if (!is.vector(colors) || !is.character(colors))
	    stop("The `colors' argument needs to be a character vector")
	cat(colors, file = (clrfile <- paste(dfile,".colors",sep="")), sep="\n")
        if(!keep) on.exit(unlink(clrfile), add = TRUE)
    }
    ## Glyphs ##
    if (!is.null(glyphs)) {
	if (!is.vector(glyphs) || !is.numeric(glyphs))
	    stop("The `glyphs' argument needs to be a numeric vector")
	glyphfile <- paste(dfile, ".glyphs", sep = "")
	cat(glyphs, file = glyphfile, sep = "\n")
        if(!keep) on.exit(unlink(glyphfile), add = TRUE)
    }
    ## Erase ##
    if (!is.null(erase)) {
	if (!is.vector(erase) || !is.numeric(erase))
	    stop("The `erase' argument needs to be a numeric vector")
	erasefile <- paste(dfile, ".erase", sep = "")
	cat(erase, file = erasefile, sep = "\n")
        if(!keep) on.exit(unlink(erasefile), add = TRUE)
    }
    ## Connected lines ##
    if (!is.null(lines)) {
	if (!is.matrix(lines) || !is.numeric(lines) || dim(lines)[2] != 2)
	    stop("The `lines' argument must be a numeric 2-column matrix")
	linesfile <- paste(dfile, ".lines", sep = "")
	unlink(linesfile)# in case it existed
	if (nrow(lines) > 0) {
	    for (i in 1:nrow(lines))
		cat(lines[i, ], "\n", file = linesfile, append = TRUE)
	}
        if(!keep) on.exit(unlink(linesfile), add = TRUE)

	## Line colors ##
	if (!is.null(linecolors)) {
	    if (!is.vector(linecolors) || !is.character(linecolors))
		stop("The `linecolors' argument must be a character vector")
	    linecolorfile <- paste(dfile, ".linecolors", sep = "")
	    cat(linecolors, file = linecolorfile, sep = "\n")

            if(!keep) on.exit(unlink(linecolorfile), add = TRUE)
	}
    }
    ## Resources ##
    if (!is.null(resources)) {
	if (!is.vector(resources) || !is.character(resources))
	    stop("The `resources' argument must be a character vector")
	resourcefile <- paste(dfile, ".resources", sep = "")
	cat(resources, file = resourcefile, sep = "\n")
        if(!keep) on.exit(unlink(resourcefile), add = TRUE)
    }
    ## nlinkable ##
    if (!is.null(nlinkable)) {
	nlinkable <- as.integer(nlinkable)
	if (length(nlinkable) > 1)
	    stop("The `nlinkable' argument must be a scalar integer")
	linkablefile <- paste(dfile, ".nlinkable", sep = "")
	cat(nlinkable, "\n", file = linkablefile)
        if(!keep) on.exit(unlink(linkablefile), add = TRUE)
    }
    ## subset ##
    subsetarg <- ""
    if (!is.null(subset)) {
	subset <- as.integer(subset)
	if (length(subset) > 1)
	    stop("The `subset' argument must be a scalar integer")
	if (subset == 0 || subset > nrow(x))
	    stop("The `subset' argument must be >0 and <= nrows")
	subsetarg <- paste(" -subset ", subset, sep = "")
	args <- paste(args, subsetarg, sep = " ")
    }

    if (!is.null(display)) {
	if (!is.character(display))
	    warning("display must be a character string")
	else args <- paste("-display", display, args)
    }
    args <- paste("-title", paste("'", title, "'", sep = ""), args)

### Note to installer:
### Here you will need to specify the path to the xgobi executable
### on your system (here we assume it *is* in the user's PATH :)

    command <- paste("xgobi", args, dfile, "&")

    cat(command, "\n")
    s <- system(command, FALSE)

    ## Now wait a bit before unlinking all the files via  on.exit(.) :
    if(!keep) Sys.sleep(3)
    invisible(s)
}
xgvis <-
function(dmat	= NULL,
	 edges	= NULL,
	 pos	= NULL,
	 rowlab = dimnames(dmat)[[1]],
	 colors = NULL,
	 glyphs = NULL,
	 erase	= NULL,
	 lines	= NULL,
	 linecolors = NULL,
	 resources  = NULL,
	 display    = NULL,
	 keep	= FALSE,
	 fprefix= "xgvis-")
{
  if (is.null(edges) && is.null(pos) && is.null(dmat))
    stop("One of dmat, edges, or pos must be present")

  basefile <- tempfile(fprefix)

  ## distance matrix ###
  if (!is.null(dmat)) {
    dmat <- eval(dmat)
    if (any(isinf <- is.infinite(dmat[!is.na(dmat)]))) {
	warning("xgvis can't handle Inf's in dmat; replaced with NA")
	dmat[isinf] <- NA
    }
    dfile <- paste(basefile, ".dist", sep="")
    write(t(dmat), file = dfile, ncolumns = ncol(dmat))
    if(!keep) on.exit(unlink(dfile), add=TRUE)
  }

  ## Edges ###
  if (!is.null(edges)) { # check data type
    if (!is.matrix(edges) || !is.numeric(edges) || dim(edges)[2] != 2)
      stop("The `edges' argument must be a numeric 2-column matrix")

    edgesfile <- paste(basefile, ".edges", sep="")
    if (nrow(edges) > 0) {
	write(t(edges), file = edgesfile, ncol=2)
    }
    if(!keep) on.exit(unlink(edgesfile), add=TRUE)
  }

  ## position matrix ###
  if (!is.null(pos)) {
    pos <- eval(pos)
    if (any(isinf <- is.infinite(pos[!is.na(pos)]))) {
	warning("xgvis can't handle Inf's in pos; replaced with NA")
	pos[isinf] <- NA
    }
    pfile <- paste(basefile, ".pos", sep="")
    write(t(pos), file = pfile, ncolumns = ncol(pos))
    if(!keep) on.exit(unlink(pfile), add = TRUE)
  }

  ## Row / Case labels ###
  if (!is.null(rowlab)) {
      if (!is.vector(rowlab) || !is.character(rowlab))# check data type
	  stop("The `rowlab' argument needs to be a character vector")
      if (!missing(rowlab) && length(rowlab) != NROW(dmat))
	  stop("`rowlab' has wrong length (not matching NROW(dmat))")
      cat(rowlab, file = (rowfile <- paste(basefile, ".row", sep="")), sep="\n")
      if(!keep) on.exit(unlink(rowfile), add = TRUE)
  }

  ## Colors ###
  if (!is.null(colors)) {
    # check data type
    if (!is.vector(colors) || !is.character(colors))
      stop("The `colors' argument needs to be a character vector")

    colorfile <- paste(basefile, ".colors", sep="")
    write(colors, file = colorfile, ncol=1)
    if(!keep) on.exit(unlink(colorfile), add = TRUE)
  }

  ## Glyphs ###
  if (!is.null(glyphs)) {
    # check data type
    if (!is.vector(glyphs) || !is.numeric(glyphs))
      stop("The `glyphs' argument needs to be a numeric vector")

    glyphfile <- paste(basefile, ".glyphs", sep="")
    write(glyphs, file = glyphfile, ncol=1)
    if(!keep) on.exit(unlink(glyphfile), add = TRUE)
  }

  ## Erase ###
  if (!is.null(erase)) {
    # check data type
    if (!is.vector(erase) || !is.numeric(erase))
      stop("The `erase' argument needs to be a numeric vector")

    erasefile <- paste(basefile, ".erase", sep="")
    write(erase, file = erasefile, ncol=1)
    if(!keep) on.exit(unlink(erasefile), add = TRUE)
  }

  ## Connected lines ###
  if (!is.null(lines)) {
    # check data type
    if (!is.matrix(lines) || !is.numeric(lines) || dim(lines)[2] != 2)
      stop("The `lines' argument must be a numeric 2-column matrix")

    linesfile <- paste(basefile, ".lines", sep="")
    if (nrow(lines) > 0) {
      write(t(lines), file = linesfile, ncol=2)
      if(!keep) on.exit(unlink(linesfile), add = TRUE)
    }
  }

  ## Line colors ###
  if ((!is.null(lines) || !is.null(edges)) && !is.null(linecolors)) {
    # check data type
    if (!is.vector(linecolors) || !is.character(linecolors))
      stop("The `linecolors' argument must be a character vector")

    linecolorfile <- paste(basefile, ".linecolors", sep="")
    write(linecolors, file = linecolorfile, ncol=1)
    if(!keep) on.exit(unlink(linecolorfile), add = TRUE)
  }

  ## Resources ###
  if (!is.null(resources)) {
    # check data type
    if (!is.vector(resources) || !is.character(resources))
      stop("The `resources' argument must be a character vector")

    resourcefile <- paste(basefile, ".resources", sep="")
    write(resources, file = resourcefile, ncol=1)
    if(!keep) on.exit(unlink(resourcefile), add = TRUE)
  }

### Note to installer:
### Here you need to specify the path to the xgvis executable / batch file
### on your system.

  command <- paste("xgvis",  basefile, "&")
  cat(command, "\n")
  ## dos:
  ## invisible(dos(command, multi= F, minimized=T, output.to.S=F, translate=T))
  s <- system(command, FALSE)

  ## Now wait a bit before unlinking all the files via on.exit(.) :
  if(!keep) Sys.sleep(3)
  invisible(s)
}

