├── Chapter 01 └── bayes.r ├── Chapter 02 ├── chapter2_1.r └── chapter2_2.r ├── Chapter 03 └── learn.r ├── Chapter 04 ├── mix1.r └── mix2.r ├── Chapter 05 ├── a.r ├── example.stan ├── mh.r └── random_walk.r ├── Chapter 06 └── overfit.r ├── Chapter 07 ├── ch7.r └── lda.r ├── LICENSE └── README.md /Chapter 01/bayes.r: -------------------------------------------------------------------------------- 1 | bayes <- function(prior, likelihood, data) 2 | { 3 | posterior <- matrix(0, nrow=length(data), ncol=length(prior)) 4 | dimnames(posterior) <- list(data, names(prior)) 5 | 6 | initial_prior = prior 7 | for(i in 1:length(data)) 8 | { 9 | posterior[i, ] <- 10 | prior*likelihood[ , data[i]]/ 11 | sum(prior * likelihood[ , data[i]]) 12 | 13 | prior <- posterior[i , ] 14 | } 15 | 16 | return(rbind(initial_prior,posterior)) 17 | } 18 | -------------------------------------------------------------------------------- /Chapter 02/chapter2_1.r: -------------------------------------------------------------------------------- 1 | # Sum-product and beliefs update examples 2 | A=matrix(c(.8,.2),2,1) 3 | B=matrix(c(.6,.4,.3,.7),2,2) 4 | C=matrix(c(.5,.5,.8,.8),2,2) 5 | D=matrix(c(.3,.7,.4,.6),2,2) 6 | 7 | Bs = t(A) %*% t(B) 8 | Cs = Bs %*% t(C) 9 | Ds = Cs %*% t(D) 10 | Ds 11 | -------------------------------------------------------------------------------- /Chapter 02/chapter2_2.r: -------------------------------------------------------------------------------- 1 | library(gRain) 2 | 3 | 4 | F = cptable(~F, values=c(10,90),levels=val) 5 | C = cptable(~C|F, values=c(10,90,20,80),levels=val) 6 | E = cptable(~E|F, values=c(50,50,30,70),levels=val) 7 | A = cptable(~A|C, values=c(50,50,70,30),levels=val) 8 | D = cptable(~D|E, values=c(60,40,70,30),levels=val) 9 | B = cptable(~B|A:D, values=c(60,40,70,30,20,80,10,90),levels=val) 10 | 11 | plist = compileCPT(list(F,E,C,A,D,B)) 12 | plist 13 | 14 | print(plist$F) 15 | print(plist$B) 16 | 17 | jtree = grain(plist) 18 | jtree 19 | 20 | querygrain(jtree, nodes=c("F"), type="marginal") 21 | querygrain(jtree, nodes=c("C"), type="marginal") 22 | querygrain(jtree, nodes=c("B"), type="marginal") 23 | querygrain(jtree, nodes=c("A","B"), type="joint") 24 | querygrain(jtree, nodes=c("A","B","C"), type="joint") 25 | 26 | jtree2 = setEvidence(jtree, evidence=list(F="true")) 27 | querygrain(jtree, nodes=c("F"), type="marginal") 28 | querygrain(jtree2, nodes=c("F"), type="marginal") 29 | querygrain(jtree, nodes=c("A"), type="marginal") 30 | querygrain(jtree2, nodes=c("A"), type="marginal") 31 | querygrain(jtree, nodes=c("B"), type="marginal") 32 | querygrain(jtree2, nodes=c("B"), type="marginal") 33 | 34 | jtree3 = setEvidence(jtree, evidence=list(F="true",A="false")) 35 | querygrain(jtree, nodes=c("C"), type="marginal") 36 | querygrain(jtree2, nodes=c("C"), type="marginal") 37 | querygrain(jtree3, nodes=c("C"), type="marginal") 38 | 39 | -------------------------------------------------------------------------------- /Chapter 03/learn.r: -------------------------------------------------------------------------------- 1 | library(graph) 2 | library(Rgraphviz) 3 | library(plyr) 4 | 5 | data0 <- data.frame( 6 | x=c("a","a","a","a","b","b","b","b"), 7 | y=c("t","t","u","u","t","t","u","u"), 8 | z=c("c","d","c","d","c","d","c","d")) 9 | 10 | edges0 <- list(x=list(edges=2),y=list(edges=3),z=list()) 11 | g0 <- graphNEL(nodes=names(data0),edgeL=edges0,edgemod="directed") 12 | plot(g0) 13 | 14 | data1 <- read.csv("http://archive.ics.uci.edu/ml/machine-learning-databases/nursery/nursery.data", col.names=c("parents","has_nurs","form","children","housing","finance","social","health","class")) 15 | edges1 <- list( parents=list(), has_nurs=list(), form=list(), children=list(), 16 | housing=list(), finance=list(), social=list(), health=list(), 17 | class=list(edges=1:8) ) 18 | g1 <- graphNEL(nodes=names(data1), edgeL=edges1,edgemod="directed") 19 | plot(g1) 20 | 21 | make_cpt<-function(df,pa) 22 | { 23 | prob <- nrow(df) 24 | parents <- data.frame(df[1,pa]) 25 | names(parents) <- pa 26 | 27 | data.frame(parents,prob) 28 | } 29 | 30 | learn <- function(g,data) 31 | { 32 | rg <- reverseEdgeDirections(g) 33 | result <- list() 34 | 35 | for(var in rg@nodes) 36 | { 37 | pa <- unlist(adj(rg,var)) 38 | if(length(pa)>0) 39 | { 40 | X <- ddply(data, c(var,pa), make_cpt, pa) 41 | Y <- ddply(data, pa, make_cpt, pa) 42 | for(i in 1:nrow(Y)) 43 | { 44 | c <- sapply(1:nrow(X), function(j) all(X[j,pa] == Y[i,pa])) 45 | c <- which(c) 46 | X$prob[c] <- X$prob[c]/Y$prob[i] 47 | } 48 | } 49 | else 50 | { 51 | X <- ddply(data,var, function(df) c(prob=nrow(df))) 52 | X$prob <- X$prob/sum(X$prob) 53 | } 54 | 55 | result[[length(result)+1]] <- X 56 | } 57 | 58 | return(result) 59 | } 60 | -------------------------------------------------------------------------------- /Chapter 04/mix1.r: -------------------------------------------------------------------------------- 1 | library(mixtools) 2 | 3 | N <- 400 4 | 5 | X <- list( 6 | mvrnorm(N, c(1,1), matrix(c(1,-0.5,-0.5,1),2,2)/4), 7 | mvrnorm(N, c(3,3), matrix(c(2,0.5,0.5,1),2,2)/4), 8 | mvrnorm(N, c(5,5), matrix(c(1,-0.5,-0.5,4),2,2)/4)) 9 | 10 | plot(0,0,xlim=c(-1,7),ylim=c(-1,7),type='n') 11 | for(i in 1:3) 12 | points(X[[i]],pch=18+i, col=1+i) 13 | -------------------------------------------------------------------------------- /Chapter 04/mix2.r: -------------------------------------------------------------------------------- 1 | library(mixtools) 2 | 3 | N <- 400 4 | 5 | X <- list( 6 | mvrnorm(100, c(1,1), matrix(c(1,-0.5,-0.5,1),2,2)/4), 7 | mvrnorm(200, c(3,3), matrix(c(2,0.5,0.5,1),2,2)/4), 8 | mvrnorm(300, c(5,5), matrix(c(1,-0.5,-0.5,4),2,2)/4)) 9 | x <- do.call(rbind,X) 10 | -------------------------------------------------------------------------------- /Chapter 05/a.r: -------------------------------------------------------------------------------- 1 | x=seq(-10,10,0.1) 2 | y=1.9*dnorm(x,0.9,2.6) 3 | cord.x <- c(-10,x,-10) 4 | cord.y <- c( 0,y,0) 5 | plot(y,xlim=c(-10,10),ylim=c(0,0.5),t='l') 6 | polygon(cord.x,cord.y,col='grey') 7 | 8 | cord2.x <- c(-10,x,-10) 9 | cord2.y <- c(0,0.35*dnorm(x,-2,1)+0.65*dnorm(x,2,1),0) 10 | #curve( 0.35*dnorm(x,-2,1)+0.65*dnorm(x,2,1),xlim=c(-10,10)) 11 | polygon(cord2.x,cord2.y,col='white') 12 | -------------------------------------------------------------------------------- /Chapter 05/example.stan: -------------------------------------------------------------------------------- 1 | parameters 2 | { 3 | real y; 4 | } 5 | 6 | model 7 | { 8 | y ~ normal(0,1); 9 | 10 | } 11 | -------------------------------------------------------------------------------- /Chapter 05/mh.r: -------------------------------------------------------------------------------- 1 | p = function(x) 2 | { 3 | dnorm(x,0,1) 4 | } 5 | 6 | mh = function(x,alpha) 7 | { 8 | xt <- runif(1,x-alpha,x+alpha) 9 | if( runif(1) > p(xt) / p(x) ) 10 | xt <- x 11 | 12 | return(xt) 13 | } 14 | 15 | sampler = function(L,alpha) 16 | { 17 | x <- numeric(L) 18 | for(i in 2:L) 19 | x[i] <- mh(x[i-1],alpha) 20 | 21 | return(x) 22 | } 23 | 24 | par(mfrow=c(2,2)) 25 | for(l in c(10,100,1000,10000)) 26 | { 27 | hist(sampler(l,1),main=paste(l,"iterations"),breaks=50,freq=F,xlim=c(-4,4),ylim=c(0,1)) 28 | lines(x0,p(x0)) 29 | } 30 | 31 | par(mfrow=c(2,2)) 32 | for(a in c(0.1,0.5,1,10)) 33 | { 34 | hist(sampler(50000,a),main=paste("alpha=",a),breaks=50,freq=F,xlim=c(-4,4),ylim=c(0,1)) 35 | lines(x0,p(x0)) 36 | } 37 | 38 | #x0 <- seq(-4,4,0.1) 39 | #plot( x0, p(x0), lty=2 , t='l') 40 | -------------------------------------------------------------------------------- /Chapter 05/random_walk.r: -------------------------------------------------------------------------------- 1 | # lets first simulate a bivariate normal sample 2 | library(MASS) 3 | library(mvtnorm) 4 | bigauss <- mvrnorm(50000, mu = c(0, 0), Sigma = matrix(c(1, .1, .1, 1), 2)) 5 | bigauss.estimate <- kde2d(bigauss[,1], bigauss[,2], n = 50) 6 | contour(bigauss.estimate,nlevels=6,lty=2) 7 | 8 | bigauss <- mvrnorm(50000, mu = c(0, 0), Sigma = matrix(c(.1, .01, .01, .1), 2)) 9 | bigauss.estimate <- kde2d(bigauss[,1], bigauss[,2], n = 50) 10 | contour(bigauss.estimate,nlevels=6,col=2,add=TRUE) 11 | 12 | L <- 1000 13 | smallcov <- matrix(c(.1,.01,.01,.1),2) 14 | x <- c(0,0) 15 | for(i in 1:L) 16 | { 17 | x2 <- mvrnorm(1, mu=x, Sigma=smallcov) 18 | lines(c(x[1],x2[1]), c(x[2],x2[2]), t='p',pch=20) 19 | x <- x2 20 | } 21 | -------------------------------------------------------------------------------- /Chapter 06/overfit.r: -------------------------------------------------------------------------------- 1 | N <- 30 2 | true_beta <- c(10, -3, 0, 8, 0, 0, 0, 0, 0) 3 | 4 | x <- runif(N, -2, 2) 5 | X <- cbind(rep(1, N), x, x^2, x^3, x^4, x^5, x^6, x^7, x^8) 6 | matplot(X, t='l') 7 | 8 | sigma <- 10 9 | eps <- rnorm(N, mean = 0, sd = sigma) 10 | y <- X %*% true_beta + eps 11 | plot(y,t='l') 12 | 13 | model <- lm(y~., data=data.frame(X[,2:ncol(X)])) 14 | beta_hat <- model$coefficients 15 | 16 | plot( beta_hat, t='o', col=2, pch='x') 17 | lines(true_beta, t='o', col=1) 18 | 19 | # Prior precision 20 | dimension <- length(true_beta) 21 | lambda <- 0.1*diag(0.1, dimension, dimension) 22 | 23 | # Posterior covariance 24 | posterior_sigma <- sigma^2 * solve(t(X) %*% X + sigma^2 * lambda) 25 | posterior_beta <- sigma^(-2) * as.vector(posterior_sigma %*% (t(X) %*% y)) 26 | 27 | t <- seq(-2,2,0.01) 28 | T <- cbind(rep(1, N), t, t^2, t^3, t^4, t^5, t^6, t^7, t^8) 29 | plot(x,y, xlim=c(-2,2), ylim=range(y, T%*%true_beta)) 30 | lines(t,T%*%true_beta, col='black', lwd=3) 31 | lines(t,T%*%beta_hat, col='blue', lwd=3) 32 | lines(t,T%*%posterior_beta, col='red', lwd=3) 33 | legend('topleft', c('True function', 'OLS estimate', 'Bayesian estimate'), col=c('black','blue','red'), lwd=3) 34 | 35 | pred_sigma <- sqrt(sigma^2 + apply((T%*%posterior_sigma)*T, MARGIN=1, FUN=sum)) 36 | upper_bound <- T%*%posterior_beta + qnorm(0.95)*pred_sigma 37 | lower_bound <- T%*%posterior_beta - qnorm(0.95)*pred_sigma 38 | 39 | plot(c(0,0),xlim=c(-2,2), ylim=range(y,lower_bound,upper_bound),col='white') 40 | polygon( c(t,rev(t)), c(upper_bound,rev(lower_bound)), col='grey', border=NA) 41 | points(x,y) 42 | lines(t,T%*%true_beta, col='black', lwd=3) 43 | lines(t,T%*%beta_hat, col='blue', lwd=3) 44 | lines(t,T%*%posterior_beta, col='red', lwd=3) 45 | legend('topleft', c('True function', 'OLS estimate', 'Bayesian estimate'), col=c('black','blue','red'), lwd=3) 46 | -------------------------------------------------------------------------------- /Chapter 07/ch7.r: -------------------------------------------------------------------------------- 1 | x1=runif(40,0,10) 2 | x2=runif(40,10,20) 3 | 4 | e1 = rnorm(20,0,2) 5 | e2 = rnorm(20,0,3) 6 | 7 | y1 = 1+2.5*x1 + e1 8 | y2 = 35+-1.5*x2 + e2 9 | 10 | xx=c(x1,x2) 11 | yy=c(y1,y2) 12 | 13 | x0 = seq(0,20,.1) 14 | m0 = lm(yy~xx) 15 | m1 = lm(y1~x1) 16 | m2 = lm(y2~x2) 17 | 18 | -------------------------------------------------------------------------------- /Chapter 07/lda.r: -------------------------------------------------------------------------------- 1 | data(NYTimes) 2 | data <- NYTimes[ samples(1:3100, size=1000,replace=F) ] 3 | 4 | matrix <- create_matrix(cbind(as.vector(data$Title),as.vector(data$Subject)), language="english", removeNumbers=TRUE, stemWords=TRUE) 5 | k <- length(unique(data$Topic.Code)) 6 | lda <- LDA(matrix, k) 7 | 8 | print(lda@gamma[1,]) 9 | plot(colSums(lda@gamma)/nrow(lda@gamma),t='h') 10 | 11 | sum(sapply( 1:nrow(lda@gamma), function(i) sum(lda@gamma[i,]>0.1) > 1)) 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Packt Publishing 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | #Learning Probabilistic Graphical Models in R 5 | 6 | All the examples are used with R version 3 or above on any platform and operating system supporting R. 7 | 8 | This code is for anyone who has to deal with lots of data and draw conclusions from it, especially when the data is noisy or uncertain. Data scientists, machine learning enthusiasts, engineers, and those who are curious about the latest advances in machine learning will find PGM interesting. 9 | 10 | You can also refer to the following books: 11 | 12 | * [R for Data Science](https://www.packtpub.com/big-data-and-business-intelligence/r-data-science?utm_source=github&utm_medium=related&utm_campaign=9781784390860) 13 | * [Learning Data Mining with R](https://www.packtpub.com/big-data-and-business-intelligence/learning-data-mining-r?utm_source=github&utm_medium=related&utm_campaign=9781783982103) 14 | * [Learning R for Geospatial Analysis](https://www.packtpub.com/big-data-and-business-intelligence/learning-r-geospatial-analysis?utm_source=github&utm_medium=related&utm_campaign=9781783984367) 15 | ### Download a free PDF 16 | 17 | If you have already purchased a print or Kindle version of this book, you can get a DRM-free PDF version at no cost.
Simply click on the link to claim your free PDF. 18 |

https://packt.link/free-ebook/9781784392055

--------------------------------------------------------------------------------