Nothing
R/imagemap.R
In ADaCGH2: Analysis of big data from aCGH experiments using parallel computing and ff objects
Defines functions
xytrans
xytrans2
usr2dev
fig2dev
plt2fig
usr2plt
usr2png
imText
imDefault
imPoly
imCircle
imRect
imPoint
moHTML
toHTML.imDefault
toHTML.imText
toHTML.imRect
toHTML.imCircle
toHTML.imPoly
toHTML.imagemap
toHTML.default
toHTML
lines.imRect
lines.imCircle
lines.imPoly
lines.imDefault
lines.imagemap
imClose
createIM
buildIM
createPage
print.imagemap
imagemap
#######################################
#######################################
# Produce HTML imagemap code from R #
#######################################
# B.Rowlingson@lancaster.ac.uk #
#######################################
# Inspired by an email from Landon #
# Jensen <lsjensen@micron.com> on the #
# R-help mailing list Dec 2002 #
# Probably none of that code here now #
#######################################
imagemap <- function(filename,width=480,height=480,title='Imagemap from R'){
png(paste(filename,".png",sep=''),width=width,height=height)
im <- list()
im$Device <- dev.cur()
im$Filename=filename
im$Height=height
im$Width=width
im$Objects <- list()
im$HTML <- list()
im$title <- title
class(im) <- "imagemap"
im
}
print.imagemap <- function(x,...){
cat("Its an imagemap!: ",x$title,"\n")
}
createPage <- function(im,file='',imgTags=list()){
out <- paste("<html><head><title>",im$title,"</title></head>\n",sep='')
out <- c(out,"<body>\n")
out <- c(out,buildIM(im,imgTags))
out <- c(out,"</body></html>\n")
cat(out,file=file,sep='')
}
buildIM <- function(im,imgTags=list()){
out <- paste("<img src=\"",paste(im$Filename,".png",sep=''),"\" usemap=\"#",im$Filename,"\" ",moHTML(imgTags)," ISMAP>\n",sep='')
out <- c(out,paste("<map name=\"",im$Filename,"\">\n",sep=''))
for(region in im$HTML){
out <- c(out,toHTML(region,im))
}
out <- c(out,"</map>\n")
return(out)
}
createIM <- function(im,file='',imgTags=list()){
cat(buildIM(im,imgTags),sep='\n',file=file)
}
imClose <- function(im){
cat(paste("Closing PNG file ",paste(im$Filename,".png",sep=''),"\n",sep=''))
dev.off(im$Device)
}
lines.imagemap <- function(x,...){
### draw the imagemap objects on the current plot
### uses the original stored coordinates
###
lapply(x$Objects,lines,...)
invisible(0)
}
lines.imDefault <- function(x,...){
cat("Default defined\n")
}
lines.imPoly <- function(x,...){
lines(rbind(x$xy,x$xy[1,]),...)
}
lines.imCircle <- function(x,...){
symbols(x$xc,x$yc,circles=x$r,inches=F,add=T,...)
}
lines.imRect <- function(x,...){
rect(x$xleft,x$ybottom,x$xright,x$ytop,...)
}
"addRegion<-" <- function(im,value){
im$HTML[[length(im$HTML)+1]] <- toHTML(value,im)
im$Objects[[length(im$Objects)+1]] <- value
return(im)
}
toHTML <- function(ob,im){
UseMethod("toHTML")
}
toHTML.default <- function(ob,im){
ob
}
toHTML.imagemap <- function(ob,im){
out <- paste("<img src=\"",paste(ob$Filename,".png",sep=''),"\" usemap=\"#",ob$Filename,"\" ISMAP\n>",sep='')
out <- c(out,paste("<map name=\"",ob$Filename,"\">\n",sep=''))
for(region in ob$HTML){
out <- c(out,toHTML(region,ob))
}
out <- c(out,"</map>\n")
out
}
toHTML.imPoly <- function(ob,im){
xyt <- usr2png(ob$xy,im)
coords <- paste(t(xyt),sep='',collapse=',')
line <- paste("<area shape=\"poly\" coords=\"",coords,"\" ",sep='')
line <- paste(line, moHTML(ob$extra), " >\n",sep='')
line
}
toHTML.imCircle <- function(ob,im){
xyrc <- usr2png(cbind(c(ob$xc,ob$r,0),c(ob$yc,0,0)),im)
r <- abs(xyrc[2,1]-xyrc[3,1])
coords <- paste(paste(xyrc[1,1],xyrc[1,2],sep=','),r,sep=',')
line <- paste("<area shape=\"circle\" coords=\"",coords,"\" ",sep='')
line <- paste(line, moHTML(ob$extra), " >\n",sep='')
line
}
toHTML.imRect <- function(ob,im){
xycorns <- usr2png(rbind(c(ob$xleft,ob$ytop),c(ob$xright,ob$ybottom)),im)
coords <- paste(xycorns[1,1],xycorns[2,2],xycorns[2,1],xycorns[1,2],sep=",")
line <- paste("<area shape=\"rect\" coords=\"",coords,"\" ",sep='')
line <- paste(line, moHTML(ob$extra), " >\n",sep='')
line
}
toHTML.imText <- function(ob,im){
## compute coords of unrotated bbox of text in usr space
xl <- ob$x-ob$width*ob$adj[1]
xr <- xl+ob$width
yb <- ob$y-ob$height*ob$adj[2]
yt <- yb+ob$height
## compute coords of unrotated box and rotation point
## in fractional pixel space
xy <- usr2dev(cbind(c(ob$x,xl,xr,xr,xl),c(ob$y,yb,yb,yt,yt)),im$Device)
xy[,1] <- xy[,1]*im$Width
xy[,2] <- xy[,2]*im$Height
## rotate corners
corners <- rbind(xy[2:5,1]-xy[1,1],xy[2:5,2]-xy[1,2])
rot <- pi*(-ob$srt)/180
rmat <- rbind(c(cos(rot),sin(rot)),c(-sin(rot),cos(rot)))
rotted <- rmat %*% corners
## convert to integer pixel coords wrt top left:
xyt <- cbind(rotted[1,]+xy[1,1],(im$Height-(rotted[2,]+xy[1,2])))
xyt <- ceiling(xyt)
## make a POLY object:
coords <- paste(t(xyt),sep='',collapse=',')
line <- paste("<area shape=\"poly\" coords=\"",coords,"\" ",sep='')
line <- paste(line, moHTML(ob$extra), " >\n",sep='')
line
}
toHTML.imDefault <- function(ob,im){
return( paste("<area shape=\"default\" ",moHTML(ob$extra)," >\n",sep='') )
}
moHTML <- function(alist){
tagline <- ""
if(length(alist)==0){return("")}
for(itag in 1:length(alist)){
value <- alist[[itag]]
name <- names(alist)[itag]
ctag <- paste(name,"=\"",value,"\" ",sep='')
tagline <- paste(tagline,ctag,sep='')
}
tagline
}
####### functions to define different region types.
#### should validate their args..
imPoint <- function(x,y,w,h,...){
## really a rectangle
imRect(x-(w/2),y+(h/2),x+(w/2),y-(h/2),...)
}
imRect <- function(xleft,ytop,xright,ybottom,...){
res <- list(type="rect",xleft=xleft,ytop=ytop,xright=xright,ybottom=ybottom,
extra=list(...))
class(res) <- c("imRegion","imRect")
res
}
imCircle <- function(xc,yc,r,...){
res <- list(type="circle",xc=xc,yc=yc,r=r,extra=list(...))
class(res) <- c("imRegion","imCircle")
res
}
imPoly <- function(xy,...){
res <- list(type="poly",xy=xy,extra=list(...))
class(res) <- c("imRegion","imPoly")
res
}
imDefault <- function(...){
res <- list(type="default",extra=list(...))
class(res) <- c("imRegion","imDefault")
res
}
imText <- function(x,y,string,pars=par(),...){
## get adj from pars or par()
if(!is.null(pars$adj)){
adj <- pars$adj
}else{
adj <- par("adj")
}
if(length(adj)==1){adj <- c(adj,.5)}
## adj is now length 2
## get srt from pars or par()
if(!is.null(pars$srt)){
srt <- pars$srt
}else{
srt <- par("srt")
}
res <- list(x=x,y=y,
width=strwidth(string),height=strheight(string),
string=string, adj=adj,srt=srt,
extra=list(...)
)
class(res) <- c("imRegion","imText")
res
}
#########################
####### functions for transformations between various coord systems
#########################
usr2png <- function(xy,im){
### convert usr coords (as used in current plot) to pixels in a png
### with width/height stored in im
xy <- usr2dev(xy,dev.cur())
cbind(
ceiling(xy[,1]*im$Width),
ceiling((1-xy[,2])*im$Height)
)
}
usr2plt <- function(xy,dev=dev.cur()){
olddev <- dev.cur()
dev.set(dev)
usr <- par("usr")
dev.set(olddev)
xytrans(xy,usr)
}
plt2fig <- function(xy,dev=dev.cur()){
olddev <- dev.cur()
dev.set(dev)
plt <- par("plt")
dev.set(olddev)
xytrans2(xy,plt)
}
fig2dev <- function(xy,dev=dev.cur()){
olddev <- dev.cur()
dev.set(dev)
fig <- par("fig")
dev.set(olddev)
xytrans2(xy,fig)
}
usr2dev <- function(xy,dev=dev.cur()){
fig2dev(plt2fig(usr2plt(xy,dev),dev),dev)
}
xytrans2 <- function(xy,par){
cbind(par[1]+((par[2]-par[1])*xy[,1]),
par[3]+((par[4]-par[3])*xy[,2]))
}
xytrans <- function(xy,par){
cbind((xy[,1]-par[1])/(par[2]-par[1]),
(xy[,2]-par[3])/(par[4]-par[3]))
}
Try the ADaCGH2 package in your browser
Any scripts or data that you put into this service are public.
ADaCGH2 documentation built on Nov. 8, 2020, 4:57 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions xytrans xytrans2 usr2dev fig2dev plt2fig usr2plt usr2png imText imDefault imPoly imCircle imRect imPoint moHTML toHTML.imDefault toHTML.imText toHTML.imRect toHTML.imCircle toHTML.imPoly toHTML.imagemap toHTML.default toHTML lines.imRect lines.imCircle lines.imPoly lines.imDefault lines.imagemap imClose createIM buildIM createPage print.imagemap imagemap
#######################################
#######################################
# Produce HTML imagemap code from R #
#######################################
# B.Rowlingson@lancaster.ac.uk #
#######################################
# Inspired by an email from Landon #
# Jensen <lsjensen@micron.com> on the #
# R-help mailing list Dec 2002 #
# Probably none of that code here now #
#######################################
imagemap <- function(filename,width=480,height=480,title='Imagemap from R'){
png(paste(filename,".png",sep=''),width=width,height=height)
im <- list()
im$Device <- dev.cur()
im$Filename=filename
im$Height=height
im$Width=width
im$Objects <- list()
im$HTML <- list()
im$title <- title
class(im) <- "imagemap"
im
}
print.imagemap <- function(x,...){
cat("Its an imagemap!: ",x$title,"\n")
}
createPage <- function(im,file='',imgTags=list()){
out <- paste("<html><head><title>",im$title,"</title></head>\n",sep='')
out <- c(out,"<body>\n")
out <- c(out,buildIM(im,imgTags))
out <- c(out,"</body></html>\n")
cat(out,file=file,sep='')
}
buildIM <- function(im,imgTags=list()){
out <- paste("<img src=\"",paste(im$Filename,".png",sep=''),"\" usemap=\"#",im$Filename,"\" ",moHTML(imgTags)," ISMAP>\n",sep='')
out <- c(out,paste("<map name=\"",im$Filename,"\">\n",sep=''))
for(region in im$HTML){
out <- c(out,toHTML(region,im))
}
out <- c(out,"</map>\n")
return(out)
}
createIM <- function(im,file='',imgTags=list()){
cat(buildIM(im,imgTags),sep='\n',file=file)
}
imClose <- function(im){
cat(paste("Closing PNG file ",paste(im$Filename,".png",sep=''),"\n",sep=''))
dev.off(im$Device)
}
lines.imagemap <- function(x,...){
### draw the imagemap objects on the current plot
### uses the original stored coordinates
###
lapply(x$Objects,lines,...)
invisible(0)
}
lines.imDefault <- function(x,...){
cat("Default defined\n")
}
lines.imPoly <- function(x,...){
lines(rbind(x$xy,x$xy[1,]),...)
}
lines.imCircle <- function(x,...){
symbols(x$xc,x$yc,circles=x$r,inches=F,add=T,...)
}
lines.imRect <- function(x,...){
rect(x$xleft,x$ybottom,x$xright,x$ytop,...)
}
"addRegion<-" <- function(im,value){
im$HTML[[length(im$HTML)+1]] <- toHTML(value,im)
im$Objects[[length(im$Objects)+1]] <- value
return(im)
}
toHTML <- function(ob,im){
UseMethod("toHTML")
}
toHTML.default <- function(ob,im){
ob
}
toHTML.imagemap <- function(ob,im){
out <- paste("<img src=\"",paste(ob$Filename,".png",sep=''),"\" usemap=\"#",ob$Filename,"\" ISMAP\n>",sep='')
out <- c(out,paste("<map name=\"",ob$Filename,"\">\n",sep=''))
for(region in ob$HTML){
out <- c(out,toHTML(region,ob))
}
out <- c(out,"</map>\n")
out
}
toHTML.imPoly <- function(ob,im){
xyt <- usr2png(ob$xy,im)
coords <- paste(t(xyt),sep='',collapse=',')
line <- paste("<area shape=\"poly\" coords=\"",coords,"\" ",sep='')
line <- paste(line, moHTML(ob$extra), " >\n",sep='')
line
}
toHTML.imCircle <- function(ob,im){
xyrc <- usr2png(cbind(c(ob$xc,ob$r,0),c(ob$yc,0,0)),im)
r <- abs(xyrc[2,1]-xyrc[3,1])
coords <- paste(paste(xyrc[1,1],xyrc[1,2],sep=','),r,sep=',')
line <- paste("<area shape=\"circle\" coords=\"",coords,"\" ",sep='')
line <- paste(line, moHTML(ob$extra), " >\n",sep='')
line
}
toHTML.imRect <- function(ob,im){
xycorns <- usr2png(rbind(c(ob$xleft,ob$ytop),c(ob$xright,ob$ybottom)),im)
coords <- paste(xycorns[1,1],xycorns[2,2],xycorns[2,1],xycorns[1,2],sep=",")
line <- paste("<area shape=\"rect\" coords=\"",coords,"\" ",sep='')
line <- paste(line, moHTML(ob$extra), " >\n",sep='')
line
}
toHTML.imText <- function(ob,im){
## compute coords of unrotated bbox of text in usr space
xl <- ob$x-ob$width*ob$adj[1]
xr <- xl+ob$width
yb <- ob$y-ob$height*ob$adj[2]
yt <- yb+ob$height
## compute coords of unrotated box and rotation point
## in fractional pixel space
xy <- usr2dev(cbind(c(ob$x,xl,xr,xr,xl),c(ob$y,yb,yb,yt,yt)),im$Device)
xy[,1] <- xy[,1]*im$Width
xy[,2] <- xy[,2]*im$Height
## rotate corners
corners <- rbind(xy[2:5,1]-xy[1,1],xy[2:5,2]-xy[1,2])
rot <- pi*(-ob$srt)/180
rmat <- rbind(c(cos(rot),sin(rot)),c(-sin(rot),cos(rot)))
rotted <- rmat %*% corners
## convert to integer pixel coords wrt top left:
xyt <- cbind(rotted[1,]+xy[1,1],(im$Height-(rotted[2,]+xy[1,2])))
xyt <- ceiling(xyt)
## make a POLY object:
coords <- paste(t(xyt),sep='',collapse=',')
line <- paste("<area shape=\"poly\" coords=\"",coords,"\" ",sep='')
line <- paste(line, moHTML(ob$extra), " >\n",sep='')
line
}
toHTML.imDefault <- function(ob,im){
return( paste("<area shape=\"default\" ",moHTML(ob$extra)," >\n",sep='') )
}
moHTML <- function(alist){
tagline <- ""
if(length(alist)==0){return("")}
for(itag in 1:length(alist)){
value <- alist[[itag]]
name <- names(alist)[itag]
ctag <- paste(name,"=\"",value,"\" ",sep='')
tagline <- paste(tagline,ctag,sep='')
}
tagline
}
####### functions to define different region types.
#### should validate their args..
imPoint <- function(x,y,w,h,...){
## really a rectangle
imRect(x-(w/2),y+(h/2),x+(w/2),y-(h/2),...)
}
imRect <- function(xleft,ytop,xright,ybottom,...){
res <- list(type="rect",xleft=xleft,ytop=ytop,xright=xright,ybottom=ybottom,
extra=list(...))
class(res) <- c("imRegion","imRect")
res
}
imCircle <- function(xc,yc,r,...){
res <- list(type="circle",xc=xc,yc=yc,r=r,extra=list(...))
class(res) <- c("imRegion","imCircle")
res
}
imPoly <- function(xy,...){
res <- list(type="poly",xy=xy,extra=list(...))
class(res) <- c("imRegion","imPoly")
res
}
imDefault <- function(...){
res <- list(type="default",extra=list(...))
class(res) <- c("imRegion","imDefault")
res
}
imText <- function(x,y,string,pars=par(),...){
## get adj from pars or par()
if(!is.null(pars$adj)){
adj <- pars$adj
}else{
adj <- par("adj")
}
if(length(adj)==1){adj <- c(adj,.5)}
## adj is now length 2
## get srt from pars or par()
if(!is.null(pars$srt)){
srt <- pars$srt
}else{
srt <- par("srt")
}
res <- list(x=x,y=y,
width=strwidth(string),height=strheight(string),
string=string, adj=adj,srt=srt,
extra=list(...)
)
class(res) <- c("imRegion","imText")
res
}
#########################
####### functions for transformations between various coord systems
#########################
usr2png <- function(xy,im){
### convert usr coords (as used in current plot) to pixels in a png
### with width/height stored in im
xy <- usr2dev(xy,dev.cur())
cbind(
ceiling(xy[,1]*im$Width),
ceiling((1-xy[,2])*im$Height)
)
}
usr2plt <- function(xy,dev=dev.cur()){
olddev <- dev.cur()
dev.set(dev)
usr <- par("usr")
dev.set(olddev)
xytrans(xy,usr)
}
plt2fig <- function(xy,dev=dev.cur()){
olddev <- dev.cur()
dev.set(dev)
plt <- par("plt")
dev.set(olddev)
xytrans2(xy,plt)
}
fig2dev <- function(xy,dev=dev.cur()){
olddev <- dev.cur()
dev.set(dev)
fig <- par("fig")
dev.set(olddev)
xytrans2(xy,fig)
}
usr2dev <- function(xy,dev=dev.cur()){
fig2dev(plt2fig(usr2plt(xy,dev),dev),dev)
}
xytrans2 <- function(xy,par){
cbind(par[1]+((par[2]-par[1])*xy[,1]),
par[3]+((par[4]-par[3])*xy[,2]))
}
xytrans <- function(xy,par){
cbind((xy[,1]-par[1])/(par[2]-par[1]),
(xy[,2]-par[3])/(par[4]-par[3]))
}
Try the ADaCGH2 package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.