Optimization of log linear model with one feature function - example


/ Published in: R
Save to your folder(s)

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)

URL: http://mjaniec.blogspot.com

Report this snippet


Comments

RSS Icon Subscribe to comments

You need to login to post a comment.