# Posted By

mjaniec on 06/09/11

# Statistics

Viewed 600 times
Favorited by 0 user(s)

# Optimization of log linear model with one feature function - example

/ Published in: R

partly inspired by: http://cseweb.ucsd.edu/~elkan/250B/cikmtutorial.pdf

Copy this code and paste it in your HTML
1. rm(list=ls(all=TRUE))
2.
3. labelsNum <- 2
4. learningNum <- 8
5. attributesNum <- 4 # d3ugooa sekwencji=ilooa atrybutÃ³w (ustalamy, ?e jest sta3a)
6.
7. featuresNum <- attributesNum+(attributesNum-1) # ff dla poszczegÃ³lnych atrybutÃ³w oraz ff dla dwÃ³ch kolejnych atrybutÃ³w
8.
9. labels <- c(1,0)
10.
11. xf <- matrix(0,learningNum,(attributesNum+1)) # przypadki; kolumna 1 - label: 1/0
12.
13. xf[1,] <- c(1,6,1,7,1)
14. xf[2,] <- c(1,2,1,7,1)
15. xf[3,] <- c(0,6,0,2,2)
16. xf[4,] <- c(1,1,0,1,1)
17. xf[5,] <- c(0,5,2,1,1)
18. xf[6,] <- c(0,4,0,2,0)
19. xf[7,] <- c(1,6,1,7,2)
20. xf[8,] <- c(0,1,0,1,0)
21.
22. w <- matrix(1,1,featuresNum) # wagi dla feature functions, inicjowana 1
23.
24. resetW <- function(x) {
25.
26. matrix(x,1,featuresNum)
27.
28. }
29.
30. ffm <- array(0,dim=c(learningNum,featuresNum,labelsNum)) # "tensor 2. rzedu" (tablica 3d) dla wartooci feature functions dla labels
31.
32. #---
33.
34. ff <- function(l,a,x,learning=FALSE) { # przykladowa feature function dla pojedynczego indeksu wektora cech: l-label, f-"feature" (indeks w wektorze cech), x-wartooa feature
35.
36. a <- a+1
37.
38. if (learning) {
39.
40. n <- length(intersect(which(xf[,1]==l),which(xf[,a]==x)))
41.
42. d <- length(which(xf[,a]==x))
43.
44. if (d!=0) n/d else 0
45. }
46.
47. else {
48.
49. i <- which(xf[,a]==x) # ktÃ³ry z przypadkÃ³w u?ytych do nauki = x
50.
51. ifelse(length(i)>0,ffm[i[1],a-1,which(labels==l)],0)
52.
53. }
54. }
55.
56.
57. ffv <- function(l,x,learning) { # feature function dla danego przypadku x (wektor cech) i labela l
58.
59. fv <- matrix(0,1,attributesNum)
60.
61. for (i in 1:attributesNum) {
62.
63. fv[i] <- ff(l,i,x[i],learning)
64.
65. }
66.
67. fv
68.
69. }
70.
71. buildffm <- function() {
72.
73. for (l in labels) {
74.
75. for (lc in 1:learningNum) {
76.
77. ffm[lc,1:4,which(labels==l)] <- ffv(l,xf[lc,2:(attributesNum+1)],learning=TRUE)
78.
79. }
80. }
81.
82. ffm
83. }
84.
85. #--- uogÃ³lniona dla dowolnej liczby atrybutÃ³w feature function ff
86.
87. isPresent <- function(x,a_values,a_positions) { # czy dany atrybut lub atrybuty wystepuj1 na danej pozycji sekwencji x?
88.
89. a_num <- length(a_values)
90.
91. b <- TRUE
92.
93. for (i in 1:a_num) {
94.
95. b <- b & x[a_positions[i]]==a_values[i]
96.
97. }
98.
99. b
100.
101. }
102.
103. ff2 <- function(l,a_values,a_positions,ff_index=0,learning=FALSE) { # a_values, a_positions - wektory wartooci i pozycje atrybutÃ³w
104.
105. if (learning) {
106.
107. label_count <- 0
108. total_count <- 0
109.
110. for (lc in 1:learningNum) {
111.
112. presence <- isPresent(xf[lc,2:(attributesNum+1)],a_values,a_positions)
113.
114. if (presence) {
115.
116. total_count <- total_count+1
117.
118. if (xf[lc,1]==l) label_count <- label_count+1
119.
120. }
121. }
122.
123. label_count/total_count
124.
125. }
126.
127. else {
128.
129. vf <- 0
130.
131. for (i in 1:learningNum) {
132.
133. if (isPresent(xf[i,2:(attributesNum+1)],a_values,a_positions) && xf[i,1]==l) {
134.
135. vf <- ffm[i,ff_index,which(labels==l)]
136.
137. break
138.
139. }
140.
141. }
142.
143. vf
144.
145. }
146.
147. }
148.
149. ffv2 <- function(l,x,learning) {
150.
151. fv <- matrix(0,1,featuresNum)
152.
153. #--- feature functions zwi1zane z pojedynczymi atrybutami
154.
155. for (i in 1:attributesNum) {
156.
157. fv[i] <- ff(l,i,x[i],learning)
158.
159. }
160.
161. #--- feature function(s) zwi1zane z dwoma kolejnymi atrybutami
162.
163. for (i in 1:(attributesNum-1)) {
164.
165. fv[attributesNum+i] <- ff2(l,x[i:(i+1)],c(i,i+1),ff_index=(attributesNum+i),learning)
166.
167. }
168.
169. fv
170. }
171.
172.
173. buildffm2 <- function() {
174.
175. for (l in labels) {
176.
177. for (lc in 1:learningNum) {
178.
179. ffm[lc,,which(labels==l)] <- ffv2(l,xf[lc,2:(attributesNum+1)],learning=TRUE)
180. }
181. }
182.
183. ffm
184. }
185.
186. #---
187.
188. nompf <- function(l,x,w,learning) { # licznik
189.
190. if (!learning)
191.
192. exp(sum(ffv2(l,x,learning) * w)) # domyolnie operujemy na wektorze x
193.
194. else
195.
196. exp(sum(ffm[x,,which(labels==l)] * w)) # je?eli sie uczymy, korzystamy z prebuilt tablicy dla przypadku numer x
197.
198. }
199.
200. sumpf <- function(x,w,learning) { # mianownik; s1 tylko 2 labels: 1 i 0
201.
202. sv <- 0
203.
204. for (l in labels) {
205.
206. sv <- sv + nompf(l,x,w,learning)
207.
208. }
209.
210. sv
211. }
212.
213. pf <- function(l,x,w,learning=FALSE) { # probability function; x - vector lub numer przypadku dla learning
214.
215. nompf(l,x,w,learning) / sumpf(x,w,learning)
216.
217. }
218.
219. pLabel <- function(x,w) {
220.
221. vl <- matrix(0,1,labelsNum)
222. colnames(vl) <- labels
223.
224. i <- 0
225.
226. for (l in labels) {
227.
228. i <- i+1
229.
230. vl[i] <- pf(l,x,w,learning=FALSE)
231.
232. }
233.
234. vl
235.
236. }
237.
238. #>>>>>> 2DO 2DO 2DO 2DO 2DO 2DO
239.
240. modelMax <- function(w) {
241. }
242.
243.
244. modelError <- function(w) { # b31d modelu jest zale?ny tylko od wag w
245.
246. r <- matrix(0,1,learningNum)
247.
248. for (lc in 1:learningNum) { # lc - learning case number
249.
250. r[lc] <- pf(1,lc,w,learning=TRUE)
251.
252. }
253.
254. sum((r-xf[,1])^2)
255.
256. }
257.
258. #--- initialization
259.
260. xf
261. (ffm <- buildffm2())
262.
263. #--- rozgrzewka ;)
264.
265. ff(1,1,6)
266. ff(1,1,2)
267. ff(1,1,9)
268.
269. pf(1,c(6,1,7,1),w)
270. pf(0,c(6,1,7,1),w)
271.
272. pLabel(c(1,1,1,1),w)
273. pLabel(c(6,0,2,1),w)
274. pLabel(c(9,7,7,9),w)
275. pLabel(c(4,0,2,0),w)
276. pLabel(c(4,0,2,1),w)
277.
278. #--- optimalization:
279.
280. modelError(w)
281.
282. # metody optymalizacyjne w R: http://cran.r-project.org/web/views/Optimization.html
283. # optymalizacja ogÃ³lnie: http://en.wikipedia.org/wiki/Optimization_(mathematics)
284.
285. (o <- optim(w, modelError))
286.
287. w <- o\$par
288.
289. pLabel(c(1,1,1,1),w)
290. pLabel(c(6,0,2,1),w)
291. pLabel(c(9,7,7,9),w)
292. pLabel(c(4,0,2,0),w)
293. pLabel(c(4,0,2,1),w)
294.
295. # dodatkowy simulated annealing:
296.
297. w <- resetW(1)
298.
299. (optim(w, modelError, method="SANN"))
300.
301. w <- o\$par
302.
303. pLabel(c(1,1,1,1),w)
304. pLabel(c(6,0,2,1),w)
305. pLabel(c(9,7,7,9),w)
306. pLabel(c(4,0,2,0),w)
307. pLabel(c(4,0,2,1),w)