R/pp.R

In s-u/Acinonyx: iPlots eXtreme

primitives <- function(plot)
  lapply(.Call(A_PlotPrimitives, plot), function(x) { class(x) <- c("primitive", "iObject"); x })

##--- methods

color <- function(x, ...) UseMethod("color")
fill <- function(x, ...) UseMethod("fill")
"color<-" <- function(x, ..., value) UseMethod("color<-")
"fill<-" <- function(x, ..., value) UseMethod("fill<-")
hidden <- function(x, ...) UseMethod("hidden")
"hidden<-" <- function(x, ..., value) UseMethod("hidden<-")
query <- function(x, ...) UseMethod("query")
"query<-" <- function(x, ..., value) UseMethod("query<-")

ilines <- function(x, ...) UseMethod("ilines")
isegments <- function(x, ...) UseMethod("isegments")
iabline <- function(a, ...) UseMethod("iabline")
ipoints <- function(x, ...) UseMethod("ipoints")
itext <- function(x, ...) UseMethod("itext")
ipolygon <- function(x, ...) UseMethod("ipolygon")

##--- primitives constructors ---

iLine <- function(x, y, color) {
  o <- .Call(A_LineCreate, as.double(c(x[1],y[1],x[2],y[2])))
  class(o) <- c("iLine", "primitive", "iObject")
  if (!missing(color)) color(o, redraw=FALSE) <- color
  invisible(o)
}

iSegments <- function(x1, y1, x2, y2, color) {
  l <- c(length(x1), length(y1), length(x2), length(y2))
  if (!all(l == l[1])) stop("all coordinates must be of the same length")
  o <- .Call(A_SegmentsCreate, as.double(x1), as.double(y1), as.double(x2), as.double(y2))
  class(o) <- c("iSegments", "primitive", "iObject")
  if (!missing(color)) color(o, redraw=FALSE) <- color
  invisible(o)  
}

iPolygon <- function(x, y, color, fill) {
  if (length(x) != length(y)) stop("all coordinates must be of the same length")
  o <- .Call(A_PolygonCreate, as.double(x), as.double(y));
  class(o) <- c("iPolygon", "primitive", "iObject")
  if (!missing(color)) color(o, redraw=FALSE) <- color
  if (!missing(fill)) fill(o, redraw=FALSE) <- fill
  invisible(o)
}

iText <- function(x, y, text, color) {
  if (!length(text)) stop("missing text")
  o <- .Call(A_TextCreate, as.double(c(x,y)), as.character(text))
  class(o) <- c("iText", "primitive", "iObject")
  if (!missing(color)) color(o, redraw=FALSE) <- color
  invisible(o)
}

##--- add/delete

add.iPlot.primitive <- function(x, obj, ...) {
  .Call(A_PlotAddPrimitive, x, obj)
  redraw(x) # just to make sure for now
}

add.iPlot.pairlist <- function(x, obj, ...) {
  .Call(A_PlotAddPrimitives, x, obj)
  redraw(x) # just to make sure for now
}

add.primitive.primitive <- function(x, obj, ...)
  CONS(x, CONS(obj))

add.pairlist.primitive <- function(x, obj, ...)
  CONS(obj, x)

delete.iPlot.primitive <- function(x, obj, ...) {
  .Call(A_PlotRemovePrimitive, x, obj)
  redraw(x) # just to make sure for now
}

delete.iPlot.pairlist <- function(x, obj, ...) {
  .Call(A_PlotRemovePrimitives, x, obj)
  redraw(x) # just to make sure for now
}

delete.primitive.primitive <- function(x, obj, ...)
  CONS(x, CONS(obj))

delete.pairlist.primitive <- function(x, obj, ...)
  CONS(obj, x)

delete.iPlot.character <- function(x, obj, ...) {
  if (all(obj == "all")) {
    .Call(A_PlotRemoveAllPrimitives, x)
    redraw(x)
  } else stop("invalid argument")
}


##--- primitive properties

`color<-.primitive` <- function(x, redraw=TRUE, ..., value) {
  value <- col2rgb(value[1], TRUE)[,1] / 255
  .Call(A_VPSetColor, x, as.double(value))
  if (redraw) .Call(A_VPRedraw, x)
  invisible(x)
}

`fill<-.primitive` <- function(x, redraw=TRUE, ..., value) {
  value <- col2rgb(value[1], TRUE)[,1] / 255
  .Call(A_VPSetFill, x, as.double(value))
  if (redraw) .Call(A_VPRedraw, x)
  invisible(x)
}

color.primitive <- function(x, ...) {
  v <- .Call(A_VPGetColor, x)
  rgb(v[1], v[2], v[3], v[4])
}

fill.primitive <- function(x, ...) {
  v <- .Call(A_VPGetFill, x)
  rgb(v[1], v[2], v[3], v[4])
}

hidden.primitive <- function(x, ...)
  .Call(A_VPGetHidden, x)

`hidden<-.primitive` <- function(x, ..., value)
  .Call(A_VPSetHidden, x, as.logical(value))

query.primitive <- function(x, ...)
  .Call(A_VPGetQuery, x)

`query<-.primitive` <- function(x, ..., value)
  .Call(A_VPSetQuery, x, value)

`$.primitive` <- function(x, name) {
  if (name == "plot") return(.po(.Call(A_VPPlot, x)))
  if (name == "color" || name == "col") return(color(x))
  if (name == "fill") return(fill(x))
  if (name == "query") return(query(x))
  if (name == "hidden") return(hidden(x))
  if (name == "context") return(.Call(A_VPGetContext, x))
  if (name == "callback" || name == "onChange") return (.Call(A_VPGetCallback, x))
  vl <- .Call(A_VPGetValue, x)
  vl[[name]]
}

`$<-.primitive` <- function(x, name, value) {
  if (name == "color" || name == "col") color(x) <- value else
  if (name == "fill") fill(x) <- value else
  if (name == "hidden") hidden(x) <- value else
  if (name == "query") query(x) <- value else
  if (name == "callback" || name == "onChange") .Call(A_VPSetCallback, x, value) else
  if (name == "context") .Call(A_VPSetContext, x, value) else
  if (name == "onSelect") .Call(A_VPSetSelCallback, x, value) else
  { vl <- .Call(A_VPGetValue, x)
    vl[[name]] <- value
    .Call(A_VPSetValue, x, vl)
  }
  x
}

iabline.lm <- function(a, ...) {
  mc <- coef(a)
  if (length(mc) != 2) stop("invalid dimensions")
  iabline(mc[1], mc[2], ...)
}

iabline.default <- function(a, b, ..., plot=.Last.plot) {
  x <- plot$xlim
  y <- x * b + a
  l <- iLine(x, y, ...)
  add(plot, l)
  invisible(l)
}

ilines.default <- function(x, y, col, ..., plot=.Last.plot) {
  p <- iPolygon(x, y)
  if (!missing(col)) p$color <- col
  add(plot, p)
  invisible(p)
}

isegments.default <- function(x, y, x1 = x, y1 = y, col, ..., plot=.Last.plot) {
  p <- iSegments(x, y, x1, y1)
  if (!missing(col)) p$color <- col
  add(plot, p)
  invisible(p)
}

ipolygon.default <- function(x, y, border, col = NA, ..., plot=.Last.plot) {
  p <- iPolygon(x, y)
  if (!missing(border)) color(p, redraw=FALSE) <- border
  if (all(!is.na(col))) fill(p, redraw=FALSE) <- col
  add(plot, p)
  invisible(p)
}

# we need to map Ops to other functions, because Ops dispatch attempts to enforce type equality which is stupid (more precisely it doesn't displatch if it finds a function for each type even though it should have ignored the second argument)
`+.iObject` <- function(e1, e2) add(e1, e2)
`-.iObject` <- function(e1, e2) delete(e1, e2)

replacePoints <- function(p, x, y)
  .Call(A_PolygonSetPoints, p, as.double(x), as.double(y))