R/Identify3d.R

Defines functions Identify3d.formula Identify3d

Documented in Identify3d Identify3d.formula

##
## p3d:Identify3d.R
## 2011-12-22
##


Id3d <-
function (labels=row.names(data), pad , ...) {
cat("Move display using left mouse button and middle button or scroll\n")
cat("Press right mouse button and drag a rectangle around points to be identified\n")
cat("Click right mouse button without selecting a point to terminate\n")
    pars <- Plot3d.par()
    data <- pars$data
    nams <- pars$names
    if( !missing( pad )) {
        padstring <- do.call(paste, c(as.list(rep(" ", pad)),sep =""))
        labels <- paste( padstring, labels, sep = "")
    }
    if ( pars$has.groups ) {
        Identify3d(
            data[[nams['x']]],  data[[nams['y']]],data[[nams['z']]],
            groups = data[[nams['g']]],labels=labels,...)
    } else {
        Identify3d(
            data[[nams['x']]],  data[[nams['y']]],data[[nams['z']]],
            labels=labels,...)
    }
}

Identify3d <-
function(x, ... ) {
'
    Use the right mouse button and drag a rectangle to selects points.
    Click and drag empty region to end.
'
    UseMethod("Identify3d")
}

Identify3d.formula <-
function( formula = attr(data, "formula"),
            data = sys.parent()  , labels = NULL , adj = 0,  ...) {
    env <- environment(formula)
    labels <- eval(substitute(labels), data, env)
    if ( is.null(labels)) labels <- rownames(data)
    dd <- model.frame( formula, data )
    if ( ncol(dd) < 3) stop( "Need at least three variables for identify3d")
    Identify3d( dd[[2]], dd[[1]], dd[[3]], labels = labels, adj = adj, ...)
}
Identify3d.default <-
function (
    x = pars$data[[pars$names['x']]],
    y = pars$data[[pars$names['y']]],
    z = pars$data[[pars$names['z']]],
    labels = rownames(Plot3d.par("data")), groups = NULL,
    col = Plot3d.par()$col ,   # c("blue", "green", "orange", "magenta", "cyan", "red", "yellow", "gray"),
    adj = 0, debug = FALSE, pad = 0,
    offset = ((100/length(x))^(1/3)) * 0.02,
	...) {
    pars <- Plot3d.par()
    ## added by GM Nov 9
       if ( ( is.matrix(x) && (ncol(x) > 1) ) || is.data.frame(x) ) {
            dat <- x
            x <- dat[,1]
            y <- dat[,2]
            z <- dat[,3]
            labels <- rownames(dat)
       }
    select3d <-function (...) {
    # adapted from select3d and rgl.selecte3d in the rgl package, but passes
    #  through arguments to rgl.select
        rgl:::.check3d()
        rect <- rgl:::rgl.select(...)
        llx <- rect[1]
        lly <- rect[2]
        urx <- rect[3]
        ury <- rect[4]
        if (llx > urx) {
            temp <- llx
            llx <- urx
            urx <- temp
            }
        if (lly > ury) {
            temp <- lly
            lly <- ury
            ury <- temp
            }
        proj <- rgl:::rgl.projection()
        function(x, y, z) {
            pixel <- rgl.user2window(x, y, z, proj = proj)
            apply(pixel, 1, function(p) (llx <= p[1]) && (p[1] <=
                urx) && (lly <= p[2]) && (p[2] <= ury) && (0 <= p[3]) &&
                (p[3] <= 1))
            }
        }
    valid <- if (is.null(groups)) complete.cases(x, y, z)
    else complete.cases(x, y, z, groups)
    x <- x[valid]
    y <- y[valid]
    z <- z[valid]
    labels <- labels[valid]
    pad <- paste( rep(" ", pad), collapse = "")
    labels.pad <- paste(pad,labels)
    # x <- (x - min(x))/(max(x) - min(x))
    # y <- (y - min(y))/(max(y) - min(y))
    # z <- (z - min(z))/(max(z) - min(z))
    rgl.bringtotop()
    identified <- character(0)
    groups <- if (!is.null(groups)) as.numeric(groups[valid])
    if (debug) disp(groups)
    else rep(1, length(x))
    repeat {
        f <- select3d(button="right")
        if ( debug ) disp(x)
        which <- f(x, y, z)
        if (debug) disp(which)
        if (!any(which)) break
        if (!is.null(groups)) cols <- col[groups][which] else cols <- col[1]
        if (debug) disp( col[groups][which] )
        if (debug) disp( col[groups])
        if (debug) disp( labels.pad[which] )
        if (debug) disp( cols )
        rgl.texts(x[which], y[which] + offset, z[which], labels.pad[which],
            color = cols, adj = adj)
        identified <- c(identified, labels[which])
        }
    identified
}

# rgl.texts(c(1,2),c(1,3),c(1,2),text=c("AAA","BBB"), color=c('blue','red'))

Try the p3d package in your browser

Any scripts or data that you put into this service are public.

p3d documentation built on May 2, 2019, 5:25 p.m.