Introduction
mclust is a contributed R package for model-based clustering, classification, and density estimation based on finite normal mixture modelling. It provides functions for parameter estimation via the EM algorithm for normal mixture models with a variety of covariance structures, and functions for simulation from these models. Also included are functions that combine model-based hierarchical clustering, EM for mixture estimation and the Bayesian Information Criterion (BIC) in comprehensive strategies for clustering, density estimation and discriminant analysis. Additional functionalities are available for displaying and visualizing fitted models along with clustering, classification, and density estimation results.
This document gives a quick tour of mclust (version 5.4) functionalities. It was written in R Markdown, using the knitr package for production. See help(package="mclust") for further details and references provided by citation("mclust").
library(mclust)
## __ ___________ __ _____________
## / |/ / ____/ / / / / / ___/_ __/
## / /|_/ / / / / / / / /\__ \ / /
## / / / / /___/ /___/ /_/ /___/ // /
## /_/ /_/\____/_____/\____//____//_/ version 5.4
## Type 'citation("mclust")' for citing this R package in publications.
Clustering
data(diabetes)
class <- diabetes$class
table(class)
## class
## Chemical Normal Overt
## 36 76 33
X <- diabetes[,-1]
head(X)
## glucose insulin sspg
## 1 80 356 124
## 2 97 289 117
## 3 105 319 143
## 4 90 356 199
## 5 90 323 240
## 6 86 381 157
clPairs(X, class)
BIC <- mclustBIC(X)
plot(BIC)
summary(BIC)
## Best BIC values:
## VVV,3 VVV,4 EVE,6
## BIC -4751.316 -4784.32213 -4785.24591
## BIC diff 0.000 -33.00573 -33.92951
mod1 <- Mclust(X, x = BIC)
summary(mod1, parameters = TRUE)
## ----------------------------------------------------
## Gaussian finite mixture model fitted by EM algorithm
## ----------------------------------------------------
##
## Mclust VVV (ellipsoidal, varying volume, shape, and orientation) model with 3 components:
##
## log.likelihood n df BIC ICL
## -2303.496 145 29 -4751.316 -4770.169
##
## Clustering table:
## 1 2 3
## 81 36 28
##
## Mixing probabilities:
## 1 2 3
## 0.5368974 0.2650129 0.1980897
##
## Means:
## [,1] [,2] [,3]
## glucose 90.96239 104.5335 229.42136
## insulin 357.79083 494.8259 1098.25990
## sspg 163.74858 309.5583 81.60001
##
## Variances:
## [,,1]
## glucose insulin sspg
## glucose 57.18044 75.83206 14.73199
## insulin 75.83206 2101.76553 322.82294
## sspg 14.73199 322.82294 2416.99074
## [,,2]
## glucose insulin sspg
## glucose 185.0290 1282.340 -509.7313
## insulin 1282.3398 14039.283 -2559.0251
## sspg -509.7313 -2559.025 23835.7278
## [,,3]
## glucose insulin sspg
## glucose 5529.250 20389.09 -2486.208
## insulin 20389.088 83132.48 -10393.004
## sspg -2486.208 -10393.00 2217.533
plot(mod1, what = "classification")
table(class, mod1$classification)
##
## class 1 2 3
## Chemical 9 26 1
## Normal 72 4 0
## Overt 0 6 27
par(mfrow = c(2,2))
plot(mod1, what = "uncertainty", dimens = c(2,1), main = "")
plot(mod1, what = "uncertainty", dimens = c(3,1), main = "")
plot(mod1, what = "uncertainty", dimens = c(2,3), main = "")
par(mfrow = c(1,1))
ICL = mclustICL(X)
summary(ICL)
## Best ICL values:
## VVV,3 EVE,6 EVE,7
## ICL -4770.169 -4797.38232 -4797.50566
## ICL diff 0.000 -27.21342 -27.33677
plot(ICL)
LRT = mclustBootstrapLRT(X, modelName = "VVV")
LRT
## Bootstrap sequential LRT for the number of mixture components
## -------------------------------------------------------------
## Model = VVV
## Replications = 999
## LRTS bootstrap p-value
## 1 vs 2 361.16739 0.001
## 2 vs 3 123.49685 0.001
## 3 vs 4 16.76161 0.482
Bootstrap inference
boot1 <- MclustBootstrap(mod1, nboot = 999, type = "bs")
summary(boot1, what = "se")
## ----------------------------------------------------------
## Resampling standard errors
## ----------------------------------------------------------
## Model = VVV
## Num. of mixture components = 3
## Replications = 999
## Type = nonparametric bootstrap
##
## Mixing probabilities:
## 1 2 3
## 0.05419824 0.05076478 0.03439980
##
## Means:
## 1 2 3
## glucose 0.9971095 3.495092 16.968865
## insulin 7.5755190 28.509588 66.873839
## sspg 7.6801499 31.104490 9.850315
##
## Variances:
## [,,1]
## glucose insulin sspg
## glucose 10.98617 52.3023 55.67768
## insulin 52.30230 514.5611 423.81468
## sspg 55.67768 423.8147 638.96053
## [,,2]
## glucose insulin sspg
## glucose 73.19889 713.4218 454.1136
## insulin 713.42183 8223.6427 3408.2040
## sspg 454.11357 3408.2040 6701.2674
## [,,3]
## glucose insulin sspg
## glucose 1050.8228 4222.914 656.1974
## insulin 4222.9140 19090.309 2472.4658
## sspg 656.1974 2472.466 490.7419
summary(boot1, what = "ci")
## ----------------------------------------------------------
## Resampling confidence intervals
## ----------------------------------------------------------
## Model = VVV
## Num. of mixture components = 3
## Replications = 999
## Type = nonparametric bootstrap
## Confidence level = 0.95
##
## Mixing probabilities:
## 1 2 3
## 2.5% 0.4391053 0.1522011 0.1304827
## 97.5% 0.6531662 0.3523459 0.2650163
##
## Means:
## [,,1]
## glucose insulin sspg
## 2.5% 89.22400 343.2214 150.0103
## 97.5% 93.19995 373.9562 181.4140
## [,,2]
## glucose insulin sspg
## 2.5% 98.82161 446.5122 258.6823
## 97.5% 112.49144 556.9686 372.5100
## [,,3]
## glucose insulin sspg
## 2.5% 196.9730 967.6157 62.84289
## 97.5% 264.2195 1231.6510 101.30441
##
## Variances:
## [,,1]
## glucose insulin sspg
## 2.5% 38.30658 1261.947 1555.379
## 97.5% 81.45462 3217.946 4146.033
## [,,2]
## glucose insulin sspg
## 2.5% 86.63346 3138.875 12422.98
## 97.5% 385.78229 33757.819 38375.98
## [,,3]
## glucose insulin sspg
## 2.5% 3308.589 47536.77 1348.638
## 97.5% 7375.754 121281.74 3292.333
par(mfrow=c(4,3))
plot(boot1, what = "pro")
plot(boot1, what = "mean")
boot4 <- MclustBootstrap(mod4, nboot = 999, type = "bs")
summary(boot4, what = "se")
## ----------------------------------------------------------
## Resampling standard errors
## ----------------------------------------------------------
## Model = E
## Num. of mixture components = 2
## Replications = 999
## Type = nonparametric bootstrap
##
## Mixing probabilities:
## 1 2
## 0.03977832 0.03977832
##
## Means:
## 1 2
## 0.04488707 0.06680960
##
## Variances:
## 1 2
## 0.02458687 0.02458687
summary(boot4, what = "ci")
## ----------------------------------------------------------
## Resampling confidence intervals
## ----------------------------------------------------------
## Model = E
## Num. of mixture components = 2
## Replications = 999
## Type = nonparametric bootstrap
## Confidence level = 0.95
##
## Mixing probabilities:
## 1 2
## 2.5% 0.5452403 0.2994824
## 97.5% 0.7005176 0.4547597
##
## Means:
## 1 2
## 2.5% 4.280150 6.191873
## 97.5% 4.455027 6.456946
##
## Variances:
## 1 2
## 2.5% 0.1436647 0.1436647
## 97.5% 0.2379912 0.2379912
par(mfrow=c(2,2))
plot(boot4, what = "pro")
plot(boot4, what = "mean")
Using colorblind-friendly palettes
Most of the graphs produced by mclust use colors that by default are defined in the following options:
mclust.options("bicPlotColors")
## EII VII EEI EVI VEI VVI EEE
## "gray" "black" "#218B21" "#41884F" "#508476" "#58819C" "#597DC3"
## EVE VEE VVE EEV VEV EVV VVV
## "#5178EA" "#716EE7" "#9B60B8" "#B2508B" "#C03F60" "#C82A36" "#CC0000"
## E V
## "gray" "black"
mclust.options("classPlotColors")
## [1] "dodgerblue2" "red3" "green3" "slateblue"
## [5] "darkorange" "skyblue1" "violetred4" "forestgreen"
## [9] "steelblue4" "slategrey" "brown" "black"
## [13] "darkseagreen" "darkgoldenrod3" "olivedrab" "royalblue"
## [17] "tomato4" "cyan2" "springgreen2"
The first option controls colors used for plotting BIC, ICL, etc. curves, whereas the second option is used to assign colors for indicating clusters or classes when plotting data.
Color-blind-friendly palettes can be defined and assigned to the above options as follows:
cbPalette <- c("#E69F00", "#56B4E9", "#009E73", "#999999", "#F0E442", "#0072B2", "#D55E00", "#CC79A7")
bicPlotColors <- mclust.options("bicPlotColors")
bicPlotColors[1:14] <- c(cbPalette, cbPalette[1:6])
mclust.options("bicPlotColors" = bicPlotColors)
mclust.options("classPlotColors" = cbPalette)
clPairs(iris[,-5], iris$Species)
mod <- Mclust(iris[,-5])
plot(mod, what = "BIC")
plot(mod, what = "classification")
The above color definitions are adapted from http://www.cookbook-r.com/Graphs/Colors_(ggplot2)/, but users can easily define their own palettes if needed.
References
Scrucca L., Fop M., Murphy T. B. and Raftery A. E. (2016) mclust 5: clustering, classification and density estimation using Gaussian finite mixture models, The R Journal, 8/1, pp. 205-233. https://journal.r-project.org/archive/2016/RJ-2016-021/RJ-2016-021.pdf
Fraley C. and Raftery A. E. (2002) Model-based clustering, discriminant analysis and density estimation, Journal of the American Statistical Association, 97/458, pp. 611-631.
Fraley C., Raftery A. E., Murphy T. B. and Scrucca L. (2012) mclust Version 4 for R: Normal Mixture Modeling for Model-Based Clustering, Classification, and Density Estimation. Technical Report No. 597, Department of Statistics, University of Washington.
mclust/src/ 0000755 0001762 0000144 00000000000 13205037573 012355 5 ustar ligges users mclust/src/Makevars 0000644 0001762 0000144 00000000062 13205037573 014047 0 ustar ligges users PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)
mclust/src/mclustaddson.f 0000644 0001762 0000144 00000214506 13205037573 015234 0 ustar ligges users * =====================================================================
subroutine transpose(X, p)
*
* Compute transpose of a matrix
*
* =====================================================================
implicit NONE
integer :: p, i, j
double precision :: X(p,p), temp
do j = 2, p
do i = 1, j-1
temp = X(i,j)
X(i,j) = X(j,i)
X(j,i) = temp
end do
end do
return
end
* =====================================================================
subroutine crossprodf(X, Y, n, p, q, XTY)
*
* Given matrices X and Y of dimension (n x p) and (n x q) computes
* the matrix of cross-product, i.e. X' Y
*
* =====================================================================
implicit NONE
integer n, p, q
double precision X(n,p), Y(n,q), XTY(p,q)
* Compute X'Y using DGEMM blas subroutine
call DGEMM('T', 'N', p, q, n, 1.d0, X, n, Y, n, 0.d0, XTY, p)
end
* ======================================================================
subroutine covwf ( X, Z, n, p, G, M, S, W )
*
* Given data matrix X(n x p) and weight matrix Z(n x G) computes
* weighted means M(p x G), weighted covariance matrices S(p x p x G)
* and weighted scattering matrices W(p x p x G)
*
* ======================================================================
implicit none
integer :: n, p, G
double precision :: X(n,p), Z(n,G)
double precision :: M(p,G), S(p,p,G), W(p,p,G)
integer :: j, k
double precision :: sumZ(G), temp(n,p)
* compute X'Z using BLAS
call dgemm('T', 'N', p, G, n, 1.d0, X, n, Z, n, 0.d0, M, p)
* compute row sums of Z
sumZ = sum(Z, DIM = 1)
do k = 1,G
* compute means
call dscal(p, (1.d0/sumZ(k)), M(:,k), 1)
do j = 1,p
* compute sqrt(Z) * (X - M)
temp(:,j) = sqrt(Z(:,k)) * (X(:,j) - M(j,k))
end do
* compute scattering matrix
call dgemm('T', 'N', p, p, n, 1.d0, temp, n, temp, n,
* 0.d0, W(:,:,k), p)
* compute covariance matrix
S(:,:,k) = W(:,:,k)/sumZ(k)
end do
return
end
************************************************************************
**** EVV model
************************************************************************
* ======================================================================
subroutine msevv (x,z, n,p,G, mu,O,U,scale,shape,pro, lwork,info,
* eps)
* Maximization step for model EEV
* ======================================================================
implicit none
integer :: n, p, G
double precision :: x(n,p), z(n,G)
double precision :: mu(p,G), O(p,p,*), U(p,p,*), pro(G)
double precision :: scale(G), shape(p,G)
double precision :: sumz(G)
integer :: i, j, k, info, lwork, dummy, l
double precision :: temp(p), wrk(lwork), eps
double precision :: FLMAX
parameter (FLMAX = 1.7976931348623157d308)
*
* double precision :: BIGLOG
* parameter (BIGLOG = 709.d0)
*
* double precision :: SMALOG
* parameter (SMALOG = -708.d0)
*-----------------------------------------------------------------------
* colsums of z
sumz = sum(z, dim = 1)
* a priori probabilities
pro = sumz / dble(n)
* pro = sumz / sum(sumz)
* if there is noise sum(sumz) does not sum to n. See help(mstep)
do k = 1,G
do j = 1,p
mu(j,k) = sum(x(:,j)*z(:,k))/sumz(k)
end do
do i = 1,n
temp = ( x(i,:) - mu(:,k) ) * sqrt(z(i,k))
* U(:,:,k) = U(:,:,k) +
* * spread(temp, dim = 2, ncopies = p)*
* * spread(temp, dim = 1, ncopies = p)
* outer product, Press et al. (1992), p. 970
call dger(p, p, 1.d0, temp, 1, temp, 1, U(:,:,k), p)
* more efficient
end do
* U contains the weighted scattering matrix
O(:,:,k) = U(:,:,k)
* call dgesvd('O', 'N', p, p, O(:,:,k), p, shape(:,k),
* * dummy, 1, dummy, 1, wrk, lwork, info)
call dgesvd('N', 'O', p, p, O(:,:,k), p, shape(:,k),
* dummy, 1, dummy, 1, wrk, lwork, info)
* O now contains eigenvectors of the scattering matrix
* ##### NOTE: O is transposed
* shape contains the eigenvalues
* check if dgesvd converged (info == 0)
if (info .ne. 0) then
l = info
else
scale(k) = exp( sum( log(shape(:,k)) ) )**(1.d0/p)
call dscal(p*p, 1.d0/scale(k), U(:,:,k), 1)
call dscal(p, 1.d0/scale(k), shape(:,k), 1)
* now U is the matrix Ck (Celeux, Govaert 1995, p.787)
* and shape is the proper scaled shape (matrix A)
end if
end do
* check very small eigenvalues (singular covariance)
if (minval(shape) .le. sqrt(eps) .or.
* minval(scale) .le. sqrt(eps)) then
shape = FLMAX
scale = FLMAX
return
end if
scale(1) = sum(scale) / sum(sumz)
return
end
* ======================================================================
subroutine esevv (x,z, n,p,G,Gnoise, mu,O,scale,shape,pro, Vinv,
* loglik, eps)
* Expectation step for model EVV
* ======================================================================
implicit none
integer :: n, p, G, Gnoise
double precision :: x(n,p), z(n,Gnoise)
double precision :: mu(p,G), O(p,p,G), scale, shape(p,G)
double precision :: Vinv, pro(Gnoise)
double precision :: temp1(p), temp2(p), temp3
integer :: i, k, j
double precision :: const, logdet, loglik, eps
double precision :: log2pi
parameter (log2pi = 1.837877066409345d0)
double precision :: FLMAX
parameter (FLMAX = 1.7976931348623157d308)
external :: ddot
double precision :: ddot
* double precision :: smalog
* parameter (smalog = -708.d0)
*-----------------------------------------------------------------------
* check very small eigenvalues (singular covariance)
if (minval(shape) .le. sqrt(eps) .or. scale .le. sqrt(eps)) then
loglik = FLMAX
return
end if
const = (-dble(p)/2.d0)*log2pi
do k = 1,G
logdet = 0.d0
do j = 1,p
logdet = logdet + ( log(shape(j,k)) + log(scale) )
end do
* compute mahalanobis distance for each observation
* ##### NOTE: O is transposed
do i = 1,n
temp1 = ( x(i,:) - mu(:,k) )
call dcopy(p, 0.d0, 0, temp2, 1)
call dgemv('N', p, p, 1.d0,
* O(:,:,k), p, temp1, 1, 0.d0, temp2, 1)
temp2 = temp2/sqrt(scale*shape(:,k))
temp3 = ddot(p, temp2, 1, temp2, 1)
* temp3 contains the mahalanobis distance
* z(i,k) = const - logdet/2.d0 - temp3/2.d0 + log(pro(k))
z(i,k) = const - logdet/2.d0 - temp3/2.d0
* help(cdens) --> The densities are not scaled by mixing proportions
end do
* z contains the log-density log(N(x|theta_k))
end do
if ( pro(1) .lt. 0.d0 ) return
* cdens function
* noise component
if (Vinv .gt. 0.d0) then
call dcopy( n, log(Vinv), 0, z(:,Gnoise), 1)
end if
* now column Gnoise of z contains log(Vinv)
do i = 1,n
z(i,:) = z(i,:) + log( pro(:) )
* Numerical Recipes pag.844
temp3 = maxval(z(i,:))
temp1(1) = temp3 + log( sum(exp(z(i,:) - temp3)) )
loglik = loglik + temp1(1)
* ##### NOTE: do we need to check if (z - zmax) is too small?
z(i,:) = exp( z(i,:) - temp1(1) )
* re-normalize probabilities
temp3 = sum( z(i,:) )
call dscal( Gnoise, 1.d0/temp3, z(i,:), 1 )
end do
return
end
* ======================================================================
subroutine meevv (x,z, n,p,G,Gnoise, mu,O,U,scale,shape,pro,Vinv,
* loglik, eqpro,itmax,tol,eps,
* niterout,errout,lwork,info)
* Maximization-expectation algorithm for model EVV
* ======================================================================
implicit none
logical :: eqpro
integer :: n, p, G, Gnoise
double precision :: x(n,p), z(n,Gnoise)
double precision :: mu(p,G), O(p,p,G),scale(G),shape(p,G)
double precision :: Vinv, pro(Gnoise)
double precision :: U(p,p,G), sumz(Gnoise)
double precision :: temp1(p), temp2(p), temp3, scsh(p)
* double precision :: temp(*)
integer :: i, j, k, info, lwork, dummy, l, itmax, niterout
double precision :: tol, eps, errout, rteps
double precision :: const, logdet, loglik, lkprev, wrk(lwork)
double precision :: log2pi
parameter (log2pi = 1.837877066409345d0)
double precision :: FLMAX
parameter (FLMAX = 1.7976931348623157d308)
external :: ddot
double precision :: ddot
* double precision :: smalog
* parameter (smalog = -708.d0)
*-----------------------------------------------------------------------
l = 0
rteps = sqrt(eps)
niterout = 0
errout = FLMAX
lkprev = FLMAX/2
loglik = FLMAX
const = (-dble(p)/2.d0)*log2pi
* WHILE loop using goto statement
100 continue
niterout = niterout + 1
sumz = sum(z, dim = 1)
if ( eqpro ) then
if ( Vinv .gt. 0 ) then
pro(Gnoise) = sumz(Gnoise) / dble(n)
pro(1:G) = ( 1 - pro(Gnoise) ) / dble(G)
sumz = pro * dble(n)
else
pro = 1 / dble(G)
sumz = pro * dble(n)
end if
else
pro = sumz / dble(n)
end if
* re-initialise U
call dcopy(p*p*G, 0.d0, 0, U, 1)
* M step..........................................................
do k = 1,G
do j = 1,p
mu(j,k) = sum(x(:,j)*z(:,k))/sumz(k)
end do
do i = 1,n
temp1 = ( x(i,:) - mu(:,k) ) * sqrt(z(i,k))
call dger(p, p, 1.d0, temp1, 1, temp1, 1, U(:,:,k), p)
end do
* U contains the weighted scattering matrix
O(:,:,k) = U(:,:,k)
call dgesvd('N', 'O', p, p, O(:,:,k), p, shape(:,k),
* dummy, 1, dummy, 1, wrk, lwork, info)
* O now contains eigenvectors of the scattering matrix
* ##### NOTE: O is transposed
* shape contains the eigenvalues
* check if dgesvd converged (info == 0)
if (info .ne. 0) then
l = info
return
else
scale(k) = exp( sum( log(shape(:,k)) ) )**(1.d0/dble(p))
call dscal(p*p, 1.d0/scale(k), U(:,:,k), 1)
call dscal(p, 1.d0/scale(k), shape(:,k), 1)
* now U is the matrix Ck (Celeux, Govaert 1995, p.787)
* and shape is the proper scaled shape (matrix A)
end if
end do
if ( Vinv .gt. 0.d0 ) then
scale(1) = sum(scale) / sum(sumz(1:G))
else
scale(1) = sum(scale)/dble(n)
end if
* if noise lambda = num/sum_{k=1}^{G} n_k; pag. 787 Celeux, Govaert
* ................................................................
* check very small eigenvalues (singular covariance)
if (minval(shape) .le. rteps .or. minval(scale) .le. rteps) then
loglik = FLMAX
return
end if
* E step..........................................................
do k = 1,G
logdet = 0.d0
do j = 1,p
logdet = logdet + ( log(shape(j,k)) + log(scale(1)) )
end do
* compute mahalanobis distance for each observation
* ##### NOTE: O is transposed
scsh = sqrt(scale(1)*shape(:,k))
do i = 1,n
temp1 = ( x(i,:) - mu(:,k) )
call dcopy(p, 0.d0, 0, temp2, 1)
call dgemv('N', p, p, 1.d0,
* O(:,:,k), p, temp1, 1, 0.d0, temp2, 1)
temp2 = temp2/scsh
temp3 = ddot(p, temp2, 1, temp2, 1)
* temp3 contains the mahalanobis distance
z(i,k) = const - logdet/2.d0 - temp3/2.d0 + log(pro(k))
end do
* z contains the log-density log(N(x|theta_k)) + log(p_k)
end do
* noise component
if (Vinv .gt. 0.d0) then
* call dcopy( n, log(Vinv) + log(pro(Gnoise)), 0, z(:,Gnoise), 1)
z(:,Gnoise) = log(Vinv) + log( pro(Gnoise) )
end if
* now column Gnoise of z contains log(Vinv) + log(p_0)
* with p_0 the proportion of noise
loglik = 0.d0
do i = 1,n
* Numerical Recipes pag.844
temp3 = maxval(z(i,:))
temp1(1) = temp3 + log( sum(exp(z(i,:) - temp3)) )
loglik = loglik + temp1(1)
* ##### NOTE: do we need to check if (z - zmax) is too small?
z(i,:) = exp( z(i,:) - temp1(1) )
* re-normalize probabilities
temp3 = sum( z(i,:) )
call dscal( Gnoise, 1.d0/temp3, z(i,:), 1 )
end do
* ................................................................
errout = abs(loglik - lkprev)/(1.d0 + abs(loglik))
* errout = abs(loglik - lkprev)
lkprev = loglik
* temp(niterout) = loglik
* Chris F (June 2015): pro should not be computed in the E-step
* sumz = sum(z, dim = 1)
* if ( eqpro ) then
* if ( Vinv .gt. 0 ) then
* pro(Gnoise) = sumz(Gnoise) / dble(n)
* pro(1:G) = ( 1 - pro(Gnoise) ) / dble(G)
* sumz = pro * dble(n)
* else
* pro = 1 / dble(G)
* sumz = pro * dble(n)
* end if
* else
* pro = sumz / dble(n)
* end if
* check if empty components
* if ( minval(pro) .lt. rteps ) then
if ( any(sumz .lt. rteps, 1) ) then
loglik = -FLMAX
return
end if
* WHILE condition
if ( errout .gt. tol .and. niterout .lt. itmax ) goto 100
return
end
************************************************************************
**** VEE model
************************************************************************
* ======================================================================
subroutine msvee (x,z, n,p,G, mu,U,C,scale,pro, lwork,info,
* itmax,tol, niterin,errin, eps)
* Maximization step for model VEE
* ======================================================================
implicit none
integer :: n, p, G
double precision :: x(n,p), z(n,G)
double precision :: mu(p,G), U(p,p,G), C(p,p), pro(G)
* ### NOTE: shape and orientation parameters are computed in R
double precision :: scale(G)
double precision :: sumz(G)
integer :: i, j, k, info, lwork, dummy, l
double precision :: temp1(p), temp2(p,p), temp3
double precision :: wrk(lwork), tol, errin, trgt, trgtprev, eps
integer :: itmax, niterin
double precision :: FLMAX
parameter (FLMAX = 1.7976931348623157d308)
external :: ddot
double precision :: ddot
*-----------------------------------------------------------------------
* colsums of z
sumz = sum(z, dim = 1)
* a priori probabilities
pro = sumz / dble(n)
* pro = sumz / sum(sumz)
* if there is noise sum(sumz) does not sum to n. See help(mstep)
* compute weighted scattering matrix and means
do k = 1,G
do j = 1,p
mu(j,k) = sum(x(:,j)*z(:,k))/sumz(k)
end do
do i = 1,n
temp1 = ( x(i,:) - mu(:,k) ) * sqrt(z(i,k))
call dger(p, p, 1.d0, temp1, 1, temp1, 1, U(:,:,k), p)
end do
* U contains the weighted scattering matrix
* check if U is positive definite (see help of dpotrf)
* (through Choleski is more efficient)
temp2 = U(:,:,k)
call dpotrf('U', p, temp2, p, info)
if ( info .ne. 0 ) then
if ( info .lt. 0) then
l = info
return
else if ( info .gt. 0 ) then
info = 0
scale = FLMAX
return
end if
end if
end do
* covariance matrix components estimation
niterin = 0
errin = FLMAX
trgt = FLMAX
trgtprev = FLMAX/2
* WHILE loop using goto statement
100 continue
niterin = niterin + 1
* initialise C
call dcopy(p*p, 0.d0, 0, C, 1)
* ### NOTE: scale is initialised in R
do k = 1,G
C = C + U(:,:,k)/scale(k)
end do
* C contains the numerator of matrix C in pag.785, Celeux, Govaert
temp2 = C
call dsyev('N', 'U', p, temp2, p, temp1, wrk, lwork, info)
temp1 = temp1(p:1:-1)
* temp1 contains the (decreasing) ordered eigenvalues of C
* check if dsyev converged or illegal value
if ( info .ne. 0 ) then
l = info
return
end if
temp3 = exp( sum(log(temp1)) )**(1/dble(p))
* temp3 is the denominator of C
C = C/temp3
* C is now the actual matrix C of pag.785
* compute the inverse of C via Choleski
temp2 = C
call dpotrf('U', p, temp2, p, info)
if ( info .ne. 0 ) then
if ( info .lt. 0) then
l = info
return
else if ( info .gt. 0 ) then
info = 0
scale = FLMAX
return
end if
end if
call dpotri('U', p, temp2, p, info)
if ( info .ne. 0 ) return
do j = 2,p
do k = 1,(j-1)
temp2(j,k) = temp2(k,j)
end do
end do
* temp2 is now the inverse of C
scale = 0.d0
do k = 1,G
do j = 1,p
scale(k) = scale(k) + ddot(p, U(j,:,k), 1, temp2(:,j), 1)
end do
scale(k) = scale(k) / (dble(p)*sumz(k))
end do
* scale contains now the lambdas (pag.784 of Celeux, Govaert)
* evaluate target function
* trgt = dble(n)*dble(p) + dble(p)*SUM(log(scale)*sumz)
trgt = sum(sumz)*dble(p) + dble(p)*SUM(log(scale)*sumz)
* error
errin = abs(trgt - trgtprev)/(1.d0 + abs(trgt))
trgtprev = trgt
* WHILE condition
if ( errin .gt. tol .and. niterin .lt. itmax ) goto 100
return
end
* ======================================================================
subroutine esvee (x,z, n,p,G,Gnoise, mu,O,scale,shape,pro, Vinv,
* loglik, eps)
* Expectation step for model VEE
* ======================================================================
implicit none
integer :: n,p,G,Gnoise
double precision :: x(n,p), z(n,Gnoise), pro(Gnoise), Vinv
double precision :: mu(p,G), O(p,p), scale(G), shape(p)
double precision :: temp1(p), temp2(p), temp3
integer :: i, k, j
double precision :: const, logdet, loglik, eps
double precision :: log2pi
parameter (log2pi = 1.837877066409345d0)
double precision :: FLMAX
parameter (FLMAX = 1.7976931348623157d308)
external :: ddot
double precision :: ddot
* double precision :: smalog
* parameter (smalog = -708.d0)
*-----------------------------------------------------------------------
* check very small eigenvalues (cannot compute E step)
if ( minval(shape) .le. sqrt(eps) .or.
* minval(scale) .le. sqrt(eps) ) then
loglik = FLMAX
return
end if
const = (-dble(p)/2.d0)*log2pi
do k = 1,G
logdet = 0.d0
do j = 1,p
logdet = logdet + ( log(shape(j)) + log(scale(k)) )
end do
* compute mahalanobis distance for each observation
* ##### NOTE: O is transposed
do i = 1,n
temp1 = ( x(i,:) - mu(:,k) )
call dcopy(p, 0.d0, 0, temp2, 1)
call dgemv('N', p, p, 1.d0,
* O, p, temp1, 1, 0.d0, temp2, 1)
temp2 = temp2/sqrt(scale(k)*shape)
temp3 = ddot(p, temp2, 1, temp2, 1)
* temp3 contains the mahalanobis distance
* z(i,k) = const - logdet/2.d0 - temp3/2.d0 + log(pro(k))
z(i,k) = const - logdet/2.d0 - temp3/2.d0
* help(cdens) --> The densities are not scaled by mixing proportions
end do
* z contains the log-density log(N(x|theta_k))
end do
if ( pro(1) .lt. 0.d0 ) return
* cdens function
* noise component
if (Vinv .gt. 0.d0) then
call dcopy( n, log(Vinv), 0, z(:,Gnoise), 1)
end if
* now column Gnoise of z contains log(Vinv)
do i = 1,n
z(i,:) = z(i,:) + log( pro(:) )
* Numerical Recipes pag.844
temp3 = maxval(z(i,:))
temp1(1) = temp3 + log( sum(exp(z(i,:) - temp3)) )
loglik = loglik + temp1(1)
z(i,:) = exp( z(i,:) - temp1(1) )
* re-normalize probabilities
temp3 = sum( z(i,:) )
call dscal( Gnoise, 1.d0/temp3, z(i,:), 1 )
end do
return
end
* ======================================================================
subroutine mevee ( x,z, n,p,G,Gnoise, mu,C,U,scale,shape,pro,Vinv,
* loglik, eqpro,itmaxin,tolin,itmaxout,tolout,eps,
* niterin,errin,niterout,errout,lwork,info )
* Maximization-expectation algorithm for model VEE
* ======================================================================
implicit none
logical :: eqpro
integer :: n,p,G,Gnoise
double precision :: x(n,p), z(n,Gnoise), pro(Gnoise), Vinv
double precision :: mu(p,G), C(p,p), scale(G), shape(p)
double precision :: U(p,p,G), sumz(Gnoise)
double precision :: temp1(p), temp2(p,p), temp3, temp4(p)
integer :: i, j, k, info, lwork, dummy, l
integer :: itmaxin, itmaxout, niterin, niterout
double precision :: tolin, tolout, errin, errout, eps, rteps
double precision :: const, logdet, loglik, lkprev, wrk(lwork)
double precision :: trgt, trgtprev
double precision :: log2pi
parameter (log2pi = 1.837877066409345d0)
double precision :: FLMAX
parameter (FLMAX = 1.7976931348623157d308)
external :: ddot
double precision :: ddot
* double precision :: smalog
* parameter (smalog = -708.d0)
*-----------------------------------------------------------------------
l = 0
rteps = sqrt(eps)
niterout = 0
errout = FLMAX
lkprev = FLMAX/2
loglik = FLMAX
const = (-dble(p)/2.d0)*log2pi
* WHILE loop for EM algorithm
100 continue
niterout = niterout + 1
sumz = sum(z, dim = 1)
if ( eqpro ) then
if ( Vinv .gt. 0 ) then
pro(Gnoise) = sumz(Gnoise) / dble(n)
pro(1:G) = ( 1 - pro(Gnoise) ) / dble(G)
sumz = pro * dble(n)
else
pro = 1 / dble(G)
sumz = pro * dble(n)
end if
else
pro = sumz / dble(n)
end if
* re-initialise U
call dcopy(p*p*G, 0.d0, 0, U, 1)
* compute weighted scattering matrix and means
do k = 1,G
do j = 1,p
mu(j,k) = sum(x(:,j)*z(:,k))/sumz(k)
end do
do i = 1,n
temp1 = ( x(i,:) - mu(:,k) ) * sqrt(z(i,k))
call dger(p, p, 1.d0, temp1, 1, temp1, 1, U(:,:,k), p)
end do
* U contains the weighted scattering matrix
* check if U is positive definite (see help of dpotrf)
* (through Choleski is more efficient)
temp2 = U(:,:,k)
call dpotrf('U', p, temp2, p, info)
if ( info .ne. 0 ) then
if ( info .lt. 0) then
l = info
return
else if ( info .gt. 0 ) then
info = 0
loglik = FLMAX
return
end if
end if
end do
* M step..........................................................
* covariance matrix components estimation
niterin = 0
errin = FLMAX
trgt = FLMAX
trgtprev = FLMAX/2
* initialise scale
call dcopy(G, 1.d0, 0, scale, 1)
* WHILE loop for M step
110 continue
niterin = niterin + 1
* initialise C
call dcopy(p*p, 0.d0, 0, C, 1)
do k = 1,G
C = C + U(:,:,k)/scale(k)
end do
* C contains the numerator of matrix C in pag.785, Celeux, Govaert
temp2 = C
call dsyev('N', 'U', p, temp2, p, temp1, wrk, lwork, info)
temp1 = temp1(p:1:-1)
* temp1 contains the (decreasing) ordered eigenvalues of C
* check if dsyev converged or illegal value
if ( info .ne. 0 ) then
l = info
return
end if
temp3 = exp( sum(log(temp1)) )**(1/dble(p))
* temp3 is the denominator of C
C = C/temp3
* C is now the actual matrix C of pag.785
* compute the inverse of C via Choleski
temp2 = C
call dpotrf('U', p, temp2, p, info)
if ( info .ne. 0 ) then
if ( info .lt. 0) then
l = info
return
else if ( info .gt. 0 ) then
info = 0
loglik = FLMAX
return
end if
end if
call dpotri('U', p, temp2, p, info)
if ( info .ne. 0 ) return
do j = 2,p
do k = 1,(j-1)
temp2(j,k) = temp2(k,j)
end do
end do
* temp2 is now the inverse of C
scale = 0.d0
do k = 1,G
do j = 1,p
scale(k) = scale(k) + ddot(p, U(j,:,k), 1, temp2(:,j), 1)
end do
scale(k) = scale(k) / (dble(p)*sumz(k))
end do
* scale contains now the lambdas (pag.784 of Celeux, Govaert)
* evaluate target function
* trgt = dble(n)*dble(p) + dble(p)*SUM(log(scale)*sumz)
trgt = sum(sumz(1:G))*dble(p) + dble(p)*SUM(log(scale)*sumz(1:G))
* error
errin = abs(trgt - trgtprev)/(1.d0 + abs(trgt))
trgtprev = trgt
* WHILE condition for M step
if ( errin .gt. tolin .and. niterin .lt. itmaxin ) goto 110
* ................................................................
* eigenvalues of C
shape = temp1 / temp3
* check very small eigenvalues (singular covariance)
if (minval(shape) .le. rteps .or. minval(scale) .le. rteps) then
loglik = FLMAX
return
end if
* E step..........................................................
do k = 1,G
logdet = 0.d0
do j = 1,p
logdet = logdet + log(shape(j)) + log(scale(k))
end do
* compute mahalanobis distance for each observation
do i = 1,n
temp1 = ( x(i,:) - mu(:,k) )
call dcopy(p, 0.d0, 0, temp4, 1)
call dgemv('N', p, p, 1.d0,
* temp2, p, temp1, 1, 0.d0, temp4, 1)
temp4 = temp4/scale(k)
temp3 = ddot(p, temp4, 1, temp1, 1)
* temp3 contains the mahalanobis distance
z(i,k) = const - logdet/2.d0 - temp3/2.d0 + log(pro(k))
* z(i,k) = const - logdet/2.d0 - temp3/2.d0
end do
* z contains the log-density log(N(x|theta_k)) + log(p_k)
end do
* if ( pro(1) .lt. 0.d0 ) return
* cdens function
* noise component
if (Vinv .gt. 0.d0) then
z(:,Gnoise) = log(Vinv) + log( pro(Gnoise) )
end if
* now column Gnoise of z contains log(Vinv) + log(p_0)
* with p_0 the proportion of noise
loglik = 0.d0
do i = 1,n
* Numerical Recipes pag.844
temp3 = maxval(z(i,:))
temp1(1) = temp3 + log( sum(exp(z(i,:) - temp3)) )
loglik = loglik + temp1(1)
z(i,:) = exp( z(i,:) - temp1(1) )
* re-normalize probabilities
temp3 = sum( z(i,:) )
call dscal( Gnoise, 1.d0/temp3, z(i,:), 1 )
end do
* ................................................................
errout = abs(loglik - lkprev)/(1.d0 + abs(loglik))
* errout = abs(loglik - lkprev)
lkprev = loglik
* temp(niterout) = loglik
* Chris F (June 2015): pro should not be computed in the E-step
* sumz = sum(z, dim = 1)
* if ( eqpro ) then
* if ( Vinv .gt. 0 ) then
* pro(Gnoise) = sumz(Gnoise) / dble(n)
* pro(1:G) = ( 1 - pro(Gnoise) ) / dble(G)
* sumz = pro * dble(n)
* else
* pro = 1 / dble(G)
* sumz = pro * dble(n)
* end if
* else
* pro = sumz / dble(n)
* end if
* check if empty components
if ( minval(sumz) .lt. rteps ) then
loglik = -FLMAX
return
end if
* WHILE condition EM
if ( errout .gt. tolout .and. niterout .lt. itmaxout ) goto 100
return
end
************************************************************************
**** EVE model
************************************************************************
* ======================================================================
subroutine mseve (x,z, n,p,G, mu,U,O,scale,shape,pro, lwork,info,
* itmax,tol, niterin,errin, eps)
* Maximization step for model EVE
* ======================================================================
implicit none
integer :: n, p, G
double precision :: x(n,p), z(n,G)
double precision :: mu(p,G), U(p,p,G), pro(G), O(p,p)
double precision :: scale, shape(p,G)
double precision :: sumz(G), omega(G)
integer :: i, j, k, info, lwork
double precision :: temp1(p,p), temp2(p,p), temp3(p,p), temp4(p)
double precision :: wrk(lwork), tol, errin, trgt, trgtprev, eps
integer :: itmax, niterin
double precision :: FLMAX
parameter (FLMAX = 1.7976931348623157d308)
external :: ddot
double precision :: ddot
*-----------------------------------------------------------------------
* colsums of z
sumz = sum(z, dim = 1)
* a priori probabilities
pro = sumz / dble(n)
* pro = sumz / sum(sumz)
* if there is noise sum(sumz) does not sum to n. See help(mstep)
* compute weighted scattering matrix and means
do k = 1,G
do j = 1,p
mu(j,k) = sum(x(:,j)*z(:,k))/sumz(k)
end do
do i = 1,n
temp1(:,1) = ( x(i,:) - mu(:,k) ) * sqrt(z(i,k))
call dger(p, p, 1.d0, temp1(:,1), 1, temp1(:,1), 1,
* U(:,:,k), p)
end do
* U contains the weighted scattering matrix
* compute the eigenvalues of U to be stored in omega
temp2 = U(:,:,k)
call dsyev('N', 'U', p, temp2, p, temp1(:,1), wrk, lwork, info)
* now temp1 contains all the eigenvalues of U
* check if dsyev converged and positive definite
if ( info .ne. 0 ) then
return
else
if ( minval(temp1(:,1)) .lt. sqrt(eps) ) then
info = 0
scale = FLMAX
return
end if
end if
omega(k) = temp1(p,1)
end do
* omega contains the largest eigenvalue of each scattering matrix
niterin = 0
errin = FLMAX
trgt = FLMAX
trgtprev = FLMAX/2
* covariance matrix components estimation
* we consider algorithm MM 1 and MM 2 of Browne, McNicholas 2013
* with a modification in computing the orientation matrix in the MM 2 step
* shape (matrix A) and orientation (matrix D) initialised in R
* shape = matrix(1, p,G)
* O = diag(p)
* WHILE loop using goto statement
100 continue
* ### NOTE: O is transposed
niterin = niterin + 1
temp2 = 0.d0
temp3 = 0.d0
* temp3 will contain matrix F
* Algorithm MM 1 ......................................
do k = 1,G
do j = 1,p
* temp1(j,:) = O(:,j) / shape(j,k)
temp1(j,:) = O(j,:) / shape(j,k)
end do
* temp1 contains inv(A)t(D)
call dgemm( 'N','N', p,p,p, 1.d0, temp1,p, U(:,:,k),p,
* 0.d0, temp2,p )
* temp2 contains inv(A) %*% t(D) %*% W
temp1 = temp2 - omega(k)*temp1
temp3 = temp3 + temp1
* temp3 contains the matrix F
end do
* compute matrices P and R where svd(F) = P %*% B %*% t(R)
call dgesvd('A','A', p,p, temp3,p, temp4, temp1,p, temp2,p,
* wrk, lwork, info)
* now temp1 contains matrix P, temp2 contains matrix t(R)
* temp4 contains the singular values
* check if dgesvd converged
if ( info .ne. 0 ) return
* NOTE: t(O) = t( R %*% t(P) ) = P %*% t(R)
call dgemm( 'N','N', p,p,p, 1.d0, temp1,p, temp2,p,
* 0.d0, O,p )
* O contains TRANSPOSED matrix D of Browne, McNicholas
* .....................................................
* Algorithm MM 2 ......................................
* call dgemm( 'T','T', p,p,p, 1.d0, temp2,p, temp1,p,
* * 0.d0, O,p )
call transpose(O, p)
* O contains matrix D of Browne, McNicholas
* Algorithm MM 2
temp1 = 0.d0
temp3 = 0.d0
do k = 1,G
call dgemm( 'N','N', p,p,p, 1.d0, U(:,:,k),p, O,p,
* 0.d0, temp1,p )
* temp1 contains W %*% D
do j = 1,p
temp2(:,j) = temp1(:,j) / shape(j,k)
end do
* temp2 contains W %*% D %*% inv(A)
temp1 = temp2 - maxval( 1/shape(:,k) )*temp1
temp3 = temp3 + temp1
* temp3 contains the matrix F
end do
* compute matrices P and R where svd(F) = P %*% B %*% t(R)
call dgesvd('A','A', p,p, temp3,p, temp4, temp1,p, temp2,p,
* wrk, lwork, info)
* now temp1 contains matrix P, temp2 contains matrix t(R)
* temp4 contains the singular values
* check if dgesvd converged
if ( info .ne. 0 ) return
* NOTE: t(O) = R %*% t(P)
* call dgemm( 'T','T', p,p,p, 1.d0, temp2,p, temp1,p,
* * 0.d0, O,p )
O = 0.d0
call dgemm( 'N','N', p,p,p, 1.d0, temp1,p, temp2,p,
* 0.d0, O,p )
* NOTE: we compute the TRANSPOSED of the matrix in the output in the paper
call transpose(O, p)
* O contains TRANSPOSED matrix D of Browne, McNicholas
* .....................................................
* compute shape (matrix A) and target function
trgt = 0.d0
do k = 1,G
temp1 = 0.d0
call dgemm( 'N','N', p,p,p, 1.d0, O,p, U(:,:,k),p,
* 0.d0, temp1,p )
* temp1 contains t(D) %*% W
do j = 1,p
shape(j,k) = ddot(p, temp1(j,:), 1, O(j,:), 1)
end do
shape(:,k) = shape(:,k)/
* exp( sum( log(shape(:,k)) ) )**(1.d0/dble(p))
* now shape contains matrix A of Celeux, Govaert pag. 785
* check positive values
if ( minval(shape(:,k)) .lt. sqrt(eps) ) then
info = 0
shape = FLMAX
return
end if
temp4(1) = 0.d0
do j = 1,p
* temp2(:,j) = O(:,j) * 1.d0/shape(j,k)
temp2(:,j) = O(j,:) * 1.d0/shape(j,k)
temp4(1) = temp4(1) + ddot(p, temp1(j,:), 1, temp2(:,j), 1)
end do
trgt = trgt + temp4(1)
end do
* error
errin = abs(trgt - trgtprev)/(1.d0 + abs(trgt))
trgtprev = trgt
* WHILE condition
if ( errin .gt. tol .and. niterin .lt. itmax ) goto 100
scale = trgt / ( sum(sumz)*dble(p) )
return
end
* ======================================================================
subroutine eseve (x,z, n,p,G,Gnoise, mu,O,scale,shape,pro, Vinv,
* loglik, eps)
* Expectation step for model EVE
* ======================================================================
implicit none
integer :: n, p, G, Gnoise
double precision :: x(n,p), z(n,Gnoise)
double precision :: mu(p,G), O(p,p), scale, shape(p,G)
double precision :: Vinv, pro(Gnoise)
double precision :: temp1(p), temp2(p), temp3, temp4(n)
integer :: i, k, j
double precision :: const, logdet, loglik, eps
double precision :: log2pi
parameter (log2pi = 1.837877066409345d0)
double precision :: FLMAX
parameter (FLMAX = 1.7976931348623157d308)
external :: ddot
double precision :: ddot
* double precision :: smalog
* parameter (smalog = -708.d0)
*-----------------------------------------------------------------------
* check very small eigenvalues (singular covariance)
if (minval(shape) .le. sqrt(eps) .or. scale .le. sqrt(eps)) then
loglik = FLMAX
return
end if
const = (-dble(p)/2.d0)*log2pi
do k = 1,G
logdet = 0.d0
do j = 1,p
logdet = logdet + ( log(shape(j,k)) + log(scale) )
end do
* compute mahalanobis distance for each observation
* ##### NOTE: O is transposed
do i = 1,n
temp1 = ( x(i,:) - mu(:,k) )
call dcopy(p, 0.d0, 0, temp2, 1)
call dgemv('N', p, p, 1.d0,
* O, p, temp1, 1, 0.d0, temp2, 1)
temp2 = temp2/sqrt(scale*shape(:,k))
temp3 = ddot(p, temp2, 1, temp2, 1)
temp4(i) = temp3
* temp3 contains the mahalanobis distance
* z(i,k) = const - logdet/2.d0 - temp3/2.d0 + log(pro(k))
z(i,k) = const - logdet/2.d0 - temp3/2.d0
* help(cdens) --> The densities are not scaled by mixing proportions
end do
* z contains the log-density log(N(x|theta_k))
end do
if ( pro(1) .lt. 0.d0 ) return
* cdens function
* noise component
if (Vinv .gt. 0.d0) then
call dcopy( n, log(Vinv), 0, z(:,Gnoise), 1)
end if
* now column Gnoise of z contains log(Vinv)
do i = 1,n
z(i,:) = z(i,:) + log( pro )
* Numerical Recipes pag.844
temp3 = maxval(z(i,:))
temp1(1) = temp3 + log( sum(exp(z(i,:) - temp3)) )
loglik = loglik + temp1(1)
* ##### NOTE: do we need to check if (z - zmax) is too small?
z(i,:) = exp( z(i,:) - temp1(1) )
* re-normalize probabilities
temp3 = sum( z(i,:) )
call dscal( Gnoise, 1.d0/temp3, z(i,:), 1 )
end do
return
end
* ======================================================================
subroutine meeve ( x,z, n,p,G,Gnoise, mu,O,U,scale,shape,pro,Vinv,
* loglik, eqpro,itmaxin,tolin,itmaxout,tolout,eps,
* niterin,errin,niterout,errout,lwork,info )
* Maximization-expectation algorithm for model EVE
* ======================================================================
implicit none
logical :: eqpro
integer :: n,p,G,Gnoise
double precision :: x(n,p), z(n,Gnoise), pro(Gnoise), Vinv
double precision :: mu(p,G), O(p,p), scale, shape(p,G)
double precision :: U(p,p,G), sumz(Gnoise), omega(G)
double precision :: temp1(p,p), temp2(p,p), temp3(p,p), temp4(p)
integer :: i, j, k, info, lwork
integer :: itmaxin, itmaxout, niterin, niterout
double precision :: tolin, tolout, errin, errout, eps, rteps
double precision :: const, logdet, loglik, lkprev, wrk(lwork)
double precision :: trgt, trgtprev
double precision :: log2pi
parameter (log2pi = 1.837877066409345d0)
double precision :: FLMAX
parameter (FLMAX = 1.7976931348623157d308)
external :: ddot
double precision :: ddot
* double precision :: smalog
* parameter (smalog = -708.d0)
*-----------------------------------------------------------------------
rteps = sqrt(eps)
niterout = 0
errout = FLMAX
lkprev = FLMAX/2
loglik = FLMAX
const = (-dble(p)/2.d0)*log2pi
* WHILE loop for EM algorithm
100 continue
niterout = niterout + 1
sumz = sum(z, dim = 1)
if ( eqpro ) then
if ( Vinv .gt. 0 ) then
pro(Gnoise) = sumz(Gnoise) / dble(n)
pro(1:G) = ( 1 - pro(Gnoise) ) / dble(G)
sumz = pro * dble(n)
else
pro = 1 / dble(G)
sumz = pro * dble(n)
end if
else
pro = sumz / dble(n)
end if
* re-initialise U
call dcopy(p*p*G, 0.d0, 0, U, 1)
* compute weighted scattering matrix and means
do k = 1,G
do j = 1,p
mu(j,k) = sum(x(:,j)*z(:,k))/sumz(k)
end do
do i = 1,n
temp1(:,1) = ( x(i,:) - mu(:,k) ) * sqrt(z(i,k))
call dger(p, p, 1.d0, temp1(:,1), 1, temp1(:,1), 1,
* U(:,:,k), p)
end do
* U contains the weighted scattering matrix
* compute the eigenvalues of U to be stored in omega
temp2 = U(:,:,k)
call dsyev('N', 'U', p, temp2, p, temp1(:,1), wrk, lwork, info)
* now temp1 contains all the eigenvalues of U
* check if dsyev converged and positive definite
if ( info .ne. 0 ) then
return
else
if ( minval(temp1(:,1)) .lt. rteps ) then
info = 0
scale = FLMAX
return
end if
end if
omega(k) = temp1(p,1)
end do
* omega contains the largest eigenvalue of each scattering matrix
* M step..........................................................
niterin = 0
errin = FLMAX
trgt = FLMAX
trgtprev = FLMAX/2
* covariance matrix components estimation
* we consider algorithm MM 1 and MM 2 of Browne, McNicholas 2013
* with a modification in computing the orientation matrix in the MM 2 step
* shape (matrix A) and orientation (matrix D) initialised in R
* shape = matrix(1, p,G)
* O = diag(p)
* ### NOTE: we don't re-initialize shape and orientation at each
* outer iteration of the EM algorithm
* WHILE loop for M step
110 continue
* ### NOTE: O is transposed
niterin = niterin + 1
temp2 = 0.d0
temp3 = 0.d0
* temp3 will contain matrix F
* Algorithm MM 1 ......................................
do k = 1,G
do j = 1,p
* temp1(j,:) = O(:,j) / shape(j,k)
temp1(j,:) = O(j,:) / shape(j,k)
end do
* temp1 contains inv(A)t(D)
call dgemm( 'N','N', p,p,p, 1.d0, temp1,p, U(:,:,k),p,
* 0.d0, temp2,p )
* temp2 contains inv(A) %*% t(D) %*% W
temp1 = temp2 - omega(k)*temp1
temp3 = temp3 + temp1
* temp3 contains the matrix F
end do
* compute matrices P and R where svd(F) = P %*% B %*% t(R)
call dgesvd('A','A', p,p, temp3,p, temp4, temp1,p, temp2,p,
* wrk, lwork, info)
* now temp1 contains matrix P, temp2 contains matrix t(R)
* temp4 contains the singular values
* check if dgesvd converged
if ( info .ne. 0 ) return
* NOTE: t(O) = t( R %*% t(P) ) = P %*% t(R)
call dgemm( 'N','N', p,p,p, 1.d0, temp1,p, temp2,p,
* 0.d0, O,p )
* O contains TRANSPOSED matrix D of Browne, McNicholas
* .....................................................
* Algorithm MM 2 ......................................
* call dgemm( 'T','T', p,p,p, 1.d0, temp2,p, temp1,p,
* * 0.d0, O,p )
call transpose(O, p)
* O contains matrix D of Browne, McNicholas
* Algorithm MM 2
temp1 = 0.d0
temp3 = 0.d0
do k = 1,G
call dgemm( 'N','N', p,p,p, 1.d0, U(:,:,k),p, O,p,
* 0.d0, temp1,p )
* temp1 contains W %*% D
do j = 1,p
temp2(:,j) = temp1(:,j) / shape(j,k)
end do
* temp2 contains W %*% D %*% inv(A)
temp1 = temp2 - maxval( 1/shape(:,k) )*temp1
temp3 = temp3 + temp1
* temp3 contains the matrix F
end do
* compute matrices P and R where svd(F) = P %*% B %*% t(R)
call dgesvd('A','A', p,p, temp3,p, temp4, temp1,p, temp2,p,
* wrk, lwork, info)
* now temp1 contains matrix P, temp2 contains matrix t(R)
* temp4 contains the singular values
* check if dgesvd converged
if ( info .ne. 0 ) return
* NOTE: t(O) = R %*% t(P)
* call dgemm( 'T','T', p,p,p, 1.d0, temp2,p, temp1,p,
* * 0.d0, O,p )
O = 0.d0
* NOTE: we compute the TRANSPOSED of the matrix in the output in the paper
call dgemm( 'N','N', p,p,p, 1.d0, temp1,p, temp2,p,
* 0.d0, O,p )
call transpose(O, p)
* O contains TRANSPOSED matrix D of Browne, McNicholas
* .....................................................
* compute shape (matrix A) and target function
trgt = 0.d0
do k = 1,G
temp1 = 0.d0
call dgemm( 'N','N', p,p,p, 1.d0, O,p, U(:,:,k),p,
* 0.d0, temp1,p )
* temp1 contains t(D) %*% W
do j = 1,p
shape(j,k) = ddot(p, temp1(j,:), 1, O(j,:), 1)
end do
shape(:,k) = shape(:,k)/
* exp( sum( log(shape(:,k)) ) )**(1.d0/dble(p))
* now shape contains matrix A of Celeux, Govaert pag. 785
* check positive values
if ( minval(shape(:,k)) .lt. rteps ) then
info = 0
loglik = FLMAX
return
end if
temp4(1) = 0.d0
do j = 1,p
* temp2(:,j) = O(:,j) * 1.d0/shape(j,k)
temp2(:,j) = O(j,:) * 1.d0/shape(j,k)
temp4(1) = temp4(1) + ddot(p, temp1(j,:), 1, temp2(:,j), 1)
end do
trgt = trgt + temp4(1)
end do
* error
errin = abs(trgt - trgtprev)/(1.d0 + abs(trgt))
trgtprev = trgt
* WHILE condition M step
if ( errin .gt. tolin .and. niterin .lt. itmaxin ) goto 110
scale = trgt / ( sum(sumz(1:G))*dble(p) )
* ................................................................
* E step..........................................................
const = (-dble(p)/2.d0)*log2pi
do k = 1,G
logdet = 0.d0
do j = 1,p
logdet = logdet + ( log(shape(j,k)) + log(scale) )
end do
* compute mahalanobis distance for each observation
* ##### NOTE: O is transposed
do i = 1,n
temp1(:,1) = ( x(i,:) - mu(:,k) )
call dcopy(p, 0.d0, 0, temp2(:,1), 1)
call dgemv('N', p, p, 1.d0,
* O, p, temp1(:,1), 1, 0.d0, temp2(:,1), 1)
temp2(:,1) = temp2(:,1)/sqrt(scale*shape(:,k))
temp3(1,1) = ddot(p, temp2(:,1), 1, temp2(:,1), 1)
* temp3 contains the mahalanobis distance
z(i,k) = const - logdet/2.d0 - temp3(1,1)/2.d0 + log(pro(k))
* z(i,k) = const - logdet/2.d0 - temp3(1,1)/2.d0
end do
* z contains the log-density log(N(x|theta_k)) + log(p_k)
end do
* noise component
if (Vinv .gt. 0.d0) then
z(:,Gnoise) = log(Vinv) + log( pro(Gnoise) )
end if
* now column Gnoise of z contains log(Vinv) + log(p_0)
loglik = 0.d0
do i = 1,n
* Numerical Recipes pag.844
temp3(1,1) = maxval(z(i,:))
temp1(1,1) = temp3(1,1) + log( sum(exp(z(i,:) - temp3(1,1))) )
loglik = loglik + temp1(1,1)
* ##### NOTE: do we need to check if (z - zmax) is too small?
z(i,:) = exp( z(i,:) - temp1(1,1) )
* re-normalize probabilities
temp3(1,1) = sum( z(i,:) )
call dscal( Gnoise, 1.d0/temp3(1,1), z(i,:), 1 )
end do
* ................................................................
errout = abs(loglik - lkprev)/(1.d0 + abs(loglik))
lkprev = loglik
* Chris F (June 2015): pro should not be computed in the E-step
* sumz = sum(z, dim = 1)
* if ( eqpro ) then
* if ( Vinv .gt. 0 ) then
* pro(Gnoise) = sumz(Gnoise) / dble(n)
* pro(1:G) = ( 1 - pro(Gnoise) ) / dble(G)
* sumz = pro * dble(n)
* else
* pro = 1 / dble(G)
* sumz = pro * dble(n)
* end if
* else
* pro = sumz / dble(n)
* end if
* check if empty components
if ( minval(sumz) .lt. rteps ) then
loglik = -FLMAX
return
end if
* WHILE condition EM
if ( errout .gt. tolout .and. niterout .lt. itmaxout ) goto 100
return
end
************************************************************************
**** VVE model
************************************************************************
* ======================================================================
subroutine msvve (x,z, n,p,G, mu,U,O,scale,shape,pro, lwork,info,
* itmax,tol, niterin,errin, eps)
* Maximization step for model VVE
* ======================================================================
implicit none
integer :: n, p, G
double precision :: x(n,p), z(n,G)
double precision :: mu(p,G), U(p,p,G), pro(G), O(p,p)
double precision :: scale(G), shape(p,G)
double precision :: sumz(G), omega(G)
integer :: i, j, k, info, lwork
double precision :: temp1(p,p), temp2(p,p), temp3(p,p), temp4(p)
double precision :: wrk(lwork), tol, errin, trgt, trgtprev, eps
integer :: itmax, niterin
double precision :: FLMAX
parameter (FLMAX = 1.7976931348623157d308)
external :: ddot
double precision :: ddot
*-----------------------------------------------------------------------
* colsums of z
sumz = sum(z, dim = 1)
* a priori probabilities
pro = sumz / dble(n)
* pro = sumz / sum(sumz)
* if there is noise sum(sumz) does not sum to n. See help(mstep)
* compute weighted scattering matrix and means
do k = 1,G
do j = 1,p
mu(j,k) = sum(x(:,j)*z(:,k))/sumz(k)
end do
do i = 1,n
temp1(:,1) = ( x(i,:) - mu(:,k) ) * sqrt(z(i,k))
call dger(p, p, 1.d0, temp1(:,1), 1, temp1(:,1), 1,
* U(:,:,k), p)
end do
* U contains the weighted scattering matrix
* compute the eigenvalues of U to be stored in omega
temp2 = U(:,:,k)
call dsyev('N', 'U', p, temp2, p, temp1(:,1), wrk, lwork, info)
* now temp1 contains all the eigenvalues of U
* check if dsyev converged and positive definite
if ( info .ne. 0 ) then
return
else
if ( minval(temp1(:,1)) .lt. sqrt(eps) ) then
info = 0
scale = FLMAX
return
end if
end if
omega(k) = temp1(p,1)
end do
* omega contains the largest eigenvalue of each scattering matrix
niterin = 0
errin = FLMAX
trgt = FLMAX
trgtprev = FLMAX/2
* covariance matrix components estimation
* we consider algorithm MM 1 and MM 2 of Browne, McNicholas 2013
* with a modification in computing the orientation matrix in the MM 2 step
* shape (matrix A) and orientation (matrix D) initialised in R
* shape = matrix(1, p,G)
* O = diag(p)
* WHILE loop using goto statement
100 continue
* ### NOTE: O is transposed
niterin = niterin + 1
temp2 = 0.d0
temp3 = 0.d0
* temp3 will contain matrix F
* Algorithm MM 1 ......................................
do k = 1,G
do j = 1,p
* temp1(j,:) = O(:,j) / shape(j,k)
temp1(j,:) = O(j,:) / shape(j,k)
end do
* temp1 contains inv(A)t(D)
call dgemm( 'N','N', p,p,p, 1.d0, temp1,p, U(:,:,k),p,
* 0.d0, temp2,p )
* temp2 contains inv(A) %*% t(D) %*% W
temp1 = temp2 - omega(k)*temp1
temp3 = temp3 + temp1
* temp3 contains the matrix F
end do
* compute matrices P and R where svd(F) = P %*% B %*% t(R)
call dgesvd('A','A', p,p, temp3,p, temp4, temp1,p, temp2,p,
* wrk, lwork, info)
* now temp1 contains matrix P, temp2 contains matrix t(R)
* temp4 contains the singular values
* check if dgesvd converged
if ( info .ne. 0 ) return
* NOTE: t(P %*% t(R)) = R %*% t(P)
call dgemm( 'N','N', p,p,p, 1.d0, temp1,p, temp2,p,
* 0.d0, O,p )
* O contains TRANSPOSED matrix D of Browne, McNicholas
* .....................................................
* Algorithm MM 2 ......................................
call transpose(O, p)
* O contains matrix D of Browne, McNicholas
* Algorithm MM 2
temp1 = 0.d0
temp3 = 0.d0
do k = 1,G
call dgemm( 'N','N', p,p,p, 1.d0, U(:,:,k),p, O,p,
* 0.d0, temp1,p )
* temp1 contains W %*% D
do j = 1,p
temp2(:,j) = temp1(:,j) / shape(j,k)
end do
* temp2 contains W %*% D %*% inv(A)
temp1 = temp2 - maxval( 1/shape(:,k) )*temp1
temp3 = temp3 + temp1
* temp3 contains the matrix F
end do
* compute matrices P and R where svd(F) = P %*% B %*% t(R)
call dgesvd('A','A', p,p, temp3,p, temp4, temp1,p, temp2,p,
* wrk, lwork, info)
* now temp1 contains matrix P, temp2 contains matrix t(R)
* temp4 contains the singular values
* check if dgesvd converged
if ( info .ne. 0 ) return
* NOTE: t(O) = R %*% t(P)
O = 0.d0
call dgemm( 'N','N', p,p,p, 1.d0, temp1,p, temp2,p,
* 0.d0, O,p )
call transpose(O, p)
* O contains TRANSPOSED matrix D of Browne, McNicholas
* .....................................................
* compute shape (matrix A) and target function
trgt = 0.d0
do k = 1,G
temp1 = 0.d0
call dgemm( 'N','N', p,p,p, 1.d0, O,p, U(:,:,k),p,
* 0.d0, temp1,p )
* temp1 contains t(D) %*% W
do j = 1,p
shape(j,k) = ddot(p, temp1(j,:), 1, O(j,:), 1)
end do
* shape(:,k) = shape(:,k)/
* * exp( sum( log(shape(:,k)) ) )**(1.d0/dble(p))
shape(:,k) = shape(:,k)/sumz(k)
* now shape contains matrix A (scale*A) of Celeux, Govaert pag. 785
* compute scale parameter and shape matrix A
scale(k) = exp( sum( log(shape(:,k)) ) )**(1/dble(p))
shape(:,k) = shape(:,k)/scale(k)
* check positive values
if ( minval(shape(:,k)) .lt. sqrt(eps) ) then
info = 0
shape = FLMAX
return
end if
temp4(1) = 0.d0
do j = 1,p
* temp2(:,j) = O(:,j) * 1.d0/shape(j,k)
temp2(:,j) = O(j,:) * 1.d0/shape(j,k)
temp4(1) = temp4(1) + ddot(p, temp1(j,:), 1, temp2(:,j), 1)
end do
trgt = trgt + temp4(1)
end do
* error
errin = abs(trgt - trgtprev)/(1.d0 + abs(trgt))
trgtprev = trgt
* WHILE condition
if ( errin .gt. tol .and. niterin .lt. itmax ) goto 100
return
end
* ======================================================================
subroutine esvve (x,z, n,p,G,Gnoise, mu,O,scale,shape,pro, Vinv,
* loglik, eps)
* Expectation step for model VVE
* ======================================================================
implicit none
integer :: n, p, G, Gnoise
double precision :: x(n,p), z(n,Gnoise)
double precision :: mu(p,G), O(p,p), scale(G), shape(p,G)
double precision :: Vinv, pro(Gnoise)
double precision :: temp1(p), temp2(p), temp3, temp4(n)
integer :: i, k, j
double precision :: const, logdet, loglik, eps
double precision :: log2pi
parameter (log2pi = 1.837877066409345d0)
double precision :: FLMAX
parameter (FLMAX = 1.7976931348623157d308)
external :: ddot
double precision :: ddot
* double precision :: smalog
* parameter (smalog = -708.d0)
*-----------------------------------------------------------------------
* check very small eigenvalues (singular covariance)
if ( minval(shape) .le. sqrt(eps) .or.
* minval(scale) .le. sqrt(eps) ) then
loglik = FLMAX
return
end if
const = (-dble(p)/2.d0)*log2pi
do k = 1,G
logdet = 0.d0
do j = 1,p
logdet = logdet + ( log(shape(j,k)) + log(scale(k)) )
end do
* compute mahalanobis distance for each observation
* ##### NOTE: O is transposed
do i = 1,n
temp1 = ( x(i,:) - mu(:,k) )
call dcopy(p, 0.d0, 0, temp2, 1)
call dgemv('N', p, p, 1.d0,
* O, p, temp1, 1, 0.d0, temp2, 1)
temp2 = temp2/sqrt(scale(k)*shape(:,k))
temp3 = ddot(p, temp2, 1, temp2, 1)
temp4(i) = temp3
* temp3 contains the mahalanobis distance
* z(i,k) = const - logdet/2.d0 - temp3/2.d0 + log(pro(k))
z(i,k) = const - logdet/2.d0 - temp3/2.d0
* help(cdens) --> The densities are not scaled by mixing proportions
end do
* z contains the log-density log(N(x|theta_k))
end do
if ( pro(1) .lt. 0.d0 ) return
* cdens function
* noise component
if (Vinv .gt. 0.d0) then
call dcopy( n, log(Vinv), 0, z(:,Gnoise), 1)
end if
* now column Gnoise of z contains log(Vinv)
do i = 1,n
z(i,:) = z(i,:) + log( pro )
* Numerical Recipes pag.844
temp3 = maxval(z(i,:))
temp1(1) = temp3 + log( sum(exp(z(i,:) - temp3)) )
loglik = loglik + temp1(1)
* ##### NOTE: do we need to check if (z - zmax) is too small?
z(i,:) = exp( z(i,:) - temp1(1) )
* re-normalize probabilities
temp3 = sum( z(i,:) )
call dscal( Gnoise, 1.d0/temp3, z(i,:), 1 )
end do
return
end
* ======================================================================
subroutine mevve ( x,z, n,p,G,Gnoise, mu,O,U,scale,shape,pro,Vinv,
* loglik, eqpro,itmaxin,tolin,itmaxout,tolout,eps,
* niterin,errin,niterout,errout,lwork,info)
* Maximization-expectation algorithm for model VVE
* ======================================================================
implicit none
logical :: eqpro
integer :: n,p,G,Gnoise
double precision :: x(n,p), z(n,Gnoise), pro(Gnoise), Vinv
double precision :: mu(p,G), O(p,p), scale(G), shape(p,G)
double precision :: U(p,p,G), sumz(Gnoise), omega(G)
double precision :: temp1(p,p), temp2(p,p), temp3(p,p), temp4(p)
integer :: i, j, k, info, lwork
integer :: itmaxin, itmaxout, niterin, niterout
double precision :: tolin, tolout, errin, errout, eps, rteps
double precision :: const, logdet, loglik, lkprev, wrk(lwork)
double precision :: trgt, trgtprev
double precision :: log2pi
parameter (log2pi = 1.837877066409345d0)
double precision :: FLMAX
parameter (FLMAX = 1.7976931348623157d308)
external :: ddot
double precision :: ddot
* double precision :: smalog
* parameter (smalog = -708.d0)
*-----------------------------------------------------------------------
rteps = sqrt(eps)
niterout = 0
errout = FLMAX
lkprev = FLMAX/2
loglik = FLMAX
const = (-dble(p)/2.d0)*log2pi
* WHILE loop for EM algorithm
100 continue
niterout = niterout + 1
sumz = sum(z, dim = 1)
if ( eqpro ) then
if ( Vinv .gt. 0 ) then
pro(Gnoise) = sumz(Gnoise) / dble(n)
pro(1:G) = ( 1 - pro(Gnoise) ) / dble(G)
sumz = pro * dble(n)
else
pro = 1 / dble(G)
sumz = pro * dble(n)
end if
else
pro = sumz / dble(n)
end if
* re-initialise U
call dcopy(p*p*G, 0.d0, 0, U, 1)
* compute weighted scattering matrix and means
do k = 1,G
do j = 1,p
mu(j,k) = sum(x(:,j)*z(:,k))/sumz(k)
end do
do i = 1,n
temp1(:,1) = ( x(i,:) - mu(:,k) ) * sqrt(z(i,k))
call dger(p, p, 1.d0, temp1(:,1), 1, temp1(:,1), 1,
* U(:,:,k), p)
end do
* U contains the weighted scattering matrix
* compute the eigenvalues of U to be stored in omega
temp2 = U(:,:,k)
call dsyev('N', 'U', p, temp2, p, temp1(:,1), wrk, lwork, info)
* now temp1 contains all the eigenvalues of U
* check if dsyev converged and positive definite
if ( info .ne. 0 ) then
return
else
if ( minval(temp1(:,1)) .lt. rteps ) then
info = 0
scale = FLMAX
return
end if
end if
omega(k) = temp1(p,1)
end do
* omega contains the largest eigenvalue of each scattering matrix
* M step..........................................................
niterin = 0
errin = FLMAX
trgt = FLMAX
trgtprev = FLMAX/2
* covariance matrix components estimation
* we consider algorithm MM 1 and MM 2 of Browne, McNicholas 2013
* with a modification in computing the orientation matrix in the MM 2 step
* shape (matrix A) and orientation (matrix D) initialised in R
* shape = matrix(1, p,G)
* O = diag(p)
* ### NOTE: we don't re-initialize shape and orientation at each
* outer iteration of the EM algorithm
* WHILE loop for M step
110 continue
* ### NOTE: O is transposed
niterin = niterin + 1
temp2 = 0.d0
temp3 = 0.d0
* temp3 will contain matrix F
* Algorithm MM 1 ......................................
do k = 1,G
do j = 1,p
* temp1(j,:) = O(:,j) / shape(j,k)
temp1(j,:) = O(j,:) / shape(j,k)
end do
* temp1 contains inv(A)t(D)
call dgemm( 'N','N', p,p,p, 1.d0, temp1,p, U(:,:,k),p,
* 0.d0, temp2,p )
* temp2 contains inv(A) %*% t(D) %*% W
temp1 = temp2 - omega(k)*temp1
temp3 = temp3 + temp1
* temp3 contains the matrix F
end do
* compute matrices P and R where svd(F) = P %*% B %*% t(R)
call dgesvd('A','A', p,p, temp3,p, temp4, temp1,p, temp2,p,
* wrk, lwork, info)
* now temp1 contains matrix P, temp2 contains matrix t(R)
* temp4 contains the singular values
* check if dgesvd converged
if ( info .ne. 0 ) return
* NOTE: t(P %*% t(R)) = R %*% t(P)
call dgemm( 'N','N', p,p,p, 1.d0, temp1,p, temp2,p,
* 0.d0, O,p )
* O contains TRANSPOSED orientation (matrix D of Browne, McNicholas)
* .....................................................
* Algorithm MM 2 ......................................
call transpose(O, p)
* O contains matrix D of Browne, McNicholas
* Algorithm MM 2
temp1 = 0.d0
temp3 = 0.d0
do k = 1,G
call dgemm( 'N','N', p,p,p, 1.d0, U(:,:,k),p, O,p,
* 0.d0, temp1,p )
* temp1 contains W %*% D
do j = 1,p
temp2(:,j) = temp1(:,j) / shape(j,k)
end do
* temp2 contains W %*% D %*% inv(A)
temp1 = temp2 - maxval( 1/shape(:,k) )*temp1
temp3 = temp3 + temp1
* temp3 contains the matrix F
end do
* compute matrices P and R where svd(F) = P %*% B %*% t(R)
call dgesvd('A','A', p,p, temp3,p, temp4, temp1,p, temp2,p,
* wrk, lwork, info)
* now temp1 contains matrix P, temp2 contains matrix t(R)
* temp4 contains the singular values
* check if dgesvd converged
if ( info .ne. 0 ) return
* NOTE: t(O) = R %*% t(P)
O = 0.d0
call dgemm( 'N','N', p,p,p, 1.d0, temp1,p, temp2,p,
* 0.d0, O,p )
call transpose(O, p)
* O contains TRANSPOSED matrix D of Browne, McNicholas
* .....................................................
* compute shape (matrix A) and target function
trgt = 0.d0
do k = 1,G
temp1 = 0.d0
call dgemm( 'N','N', p,p,p, 1.d0, O,p, U(:,:,k),p,
* 0.d0, temp1,p )
* temp1 contains t(D) %*% W
do j = 1,p
shape(j,k) = ddot(p, temp1(j,:), 1, O(j,:), 1)
end do
* shape(:,k) = shape(:,k)/
* * exp( sum( log(shape(:,k)) ) )**(1.d0/dble(p))
shape(:,k) = shape(:,k)/sumz(k)
* now shape contains matrix A (scale*A) of Celeux, Govaert pag. 785
* compute scale parameter and shape matrix A
scale(k) = exp( sum( log(shape(:,k)) ) )**(1/dble(p))
shape(:,k) = shape(:,k)/scale(k)
* check positive values
if (minval(shape(:,k)) .lt. rteps .or.
* scale(k) .lt. rteps) then
info = 0
loglik = FLMAX
return
end if
temp4(1) = 0.d0
do j = 1,p
* temp2(:,j) = O(:,j) * 1.d0/shape(j,k)
temp2(:,j) = O(j,:) * 1.d0/shape(j,k)
temp4(1) = temp4(1) + ddot(p, temp1(j,:), 1, temp2(:,j), 1)
end do
trgt = trgt + temp4(1)
end do
* error
errin = abs(trgt - trgtprev)/(1.d0 + abs(trgt))
trgtprev = trgt
* WHILE condition M step
if ( errin .gt. tolin .and. niterin .lt. itmaxin ) goto 110
* do k = 1,G
* scale(k) = exp( sum( log(shape(:,k)) ) )**(1/dble(p))
* shape(:,k) = shape(:,k)/scale(k)
* end do
* ................................................................
* E step..........................................................
const = (-dble(p)/2.d0)*log2pi
do k = 1,G
logdet = 0.d0
do j = 1,p
logdet = logdet + ( log(shape(j,k)) + log(scale(k)) )
end do
* compute mahalanobis distance for each observation
* ##### NOTE: O is transposed
do i = 1,n
temp1(:,1) = ( x(i,:) - mu(:,k) )
call dcopy(p, 0.d0, 0, temp2(:,1), 1)
call dgemv('N', p, p, 1.d0,
* O, p, temp1(:,1), 1, 0.d0, temp2(:,1), 1)
temp2(:,1) = temp2(:,1)/sqrt(scale(k)*shape(:,k))
temp3(1,1) = ddot(p, temp2(:,1), 1, temp2(:,1), 1)
* temp3 contains the mahalanobis distance
z(i,k) = const - logdet/2.d0 - temp3(1,1)/2.d0 + log(pro(k))
* z(i,k) = const - logdet/2.d0 - temp3(1,1)/2.d0
end do
* z contains the log-density log(N(x|theta_k)) + log(p_k)
end do
* noise component
if (Vinv .gt. 0.d0) then
z(:,Gnoise) = log(Vinv) + log( pro(Gnoise) )
end if
* now column Gnoise of z contains log(Vinv) + log(p_0)
loglik = 0.d0
do i = 1,n
* Numerical Recipes pag.844
temp3(1,1) = maxval(z(i,:))
temp1(1,1) = temp3(1,1) + log( sum(exp(z(i,:) - temp3(1,1))) )
loglik = loglik + temp1(1,1)
* ##### NOTE: do we need to check if (z - zmax) is too small?
z(i,:) = exp( z(i,:) - temp1(1,1) )
* re-normalize probabilities
temp3(1,1) = sum( z(i,:) )
call dscal( Gnoise, 1.d0/temp3(1,1), z(i,:), 1 )
end do
* ................................................................
errout = abs(loglik - lkprev)/(1.d0 + abs(loglik))
lkprev = loglik
* Chris F (June 2015): pro should not be computed in the E-step
* sumz = sum(z, dim = 1)
* if ( eqpro ) then
* if ( Vinv .gt. 0 ) then
* pro(Gnoise) = sumz(Gnoise) / dble(n)
* pro(1:G) = ( 1 - pro(Gnoise) ) / dble(G)
* sumz = pro * dble(n)
* else
* pro = 1 / dble(G)
* sumz = pro * dble(n)
* end if
* else
* pro = sumz / dble(n)
* end if
* check if empty components
if ( minval(sumz) .lt. rteps ) then
loglik = -FLMAX
return
end if
* WHILE condition EM
if ( errout .gt. tolout .and. niterout .lt. itmaxout ) goto 100
return
end
mclust/src/init.c 0000644 0001762 0000144 00000042730 13205037573 013472 0 ustar ligges users #include 
