SCM

SCM Repository

[directlabels] Annotation of /tex/2012-semin-r/iris-images.R
ViewVC logotype

Annotation of /tex/2012-semin-r/iris-images.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 583 - (view) (download)

1 : tdhock 583 if(!require(EBImage)){
2 :     source("http://bioconductor.org/biocLite.R")
3 :     biocLite("EBImage")
4 :     library(EBImage)
5 :     }
6 :     levels(iris$Species)
7 :     iris.urls <- c(setosa="http://upload.wikimedia.org/wikipedia/commons/5/56/Kosaciec_szczecinkowaty_Iris_setosa.jpg",
8 :     virginica="http://upload.wikimedia.org/wikipedia/commons/9/9f/Iris_virginica.jpg",
9 :     versicolor="http://upload.wikimedia.org/wikipedia/commons/4/41/Iris_versicolor_3.jpg")
10 :     iris.photos <- list()
11 :     for(i in seq_along(iris.urls)){
12 :     species <- names(iris.urls)[i]
13 :     f <- sprintf("%s.jpg",species)
14 :     if(!file.exists(f))download.file(iris.urls[i],f)
15 :     iris.photos[[species]] <- readImage(f)
16 :     }
17 :     ##grid.raster(pics[[3]])
18 :     library(ggplot2)
19 :     ### Process data points using the Positioning Method and draw the
20 :     ### resulting direct labels. This is called for every panel with
21 :     ### direct labels, every time the plot window is resized.
22 :     drawDetails.imgrob <- function(x,recording){
23 :     ## calculate x and y position in cm --- by this time we should have
24 :     ## done any preprocessing necessary to convert 1d data to 2d data!
25 :     cm.data <- transform(x$data,
26 :     x=convertX(unit(x,"native"),"cm",valueOnly=TRUE),
27 :     y=convertY(unit(y,"native"),"cm",valueOnly=TRUE),
28 :     groups=factor(groups))
29 :     ## save original levels for later in case Positioning Methods mess
30 :     ## them up.
31 :     levs <- unique(cm.data[,c("groups","colour")])
32 :     code <- as.character(cm.data$colour)
33 :     names(code) <- as.character(cm.data$groups)
34 :     ## apply ignore.na function -- these points are not plotted
35 :     cm.data <- ignore.na(cm.data)
36 :     cm.data <- apply.method(x$method,cm.data,
37 :     debug=x$debug,
38 :     axes2native=x$axes2native,
39 :     images=x$images)
40 :     if(nrow(cm.data)==0)return()## empty data frames can cause many bugs
41 :     ## rearrange factors in case Positioning Methods messed up the
42 :     ## order:
43 :     cm.data$col <- code[as.character(cm.data$groups)]
44 :     ## defaults for grid parameter values:
45 :     defaults <- list(hjust=0.5,vjust=0.5,rot=0)
46 :     for(p in names(defaults)){
47 :     if(!p %in% names(cm.data))cm.data[,p] <- NA
48 :     cm.data[is.na(cm.data[,p]),p] <- defaults[[p]]
49 :     }
50 :     cm.data <- unique(cm.data)
51 :     ## Positioning Methods finished, print result!
52 :     if(x$debug)print(cm.data)
53 :     ## Split data into image labels and text labels
54 :     has.image <- cm.data$groups%in%names(x$images)
55 :     text.labels <- cm.data[!has.image,]
56 :     image.labels <- cm.data[has.image,]
57 :     if(nrow(text.labels)){
58 :     gpargs <- c("cex","alpha","fontface","fontfamily","col")
59 :     gp <- do.call(gpar,text.labels[names(text.labels)%in%gpargs])
60 :     with(text.labels,{
61 :     grid.text(groups,x,y,hjust=hjust,vjust=vjust,rot=rot,default.units="cm",
62 :     gp=gp)
63 :     })
64 :     }
65 :     for(i in seq_along(image.labels$groups)){
66 :     irow <- image.labels[i,]
67 :     grid.raster(x$images[[as.character(irow$groups)]],
68 :     vp=with(irow,viewport(x,y,w,h,"cm",just=c(hjust,vjust),angle=rot)))
69 :     }
70 :     }
71 :     library(proto)
72 :     ### needed to add images argument to draw
73 :     GeomImageLabel <- proto(ggplot2:::Geom, {
74 :     draw_groups <- function(., ...) .$draw(...)
75 :     draw <- function(., data, scales, coordinates,
76 :     method=NULL,debug=FALSE,images=list(), ...) {
77 :     if(!is.list(images))stop("images must be a named list of images")
78 :     data$rot <- as.integer(data$angle)
79 :     data$groups <- data$label
80 :     grob(data=subset(coord_transform(coordinates, data, scales),select=-group),
81 :     cl="imgrob",
82 :     method=method,debug=debug,images=images,
83 :     axes2native=function(data){
84 :     coord_transform(coordinates, data, scales)
85 :     })
86 :     }
87 :     draw_legend <- function(.,data,...){
88 :     data <- aesdefaults(data,.$default_aes(),list(...))
89 :     with(data,{
90 :     textGrob("dl",0.5,0.5,rot=angle,
91 :     gp=gpar(col=alpha(colour,alpha),fontsize=size*.pt))
92 :     })
93 :     }
94 :     objname <- "dl"
95 :     desc <- "Image labels"
96 :     default_stat <- function(.) StatIdentity
97 :     required_aes <- c("x", "y", "label")
98 :     default_aes <- function(.)
99 :     aes(colour="black", size=5 , angle=0, hjust=0.5, vjust=0.5, alpha = 1)
100 :     })
101 :    
102 :     ### change so that the height and width of the box is stored
103 :     find.empty.box <- function # just like empty.grid
104 :     ### Label placement method for scatterplots that ensures labels are
105 :     ### placed in different places. A grid is drawn over the whole
106 :     ### plot. Each cluster is considered in sequence and assigned to the
107 :     ### point on this grid which is closest to the point given by
108 :     ### the input data points. Makes use of attr(d,"orig.data").
109 :     (d,
110 :     ### Data frame of target points on the scatterplot for each label.
111 :     debug=FALSE,
112 :     ### Show debugging info on the plot?
113 :     ...
114 :     ### ignored.
115 :     ){
116 :     NREP <- 10
117 :     all.points <- attr(d,"orig.data")[,c("x","y")]
118 :     if(any(table(d$groups)>1))d <- get.means(d)
119 :     label.targets <- d
120 :     ranges <- list(x=convertX(unit(c(0,1),"npc"),"cm",valueOnly=TRUE),
121 :     y=convertY(unit(c(0,1),"npc"),"cm",valueOnly=TRUE))
122 :     gl <- function(v){
123 :     s <- seq(min(all.points[,v]),max(all.points[,v]),l=NREP)
124 :     if(expand){
125 :     dif <- s[2]-s[1]
126 :     s <- seq(min(ranges[[v]])-expand*dif,
127 :     max(ranges[[v]])+expand*dif,
128 :     l=NREP+2*expand)
129 :     }
130 :     list(centers=s,diff=s[2]-s[1])
131 :     }
132 :     hgrid <- function(x,w){
133 :     hboxes <- floor(diff(ranges[[x]])/r[,w])
134 :     (-expand:(hboxes+expand-1))*r[,w]+r[,w]/2+min(ranges[[x]])
135 :     }
136 :     if(debug)with(label.targets,{
137 :     grid.points(x,y,default.units="cm",gp=gpar(col="green"))
138 :     })
139 :     draw <- function(g){
140 :     gridlines <- with(g,list(x=unique(c(left,right)),y=unique(c(top,bottom))))
141 :     drawlines <- function(a,b,c,d)
142 :     grid.segments(a,b,c,d,"cm",gp=gpar(col="grey"))
143 :     with(gridlines,drawlines(min(x),y,max(x),y))
144 :     with(gridlines,drawlines(x,min(y),x,max(y)))
145 :     }
146 :     res <- data.frame()
147 :     label.targets <-
148 :     label.targets[order(nchar(as.character(label.targets$groups))),]
149 :     for(v in label.targets$groups){
150 :     r <- subset(label.targets,groups==v)
151 :     no.points <- data.frame()
152 :     expand <- 0
153 :     while(nrow(no.points)==0){
154 :     boxes <- if("left"%in%names(label.targets)){
155 :     list(x=hgrid("x","w"),y=hgrid("y","h"),w=r$w,h=r$h)
156 :     }else{
157 :     L <- sapply(c("x","y"),gl,simplify=FALSE)
158 :     list(x=L$x$centers,y=L$y$centers,w=L$x$diff,h=L$y$diff)
159 :     }
160 :     boxes <- calc.borders(do.call(expand.grid,boxes))
161 :     boxes <- cbind(boxes,data=inside(boxes,all.points))
162 :     no.points <- transform(subset(boxes,data==0))
163 :     expand <- expand+1 ## look further out if we can't find any labels inside
164 :     }
165 :     if(debug)draw(boxes)
166 :     no.points <- transform(no.points,len=(r$x-x)^2+(r$y-y)^2)
167 :     best <- no.points[which.min(no.points$len),]
168 :     res <- rbind(res,transform(r,
169 :     x=best$x,y=best$y,
170 :     w=best$w,h=best$h,
171 :     hjust=best$hjust,vjust=best$vjust))
172 :     ## add points to cloud
173 :     newpts <- with(best,{
174 :     expand.grid(x=seq(left,right,l=3),
175 :     y=seq(top,bottom,l=3))
176 :     })
177 :     all.points <- rbind(all.points,newpts)
178 :     }
179 :     if(debug)with(all.points,grid.points(x,y,default.units="cm"))
180 :     res
181 :     ### Data frame with columns groups x y, 1 line for each group, giving
182 :     ### the positions on the grid closest to each cluster.
183 :     }
184 :    

R-Forge@R-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business University of Wisconsin - Madison Powered By FusionForge