-
Notifications
You must be signed in to change notification settings - Fork 4
/
Copy pathpbm.R
484 lines (480 loc) · 22.2 KB
/
pbm.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
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
# THIS IS THE NEW VERSION OF pbm() BUT NOT IMPLEMENTED YET
# Using SVD and also defined Kappa=1e10
## this is the new implementation of the Penalized B-splines smoother
## Mikis Stasinopoulos, Bob Rigby, Paul Eilers based on Simon Woods's idea
## created 17-03-2015
#-------------------------------------------------------------------------------
pbm <- function(x, df = NULL, lambda = NULL, mono=c("up", "down"), control=pbm.control(...), ...)
{
# ------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
## local function
## creates the basis for p-splines
## Paul Eilers' function
#-------------------------------------------------------------------------------
bbase <- function(x, xl, xr, ndx, deg, quantiles=FALSE)
{
tpower <- function(x, t, p)
# Truncated p-th power function
(x - t) ^ p * (x > t)
# DS xl= min, xr=max, ndx= number of points within
# Construct B-spline basis
# if quantiles=TRUE use different bases
dx <- (xr - xl) / ndx # DS increment
if (quantiles) # if true use splineDesign
{
knots <- sort(c(seq(xl-deg*dx, xl, dx),quantile(x, prob=seq(0, 1, length=ndx)), seq(xr, xr+deg*dx, dx)))
B <- splineDesign(knots, x = x, outer.ok = TRUE, ord=deg+1)
return(B)
}
else # if false use Paul's
{
knots <- seq(xl - deg * dx, xr + deg * dx, by = dx)
P <- outer(x, knots, tpower, deg)# calculate the power in the knots
n <- dim(P)[2]
D <- diff(diag(n), diff = deg + 1) / (gamma(deg + 1) * dx ^ deg) #
B <- (-1) ^ (deg + 1) * P %*% t(D)
attr(B, "knots") <- knots[-c(1:(deg-1), (n-(deg-2)):n)]
B
}
}
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
# the main function starts here
scall <- deparse(sys.call(), width.cutoff = 500L)
if (is.matrix(x)) stop("x is a matric declare it as a vector")
mono <- match.arg(mono)
no.dist.val <- length(table(x))
lx <- length(x)
control$inter <- if (lx<99) 10 else control$inter # this is to prevent singularities when length(x) is small:change to 99 30-11-11 MS
control$inter <- if (no.dist.val<=control$inter) no.dist.val else control$inter
xl <- min(x)
xr <- max(x)
xmax <- xr + 0.01 * (xr - xl)
xmin <- xl - 0.01 * (xr - xl)
## create the basis
X <- bbase(x, xmin, xmax, control$inter, control$degree, control$quantiles) #
r <- ncol(X)
## the penalty matrix
D <- if(control$order==0) diag(r) else diff(diag(r), diff=control$order)
## ------ if df are set
if(!is.null(df)) # degrees of freedom
{
if (df>(dim(X)[2]-2))
{df <- 3;
warning("The df's exceed the number of columns of the design matrix", "\n", " they are set to 3") }
if (df < 0) warning("the extra df's are set to 0")
df <- if (df < 0) 2 else df+2
}
##
## here we get the gamlss environment and a random name to save
## the starting values for lambda within gamlss()
## get gamlss environment
#--------
rexpr<-regexpr("gamlss",sys.calls())
for (i in 1:length(rexpr)){
position <- i
if (rexpr[i]==1) break}
gamlss.environment <- sys.frame(position)
#--------
## get a random name to use it in the gamlss() environment
#--------
sl <- sample(letters, 4)
fourLetters <- paste(paste(paste(sl[1], sl[2], sep=""), sl[3], sep=""),sl[4], sep="")
startLambdaName <- paste("start.Lambda",fourLetters, sep=".")
## put the starting values in the gamlss()environment
#--------
assign(startLambdaName, control$start, envir=gamlss.environment)
#--------
xvar <- rep(0,length(x)) # only the linear part in the design matrix the rest pass as artributes
attr(xvar, "control") <- control
attr(xvar, "D") <- D
attr(xvar, "X") <- X
attr(xvar, "x") <- x
attr(xvar, "df") <- df
attr(xvar, "mono") <- mono
attr(xvar, "call") <- substitute(gamlss.pbm(data[[scall]], z, w))
attr(xvar, "lambda") <- lambda
attr(xvar, "gamlss.env") <- gamlss.environment
attr(xvar, "NameForLambda") <- startLambdaName
attr(xvar, "class") <- "smooth"
xvar
}
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
# control function for pb()
##------------------------------------------------------------------------------
pbm.control <- function(inter = 20, degree= 3, order = 2, start=10, quantiles=FALSE,
method=c("ML","GAIC", "GCV"), k=2, kappa = 1e10, ...)
{
## Control function for pb()
## MS Tuesday, March 24, 2009
## inter : is the number of equal space intervals in x
## (unless quantiles = TRUE is used in which case the points will be at the quantiles values of x)
## degree: is the degree of the polynomial
## order refers to differences in the penalty for the coeficients
## order = 0 : white noise random effects
## order = 1 : random walk
## order = 2 : random walk of order 2
## order = 3 : random walk of order 3
# inter = 20, degree= 3, order = 2, start=10, quantiles=FALSE, method="loML"
if(inter <= 0) {
warning("the value of inter supplied is less than 0, the value of 10 was used instead")
inter <- 10 }
if(degree <= 0) {
warning("the value of degree supplied is less than zero or negative the default value of 3 was used instead")
degree <- 3}
if(order < 0) {
warning("the value of order supplied is zero or negative the default value of 2 was used instead")
order <- 2}
if(k <= 0) {
warning("the value of GAIC/GCV penalty supplied is less than zero the default value of 2 was used instead")
k <- 2}
method <- match.arg(method)
list(inter = inter, degree = degree, order = order, start=start,
quantiles = as.logical(quantiles)[1], method= method, k=k, kappa=kappa)
}
#-------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
# the main function
#-------------------------------------------------------------------------------
gamlss.pbm <- function(x, y, w, xeval = NULL, ...)
{
# ------------------------------------------------------------------------------
# functions within
# a simple penalised regression
# this is the original matrix manipulation version but it swiches to QR if it fails
regpen <- function(y, X, w, lambda, D)# original
{
kappa <- control$kappa
D2 <- diff(diag(dim(D)[2]))
w2 <- rep(0, dim(D)[2]-1)
for (it in 1:20)
{
RD <- rbind(R,sqrt(lambda)*D, sqrt(kappa)*(w2*D2) ) #
svdRD <- svd(RD) # U 2pxp D pxp V pxp
rank <- sum(svdRD$d>max(svdRD$d)*.Machine$double.eps^.8)
U1 <- svdRD$u[1:p,1:rank]
y1 <- t(U1)%*%Qy
beta <- svdRD$v[,1:rank] %*%(y1/svdRD$d[1:rank])
# cat(it, beta, '\n')
# plot(beta)
w2new <- if (mono=="up") c((D2 %*% beta) < 0) else c((D2 %*% beta) > 0)
diffw2 <- sum(w2new != w2)
# cat(it, diffw2, '\n')be
if (diffw2 == 0) break
w2 <- as.numeric(w2new)
}
HH <- (svdRD$u)[1:p,1:rank]%*%t(svdRD$u[1:p,1:rank])
df <- sum(diag(HH))
fit <- list(beta = beta, edf = df)
return(fit)
}
# #-------------------------------------------------------------------------------
# ## function to find lambdas miimizing the local GAIC
fnGAIC <- function(lambda, k)
{
fit <- regpen(y=y, X=X, w=w, lambda=lambda, D)
fv <- X %*% fit$beta
GAIC <- sum(w*(y-fv)^2)+k*fit$edf
# cat("GAIC", GAIC, "\n")
GAIC
}
# #-------------------------------------------------------------------------------
# ## function to find the lambdas wich minimise the local GCV
fnGCV <- function(lambda, k)
{
I.lambda.D <- (1+lambda*UDU$values)
edf <- sum(1/I.lambda.D)
y_Hy2 <- y.y-2*sum((yy^2)/I.lambda.D)+sum((yy^2)/((I.lambda.D)^2))
GCV <- (n*y_Hy2)/(n-k*edf)
GCV
}
# #-------------------------------------------------------------------------------
# ## local function to get edf from lambda
# # edf_df <- function(lambda)
# # {
# # G <- lambda * t(D) %*% D
# # H <- solve(XWX + G, XWX)
# # edf <- sum(diag(H))
# # # cat("edf", edf, "\n")
# # (edf-df)
# # }
# ## local function to get df using eigen values
edf1_df <- function(lambda)
{
edf <- sum(1/(1+lambda*UDU$values))
(edf-df)
}
#-------------------------------------------------------------------------------
# the main function starts here
# get the attributes
#w <- ifelse(w>.Machine$double.xmax^.5,.Machine$double.xmax^.5,w )
if (is.null(xeval)) # if no prediction
{
X <- if (is.null(xeval)) as.matrix(attr(x,"X")) #the trick is for prediction
else as.matrix(attr(x,"X"))[seq(1,length(y)),]
xvar <- as.matrix(attr(x,"x")) # the original x
D <- as.matrix(attr(x,"D")) # penalty
lambda <- as.vector(attr(x,"lambda")) # lambda
df <- as.vector(attr(x,"df")) # degrees of freedom
mono <- attr(x,"mono") # whether up or down
control <- as.list(attr(x, "control"))
gamlss.env <- as.environment(attr(x, "gamlss.env"))
startLambdaName <- as.character(attr(x, "NameForLambda"))
order <- control$order # the order of the penalty matrix
N <- sum(w!=0) # DS+FDB 3-2-14
n <- nrow(X) # the no of observations
p <- ncol(D) # the rows of the penalty matrix
qrX <- qr(sqrt(w)*X, tol=.Machine$double.eps^.8)
R <- qr.R(qrX)
Q <- qr.Q(qrX)
Qy <- t(Q)%*%(sqrt(w)*y)
tau2 <- sig2 <- NULL
# now the action depends on the values of lambda and df
#-------------------------------------------------------------------------------
lambdaS <- get(startLambdaName, envir=gamlss.env) ## geting the starting value
if (lambdaS>=1e+07) lambda <- 1e+07 # MS 19-4-12
if (lambdaS<=1e-07) lambda <- 1e-07 # MS 19-4-12
# cat(lambda, "\n")
# case 1: if lambda is known just fit -----------------------------------------
if (is.null(df)&&!is.null(lambda)||!is.null(df)&&!is.null(lambda))
{
fit <- regpen(y, X, w, lambda, D)
fv <- X %*% fit$beta
} # case 2: if lambda is estimated --------------------------------------------
else if (is.null(df)&&is.null(lambda))
{ #
# cat("----------------------------","\n")
lambda <- lambdaS # MS 19-4-12
# if ML --------------------------------------------------------------------ML
switch(control$method,
"ML"={
for (it in 1:50)
{
fit <- regpen(y, X, w, lambda, D) # fit model
gamma. <- D %*% as.vector(fit$beta) # get the gamma differences
fv <- X %*% fit$beta # fitted values
sig2 <- sum(w * (y - fv) ^ 2) / (N - fit$edf) # DS+FDB 3-2-14
tau2 <- sum(gamma. ^ 2) / (fit$edf-order)# see LNP page 279
if(tau2<1e-7) tau2 <- 1.0e-7 # MS 19-4-12
lambda.old <- lambda
lambda <- sig2 / tau2 # maybe only 1/tau2 will do since it gives exactly the EM results see LM-1
if (lambda<1.0e-7) lambda<-1.0e-7 # DS Saturday, April 11, 2009 at 14:18
if (lambda>1.0e+7) lambda<-1.0e+7 # DS 29 3 2012
# cat("iter tau2 sig2",it,tau2, sig2, '\n')
if (abs(lambda-lambda.old) < 1.0e-7||lambda>1.0e10) break
assign(startLambdaName, lambda, envir=gamlss.env)
#cat("lambda",lambda, '\n')
}
},
# "ML-1"={ #------------------------------------------------------------ML-1
# for (it in 1:50)
# {
# fit <- regpen(y, X, w, lambda, D) # fit model
# gamma. <- D %*% as.vector(fit$beta) # get the gamma differences
# fv <- X %*% fit$beta # fitted values
# sig2 <- 1 # sum(w * (y - fv) ^ 2) / (N - fit$edf)
# tau2 <- sum(gamma. ^ 2) / (fit$edf-order)# Monday, March 16, 2009 at 20:00 see LNP page 279
# if(tau2<1e-7) tau2 <- 1.0e-7
# lambda.old <- lambda
# lambda <- sig2 / tau2 # 1/tau2
# if (lambda<1.0e-7) lambda<-1.0e-7 # DS Saturday, April 11, 2009 at 14:18
# if (lambda>1.0e+7) lambda<-1.0e+7 # DS 29 3 2012
# if (abs(lambda-lambda.old) < 1.0e-7||lambda>1.0e7) break
# assign(startLambdaName, lambda, envir=gamlss.env)
# }
# },
# "EM"={ #------------------------------------------------------------ EM
# for (it in 1:500)
# {
# fit <- regpenEM(y, X, w, lambda, order, D)
# gamma. <- D %*% as.vector(fit$beta)
# vgamma <- sum(diag(D%*%fit$V%*%t(D))) # this is crucial for estimating the variance of gamma Monday, March 23, 2009
# fv <- X %*% fit$beta
# tau2 <- ((sum(gamma.^ 2))+vgamma)/length(gamma.)
# if(tau2<1e-7) tau2 <- 1.0e-7
# lambda.old <- lambda
# lambda <- 1 / tau2
# #if (lambda<1.0e-7) lambda<-1.0e-7 # DS Saturday, April 11, 2009
# if (lambda<1.0e-7) lambda<-1.0e-7 # DS Saturday, April 11, 2009 at 14:18
# if (lambda>1.0e+7) lambda<-1.0e+7 # DS 29 3 2012
# # cat("iter sigma_t^2",it, tau2, "lambda",lambda, '\n')
# if (abs(lambda-lambda.old) < 1.0e-7||lambda>1.0e7) break
# }
# #cat("lambda",lambda, '\n')
# assign(startLambdaName, lambda, envir=gamlss.env)
# },
"GAIC"= #--------------------------------------------------------------- GAIC
{
lambda <- nlminb(lambda, fnGAIC, lower = 1.0e-7, upper = 1.0e7, k=control$k)$par
fit <- regpen(y=y, X=X, w=w, lambda=lambda, D)
fv <- X %*% fit$beta
assign(startLambdaName, lambda, envir=gamlss.env)
},
"GCV"={ #-------------------------------------------------------------- GCV
#
wy <- sqrt(w)*y
y.y <- sum(wy^2)
Rinv <- solve(R)
S <- t(D)%*%D
UDU <- eigen(t(Rinv)%*%S%*%Rinv)
yy <- t(UDU$vectors)%*%Qy #t(qr.Q(QR))%*%wy
lambda <- nlminb(lambda, fnGCV, lower = 1.0e-7, upper = 1.0e7, k=control$k)$par
fit <- regpen(y=y, X=X, w=w, lambda=lambda, D)
fv <- X %*% fit$beta
assign(startLambdaName, lambda, envir=gamlss.env)
})
}
else # case 3 : if df are required--------------------------------------------
{
Rinv <- solve(R)
S <- t(D)%*%D
UDU <- eigen(t(Rinv)%*%S%*%Rinv)
lambda <- if (sign(edf1_df(0))==sign(edf1_df(100000))) 100000 # in case they have the some sign
else uniroot(edf1_df, c(0,100000))$root
# if (any(class(lambda)%in%"try-error")) {lambda<-100000}
fit <- regpen(y, X, w, lambda, D)
fv <- X %*% fit$beta
}#end of case 3 --------------------------------------------------------------
# I need to calculate the hat matrix here for the variance of the smoother
# but this is working
#Version 1 --------------------------------------------------
# RD <- rbind(R,sqrt(lambda)*D) # 2p x p matrix
# svdRD <- svd(RD) # U 2pxp D pxp V pxp
# ## take only the important values
# rank <- sum(svdRD$d>max(svdRD$d)*.Machine$double.eps^.8)
# U1 <- svdRD$u[1:p,1:rank] # U1 p x rank
# HAT <- Q%*%U1%*%t(U1)%*%t(Q)
# lev <- diag(HAT) # lev1=lev
# #-end -----------------------------------------------------------
# #Version 2 --------------------------------------------------
# RD <- rbind(R,sqrt(lambda)*D) # 2p x p matrix
# svdRD <- svd(RD) # U 2pxp D pxp V pxp
# # ## take only the important values
# rank <- sum(svdRD$d>max(svdRD$d)*.Machine$double.eps^.8)
# U1 <- svdRD$u[1:p,1:rank] # U1 p x rank
# U1U1T <- U1%*%t(U1)
# lev <- rep(0, N)
# for (i in 1:N) lev[i] <- Q[i, ]%*%U1U1T%*%Q[i, ]
# #-end -----------------------------------------------------------
# #Version 3 --------------------------------------------------
# RD <- rbind(R,sqrt(lambda)*D) # 2p x p matrix
# svdRD <- svd(RD) # U 2pxp D pxp V pxp
# # # ## take only the important values
# rank <- sum(svdRD$d>max(svdRD$d)*.Machine$double.eps^.8)
# #U1 <- svdRD$u[1:p,1:rank] # U1 p x rank
# betavcov <- svdRD$v%*%diag(svdRD$d^(-2))%*%t(svdRD$v)
# lev3 <- rep(0, N)
# for (i in 1:N) lev3[i] <- X[i, ]%*%betavcov%*%X[i, ]
# this verion is not working???
# #-end -----------------------------------------------------------
#Version 4 --------------------------------------------------
waug <- as.vector(c(w, rep(1,nrow(D))))
xaug <- as.matrix(rbind(X,sqrt(lambda)*D))
lev <- hat(sqrt(waug)*xaug,intercept=FALSE)[1:n] # get the hat matrix
# MIKIS: conclusion is that version 4 the R hat is the faster
#-end -----------------------------------------------------------
lev <- (lev-.hat.WX(w,x)) # subtract the linear since is already fitted
var <- lev/w # the variance of the smootherz
# # se <- sqrt(diag(solve(XWX + lambda * t(D) %*% D)))
suppressWarnings(Fun <- splinefun(xvar, fv, method="monoH.FC"))
coefSmo <- list( coef = fit$beta,
fv = fv,
lambda = lambda,
edf = fit$edf,
sigb2 = tau2,
sige2 = sig2,
knots = attr(X,"knots"),
sigb = if (is.null(tau2)) NA else sqrt(tau2),
sige = if (is.null(sig2)) NA else sqrt(sig2),
method = control$method,
fun = Fun)
class(coefSmo) <- c("pbm", "pb")
# {
list(fitted.values=fv, residuals=y-fv, var=var, nl.df =fit$edf-1,
lambda=lambda, coefSmo=coefSmo )
}
else # for prediction
{
position <- 0
rexpr <- regexpr("predict.gamlss",sys.calls())
for (i in 1:length(rexpr)){
position <- i
if (rexpr[i]==1) break}
# cat("New way of prediction in pbm() (starting from GAMLSS version 5.0-3)", "\n" )
gamlss.environment <- sys.frame(position)
param <- get("what", envir=gamlss.environment)
object <- get("object", envir=gamlss.environment)
TT <- get("TT", envir=gamlss.environment)
smooth.labels <- get("smooth.labels", envir=gamlss.environment)
ll <- dim(as.matrix(attr(x,"X")))[1]
newxval <- as.vector(attr(x,"x"))[seq(length(y)+1,ll)]
pred <- getSmo(object, parameter= param, which=which(smooth.labels==TT))$fun(newxval)
# pred <- getSmo(object, parameter= param, which=which(TT%in%smooth.labels))$fun(newxval)
pred
}
}
#########################################################################
#########################################################################
print.pbm <- function (x, digits = max(3, getOption("digits") - 3), ...)
{
cat("Monotone P-spline fit using the gamlss function pbm() \n")
cat("Degrees of Freedom for the fit :", x$edf, "\n")
cat("Random effect parameter sigma_b:", format(signif(x$sigb)), "\n")
cat("Smoothing parameter lambda :", format(signif(x$lambda)), "\n")
}
#########################################################################
#########################################################################
getZmatrix<-function (x,xmin=NULL,xmax=NULL,inter=20,degree=3,order=2)
{
#-----------------------local function------------------------------------------
bbase <- function(x, xl, xr, ndx, deg, quantiles=FALSE)
{
tpower <- function(x, t, p)
# Truncated p-th power function
(x - t) ^ p * (x > t)
# DS xl= min, xr=max, ndx= number of points within
# Construct B-spline basis
# if quantiles=TRUE use different bases
dx <- (xr - xl) / ndx # DS increment
if (quantiles) # if true use splineDesign
{
knots <- sort(c(seq(xl-deg*dx, xl, dx),quantile(x, prob=seq(0, 1, length=ndx)), seq(xr, xr+deg*dx, dx)))
B <- splineDesign(knots, x = x, outer.ok = TRUE, ord=deg+1)
return(B)
}
else # if false use Paul's
{
knots <- seq(xl - deg * dx, xr + deg * dx, by = dx)
P <- outer(x, knots, tpower, deg)# calculate the power in the knots
n <- dim(P)[2]
D <- diff(diag(n), diff = deg + 1) / (gamma(deg + 1) * dx ^ deg) #
B <- (-1) ^ (deg + 1) * P %*% t(D)
attr(B, "knots") <- knots[-c(1:(deg-1), (n-(deg-2)):n)]
B
}
}
#-------------------------------------------------------------------------------
#------------------------------------------------------------------------------
#-------------------------------------------------------------------------------
no.dist.val <- length(table(x))
lx <- length(x)
inter <- if (lx<99) 10 else inter # this is to prevent singularities when length(x) is small
inter <- if (no.dist.val<=inter) no.dist.val else inter
if (is.null(xmin)) xl <- min(x)
if (is.null(xmax)) xr <- max(x)
xmin <- if (is.null(xmin)) xl - 0.01 * (xr - xl) else xmin
xmax <- if (is.null(xmax)) xr + 0.01 * (xr - xl) else xmax
B <- bbase(x, xmin, xmax, inter, degree, FALSE) #
r <- ncol(B)
D <- if(order==0) diag(r) else diff(diag(r), diff=order)
P.svd <- svd(t(D)%*%D)
U <- (P.svd$u)[,1:(r-order)]
d <- (P.svd$d)[1:(r-order)]
Delta <- diag(1/sqrt(d))
Z <- B%*%U%*%Delta
Z
}
#########################################################################
#########################################################################