-
Notifications
You must be signed in to change notification settings - Fork 0
/
smacofFixed.R
executable file
·112 lines (102 loc) · 2.92 KB
/
smacofFixed.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
smacof <- function(D, niter = 100, interc = 1, inicon = NULL, cols = "black", colv = palette()[c(8, 2, 4, 3, 5, 6, 7, 1)], main = "Multidimensional Scaling", k = 2, pch = 16, PLOT = TRUE, VERBOSE = TRUE, ...) {
dhat <- ddelta <- D <- normdist(D)
n <- dimdata(D)
delta <- lowmat(D)
ycol <- matrix(c(0, 0), nrow = 1, byrow = T)
if (is.null(inicon)) {
inicon <- cmdscale(D, k)
}
yy <- xx <- inicon
dd <- lowmat(dist(xx), ...)
str0 <- str <- sum((delta - dd)**2)
for (i in 1:niter)
{
if (niter != 0) {
xx <- (1 / n) * (bmat(delta, dd)) %*% xx
dd <- dist(xx)
if (interc == 1) {
ddd <- dd
dhat <- lm(dd ~ ddelta)$fitted.values
delta <- lowmat(normdist(dhat))
if ((a <- min(dhat)) <= 0) {
ddd <- .01 + dd + abs(a)
dhat <- lm(ddd ~ ddelta)$fitted.values
delta <- lowmat(normdist(dhat))
}
}
dd <- lowmat(dist(xx))
# str=(sum((delta-dd)**2))**.5
str <- snorm <- fit(delta, dd)
if (VERBOSE) cat("it = ", i, ", crit = ", str, " \n")
if (abs(str0 - str) < 1e-6) break
str0 <- str
}
}
xx <- rotat(xx)
if (PLOT) {
lims <- c(
ll = floor(100 * min(c(xx[, 1], xx[, 2]))) / 100,
ul = ceiling(100 * max(c(xx[, 1], xx[, 2]))) / 100
)
# plot(xx,asp=1,type='n',xlab='Dimension 1 ',ylab='Dimension 2')
# points(xx,asp=1,col="gray",pch=21,bg="gray")
plot(xx,
xlab = "Dimension 1", ylab = "Dimension 2",
main = main, xlim = lims, ylim = lims,
xaxs = "i", yaxs = "i", pch = pch, col = cols, ...
)
}
delta <- normdist(dhat)
return(list(D = delta, X = xx, interc = interc))
}
plotSmacof <- function(xx, main = "Multidimensional Scaling", pch = 16, cols = "black", ...){
lims <- c(
ll = floor(100 * min(c(xx[, 1], xx[, 2]))) / 100,
ul = ceiling(100 * max(c(xx[, 1], xx[, 2]))) / 100
)
size <- 2
par(mar = c(5,5,4,2)+0.1)
plot(xx,
xlab = "Dimension 1", ylab = "Dimension 2",
main = main, xlim = lims, ylim = lims,
xaxs = "r", yaxs = "r",
cex.lab = size,
cex.axis = size,
cex.main = size,
pch = pch, col = cols, ...
)
}
plotNoLims <- function(xx, main = "Plot", xlab = "Dimension 1", ylab = "Dimension 2", pch = 16, cols = "black", ...){
size <- 2
par(mar = c(5,5,4,2)+0.1)
plot(xx,
xlab = xlab, ylab = ylab,
main = main,
xaxs = "r", yaxs = "r", pch = pch, col = cols,
cex.lab = size,
cex.axis = size,
cex.main = size, ...
)
}
bmat <- function(odist, fdist) {
n <- nrow(odist)
nnn <- matrix(0, nrow = n, ncol = n)
bb <- matrix(0, nrow = n, ncol = n)
for (i in 1:n) {
nnn[i, i] <- 1
}
for (i in 1:n)
{
sb <- 0
for (j in 1:n)
{
if (fdist[i, j] != 0) {
bb[i, j] <- odist[i, j] / fdist[i, j]
sb <- sb - bb[i, j]
}
}
bb[i, i] <- bb[i, i] + sb
}
bmat <- -bb
return(bmat)
}