SCM

SCM Repository

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

Annotation of /tex/2012-semin-r/pointLabel.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 583 - (view) (download)

1 : tdhock 583 # http://en.wikipedia.org/wiki/Automatic_label_placement
2 :     # http://www.szoraster.com/Cartography/PracticalExperience.htm
3 :     # http://www.eecs.harvard.edu/~shieber/Projects/Carto/carto.html
4 :     # http://i11www.iti.uni-karlsruhe.de/map-labeling/bibliography/
5 :    
6 :    
7 :     pointLabel <- function(x, y = NULL, labels = seq(along = x), cex = 1,
8 :     method = c("SANN", "GA"),
9 :     allowSmallOverlap = FALSE,
10 :     trace = FALSE,
11 :     doPlot = TRUE,
12 :     ...)
13 :     {
14 :     if (!missing(y) && (is.character(y) || is.expression(y))) {
15 :     labels <- y
16 :     y <- NULL
17 :     }
18 :     if (is.factor(labels))
19 :     labels <- as.character(labels)
20 :     z = xy.coords(x, y, recycle = TRUE)
21 :     x = z$x
22 :     y = z$y
23 :     if (length(labels) < length(x))
24 :     labels = rep(labels, length(x))
25 :    
26 :     method <- match.arg(method)
27 :    
28 :     boundary = par()$usr
29 :     image_width = boundary[2] - boundary[1]
30 :     image_height = boundary[4] - boundary[3]
31 :     if (allowSmallOverlap) # default to 2% of the image size
32 :     nudgeFactor = .02*(abs(boundary[1] + 1i*boundary[2] - boundary[3] - 1i*boundary[4]))
33 :    
34 :     n_labels = length(x)
35 :    
36 :     # There are eight possible alignment codes, corresponding to the
37 :     # corners and side mid-points of the rectangle
38 :     # Codes are 1:8
39 :     # Code 7 is the most preferred
40 :     xBoundary = image_width * 0.01 # add a small boundary around the rectangle
41 :     yBoundary = image_height * 0.01
42 :     width = strwidth(labels, units = "user", cex = cex) + xBoundary
43 :     height = strheight(labels, units = "user", cex = cex) + yBoundary
44 :     gen_offset <- function(code)
45 :     c(-1, -1, -1, 0, 0, 1, 1, 1)[code] * (width/2) +
46 :     1i * c(-1, 0, 1, -1, 1, -1, 0, 1)[code] * (height/2)
47 :    
48 :    
49 :     # Finds intersection area of two rectangles
50 :     rect_intersect <- function(xy1, offset1, xy2, offset2) {
51 :     w = pmin(Re(xy1+offset1/2), Re(xy2+offset2/2)) - pmax(Re(xy1-offset1/2), Re(xy2-offset2/2))
52 :     h = pmin(Im(xy1+offset1/2), Im(xy2+offset2/2)) - pmax(Im(xy1-offset1/2), Im(xy2-offset2/2))
53 :     w[w <= 0] = 0
54 :     h[h <= 0] = 0
55 :     w*h
56 :     }
57 :    
58 :     nudge <- function(offset) {
59 :     # Nudge the labels slightly if they overlap:
60 :     doesIntersect = rect_intersect(xy[rectidx1] + offset[rectidx1], rectv[rectidx1],
61 :     xy[rectidx2] + offset[rectidx2], rectv[rectidx2]) > 0
62 :    
63 :     pyth = abs(xy[rectidx1] + offset[rectidx1] - xy[rectidx2] - offset[rectidx2]) / nudgeFactor
64 :     eps = 1.0e-10
65 :    
66 :     for (i in which(doesIntersect & pyth > eps)) {
67 :     idx1 = rectidx1[i]
68 :     idx2 = rectidx2[i]
69 :     vect = (xy[idx1] + offset[idx1] - xy[idx2] - offset[idx2]) / pyth[idx1]
70 :     offset[idx1] = offset[idx1] + vect
71 :     offset[idx2] = offset[idx2] - vect
72 :     }
73 :     offset
74 :     }
75 :    
76 :     objective <- function(gene) {
77 :     offset = gen_offset(gene)
78 :    
79 :     # Allow for "bending" the labels a bit
80 :     if (allowSmallOverlap) offset = nudge(offset)
81 :    
82 :     if (!is.null(rectidx1))
83 :     area = sum(rect_intersect(xy[rectidx1] + offset[rectidx1], rectv[rectidx1],
84 :     xy[rectidx2] + offset[rectidx2], rectv[rectidx2]))
85 :     else
86 :     area = 0
87 :    
88 :     # Penalize labels which go outside the image area
89 :     # Count points outside of the image
90 :     n_outside = sum(Re(xy + offset - rectv/2) < boundary[1] | Re(xy + offset + rectv/2) > boundary[2] |
91 :     Im(xy + offset - rectv/2) < boundary[3] | Im(xy + offset + rectv/2) > boundary[4])
92 :     area + n_outside * image_width * image_height
93 :     }
94 :    
95 :    
96 :     # Make a list of label rectangles in their reference positions,
97 :     # centered over the map feature; the real labels are displaced
98 :     # from these positions so as not to overlap
99 :     # Note that some labels can be bigger than others
100 :     xy = x + 1i * y
101 :     rectv = width + 1i * height
102 :    
103 :     rectidx1 = rectidx2 = array(0, (length(x)^2 - length(x)) / 2)
104 :     k=0
105 :     for (i in 1:length(x))
106 :     for (j in seq(len=(i-1))) {
107 :     k = k + 1
108 :     rectidx1[k] = i
109 :     rectidx2[k] = j
110 :     }
111 :     canIntersect = rect_intersect(xy[rectidx1], 2 * rectv[rectidx1],
112 :     xy[rectidx2], 2 * rectv[rectidx2]) > 0
113 :     rectidx1 = rectidx1[canIntersect]
114 :     rectidx2 = rectidx2[canIntersect]
115 :     if (trace) cat("possible intersects =", length(rectidx1), "\n")
116 :    
117 :     if (trace) cat("portion covered =", sum(rect_intersect(xy, rectv,xy,rectv))/(image_width*image_height),"\n")
118 :    
119 :     GA <- function() {
120 :     # Make some starting genes
121 :     n_startgenes = 1000 # size of starting gene pool
122 :     n_bestgenes = 30 # genes selected for cross-breeding
123 :     prob = 0.2
124 :    
125 :     # Mutation function: O(n^2) time
126 :     mutate <- function(gene) {
127 :     offset = gen_offset(gene)
128 :     # Directed mutation where two rectangles intersect
129 :     doesIntersect = rect_intersect(xy[rectidx1] + offset[rectidx1], rectv[rectidx1],
130 :     xy[rectidx2] + offset[rectidx2], rectv[rectidx2]) > 0
131 :    
132 :     for (i in which(doesIntersect)) {
133 :     gene[rectidx1[i]] = sample(1:8, 1)
134 :     }
135 :     # And a bit of random mutation, too
136 :     for (i in seq(along=gene))
137 :     if (runif(1) <= prob)
138 :     gene[i] = sample(1:8, 1)
139 :     gene
140 :     }
141 :    
142 :     # Crossbreed two genes, then mutate at "hot spots" where intersections remain
143 :     crossbreed <- function(g1, g2)
144 :     ifelse(sample(c(0,1), length(g1), repl = TRUE) > .5, g1, g2)
145 :    
146 :    
147 :     genes = matrix(sample(1:8, n_labels * n_startgenes, repl = TRUE), n_startgenes, n_labels)
148 :    
149 :     for (i in 1:10) {
150 :     scores = array(0., NROW(genes))
151 :     for (j in 1:NROW(genes))
152 :     scores[j] = objective(genes[j,])
153 :     rankings = order(scores)
154 :     genes = genes[rankings,]
155 :     bestgenes = genes[1:n_bestgenes,]
156 :     bestscore = scores[rankings][1]
157 :     if (bestscore == 0) {
158 :     if (trace) cat("overlap area =", bestscore, "\n")
159 :     break
160 :     }
161 :     # At each stage, we breed the best genes with one another
162 :     genes = matrix(0, n_bestgenes^2, n_labels)
163 :     for (j in 1:n_bestgenes)
164 :     for (k in 1:n_bestgenes)
165 :     genes[n_bestgenes*(j-1) + k,] = mutate(crossbreed(bestgenes[j,], bestgenes[k,]))
166 :    
167 :     genes = rbind(bestgenes, genes)
168 :     if (trace) cat("overlap area =", bestscore, "\n")
169 :     }
170 :     nx = Re(xy + gen_offset(bestgenes[1,]))
171 :     ny = Im(xy + gen_offset(bestgenes[1,]))
172 :     list(x = nx, y = ny)
173 :     }
174 :     SANN <- function() {
175 :     # Make some starting "genes"
176 :     #gene = sample(1:8, n_labels, repl = TRUE)
177 :     gene = rep(8, n_labels)
178 :     score = objective(gene)
179 :     bestgene = gene
180 :     bestscore = score
181 :     T = 2.5
182 :     for (i in 1:50) {
183 :     k = 1
184 :     for (j in 1:50) {
185 :     newgene = gene
186 :     newgene[sample(1:n_labels, 1)] = sample(1:8,1)
187 :     newscore = objective(newgene)
188 :     if (newscore < score || runif(1) < 1 - exp((newscore - score) / T)) {
189 :     k = k + 1
190 :     score = newscore
191 :     gene = newgene
192 :     }
193 :     if (score <= bestscore) {
194 :     bestscore = score
195 :     bestgene = gene
196 :     }
197 :     if (bestscore == 0 || k == 10) break
198 :     }
199 :     if (bestscore == 0) break
200 :     if (trace) cat("overlap area =", bestscore, "\n")
201 :     T = 0.9 * T
202 :     }
203 :    
204 :     if (trace) cat("overlap area =", bestscore, "\n")
205 :     nx = Re(xy + gen_offset(bestgene))
206 :     ny = Im(xy + gen_offset(bestgene))
207 :     list(x = nx, y = ny)
208 :     }
209 :     if (method == "SANN")
210 :     xy = SANN()
211 :     else
212 :     xy = GA()
213 :     if (doPlot)
214 :     text(xy, labels, cex = cex, ...)
215 :     invisible(xy)
216 :     }
217 :    

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge