Nothing
R/imagemap.R
In imagemap: Create html imagemaps
#######################################
#######################################
# 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 #
#######################################
# public
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
}
# public?
print.imagemap <- function(x,...){
cat("Its an imagemap!: ",x$title,"\n")
}
# public
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='')
}
# private
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)
}
# public
createIM <- function(im,file='',imgTags=list()){
cat(buildIM(im,imgTags),sep='\n',file=file)
}
# public
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=FALSE,add=TRUE,...)
}
lines.imRect <- function(x,...){
rect(x$xleft,x$ybottom,x$xright,x$ytop,...)
}
# public
"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='') )
}
# private
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..
# public
imPoint <- function(x,y,w,h,...){
## really a rectangle
imRect(x-(w/2),y+(h/2),x+(w/2),y-(h/2),...)
}
# public
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
}
# public
imCircle <- function(xc,yc,r,...){
res <- list(type="circle",xc=xc,yc=yc,r=r,extra=list(...))
class(res) <- c("imRegion","imCircle")
res
}
# public
imPoly <- function(xy,...){
res <- list(type="poly",xy=xy,extra=list(...))
class(res) <- c("imRegion","imPoly")
res
}
# public
imDefault <- function(...){
res <- list(type="default",extra=list(...))
class(res) <- c("imRegion","imDefault")
res
}
# public
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
#########################
#private
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)
)
}
# private
usr2plt <- function(xy,dev=dev.cur()){
olddev <- dev.cur()
dev.set(dev)
usr <- par("usr")
dev.set(olddev)
xytrans(xy,usr)
}
# private
plt2fig <- function(xy,dev=dev.cur()){
olddev <- dev.cur()
dev.set(dev)
plt <- par("plt")
dev.set(olddev)
xytrans2(xy,plt)
}
# private
fig2dev <- function(xy,dev=dev.cur()){
olddev <- dev.cur()
dev.set(dev)
fig <- par("fig")
dev.set(olddev)
xytrans2(xy,fig)
}
# private
usr2dev <- function(xy,dev=dev.cur()){
fig2dev(plt2fig(usr2plt(xy,dev),dev),dev)
}
# private
xytrans2 <- function(xy,par){
cbind(par[1]+((par[2]-par[1])*xy[,1]),
par[3]+((par[4]-par[3])*xy[,2]))
}
# private
xytrans <- function(xy,par){
cbind((xy[,1]-par[1])/(par[2]-par[1]),
(xy[,2]-par[3])/(par[4]-par[3]))
}
Try the imagemap package in your browser
Any scripts or data that you put into this service are public.
imagemap documentation built on May 2, 2019, 4:27 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.
#######################################
#######################################
# 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 #
#######################################
# public
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
}
# public?
print.imagemap <- function(x,...){
cat("Its an imagemap!: ",x$title,"\n")
}
# public
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='')
}
# private
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)
}
# public
createIM <- function(im,file='',imgTags=list()){
cat(buildIM(im,imgTags),sep='\n',file=file)
}
# public
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=FALSE,add=TRUE,...)
}
lines.imRect <- function(x,...){
rect(x$xleft,x$ybottom,x$xright,x$ytop,...)
}
# public
"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='') )
}
# private
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..
# public
imPoint <- function(x,y,w,h,...){
## really a rectangle
imRect(x-(w/2),y+(h/2),x+(w/2),y-(h/2),...)
}
# public
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
}
# public
imCircle <- function(xc,yc,r,...){
res <- list(type="circle",xc=xc,yc=yc,r=r,extra=list(...))
class(res) <- c("imRegion","imCircle")
res
}
# public
imPoly <- function(xy,...){
res <- list(type="poly",xy=xy,extra=list(...))
class(res) <- c("imRegion","imPoly")
res
}
# public
imDefault <- function(...){
res <- list(type="default",extra=list(...))
class(res) <- c("imRegion","imDefault")
res
}
# public
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
#########################
#private
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)
)
}
# private
usr2plt <- function(xy,dev=dev.cur()){
olddev <- dev.cur()
dev.set(dev)
usr <- par("usr")
dev.set(olddev)
xytrans(xy,usr)
}
# private
plt2fig <- function(xy,dev=dev.cur()){
olddev <- dev.cur()
dev.set(dev)
plt <- par("plt")
dev.set(olddev)
xytrans2(xy,plt)
}
# private
fig2dev <- function(xy,dev=dev.cur()){
olddev <- dev.cur()
dev.set(dev)
fig <- par("fig")
dev.set(olddev)
xytrans2(xy,fig)
}
# private
usr2dev <- function(xy,dev=dev.cur()){
fig2dev(plt2fig(usr2plt(xy,dev),dev),dev)
}
# private
xytrans2 <- function(xy,par){
cbind(par[1]+((par[2]-par[1])*xy[,1]),
par[3]+((par[4]-par[3])*xy[,2]))
}
# private
xytrans <- function(xy,par){
cbind((xy[,1]-par[1])/(par[2]-par[1]),
(xy[,2]-par[3])/(par[4]-par[3]))
}
Try the imagemap 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.