bio.calc.norm.ret <- function (ret)

{

s <- apply(ret, 1, sd)

x <- ret / s

return(x)

}

qrm.calc.norm.ret <- bio.calc.norm.ret

bio.cl.sigs <- function(x, iter.max = 100,

num.try = 1000, num.runs = 10000)

{

cl.ix <- function(x) match(1, x)

y <- log(1 + x)

y <- t(t(y) - colMeans(y))

x.d <- exp(y)

k <- ncol(bio.erank.pc(y)$pc)

n <- nrow(x)

u <- rnorm(n, 0, 1)

q <- matrix(NA, n, num.runs)

p <- rep(NA, num.runs)

for(i in 1:num.runs)

{

z <- qrm.stat.ind.class(y, k, iter.max = iter.max,

num.try = num.try, demean.ret = F)

p[i] <- sum((residuals(lm(u ∼ -1 + z)))ˆ2)

q[, i] <- apply(z, 1, cl.ix)

}

p1 <- unique(p)

ct <- rep(NA, length(p1))

for(i in 1:length(p1))

ct[i] <- sum(p1[i] == p)

p1 <- p1[ct == max(ct)]

i <- match(p1, p)[1]

ix <- q[, i]

k <- max(ix)

z <- matrix(NA, n, k)

for(j in 1:k)

z[, j] <- as.numeric(ix == j)

res <- bio.cl.wts(x.d, z)

return(res)

}

bio.cl.wts <- function (x, ind)

{

first.ix <- function(x) match(1, x)[1]

calc.wts <- function(x, use.wts = F, use.geom = F)

{

if(use.geom)

{

if(use.wts)

s <- apply(log(x), 1, sd)

else

s <- rep(1, nrow(x))

s <- 1 / s / sum(1 / s)

fac <- apply(xˆs, 2, prod)

}

else

{

if(use.wts)

s <- apply(x, 1, sd)

else

s <- rep(1, nrow(x))

fac <- colMeans(x / s)

}

w <- coefficients(lm(t(x) ∼ -1 + fac))

w <- 100 * w / sum(w)

return(w)

}

n <- nrow(x)

w <- w.g <- v <- v.g <- rep(NA, n)

z <- colSums(ind)

z <- as.numeric(paste(z, ".", apply(ind, 2, first.ix), sep = ""))

dimnames(ind)[[2]] <- names(z) <- 1:ncol(ind)

z <- sort(z)

z <- names(z)

ind <- ind[, z]

dimnames(ind)[[2]] <- NULL

for(i in 1:ncol(ind))

{

take <- ind[, i] == 1

if(sum(take) == 1)

{

w[take] <- w.g[take] <- 1

v[take] <- v.g[take] <- 1

next

}

w[take] <- calc.wts(x[take,], F, F)

w.g[take] <- calc.wts(x[take,], F, T)

v[take] <- calc.wts(x[take,], T, F)

v.g[take] <- calc.wts(x[take,], T, T)

}

res <- new.env()

res$ind <- ind

res$w <- w

res$w.g <- w.g

res$v <- v

res$v.g <- v.g

return(res)

}