Nothing
R/cgam.R
In cgam: Constrained Generalized Additive Model
Defines functions
testpar.fit
testpar
ddb.penal_dexp
ddb.penal
db.penal
varest
print.anova.cgam
anova.cgam
cgam.pvz
cgam.pv
getbin
getvars
makebin
Ord
fwt_a
fgr_a
fwt
fgr
ddfun
dfun
pfun
polr_getedf
predict_polr
dev_fun
print.summary.cgam.polr
summary.cgam.polr
cgam.polr.fit
cgam.polr
cpfun
sameside
intri
plotpersp.trisplp
plotpersp.trispl
s.conc.conc
s.conv.conv
makedelta_tri
tri_getedf
trispl.fit
irls
plot.shapeselect
CharToShape
ShapeToChar
ConstrALL
ConstrGA
make_form
in.or.out
shapes
best.fit
ShapeSelect
fitted.cgam.polr
fitted.trispl
fitted.wps
fitted.cgam
coef.cgam.polr
coef.trispl
coef.wps
coef.cgam
makeamat_wps
make_pen
makedelta_wps
s.decr.decr
s.decr.incr
s.incr.decr
s.incr.incr
wps.fit
wps_getedf
plotpersp.wpsp
plotpersp.wps
plotpersp.cgamp
plotpersp.cgam
plotpersp_control
plotpersp
makedelta_tri
predict.trispl
predict.wps
pred_del
predict.cgam
print.summary.wps
print.summary.cgam
summary.wps
summary.cgam
incconcave
incconvex
concave
convex
mondecr
monincr
make_delta_add
makedelta
umbrella.fun
umbrella
tree.fun
tree
s
s.decr.conc
s.decr.conv
s.incr.conc
s.incr.conv
s.conc
s.conv
s.decr
s.incr
decr.conc
incr.conc
decr.conv
incr.conv
conc
conv
decr
incr
get_varname
CicFamily
CicFamily
cgam.fit
bmat.fun
amat.fun
cgam
Documented in
best.fit
cgam
conc
conv
decr
decr.conc
decr.conv
incr
incr.conc
incr.conv
in.or.out
Ord
plotpersp
plotpersp_control
predict.cgam
s
s.conc
s.conc.conc
s.conv
s.conv.conv
s.decr
s.decr.conc
s.decr.conv
s.decr.decr
s.decr.incr
shapes
ShapeSelect
s.incr
s.incr.conc
s.incr.conv
s.incr.decr
s.incr.incr
testpar
tree
umbrella
######
#cgam#
######
cgam <- function(formula, cic = FALSE, nsim = 100, family = gaussian, cpar = 1.5, data = NULL, weights = NULL, sc_x = FALSE, sc_y = FALSE, pnt = TRUE, pen = 0, var.est = NULL, gcv = FALSE, pvf = TRUE)
{
cl <- match.call()
if (is.character(family))
family <- get(family, mode = "function", envir = parent.frame())
if (is.function(family))
family <- family()
if (is.null(family$family))
stop("'family' not recognized!")
if (family$family == "ordered") {
rslt <- cgam.polr(formula, data = data, weights = weights, family = family, nsim = nsim, cpar = cpar)
rslt$call <- cl
return (rslt)
} else {
labels <- NULL
mf <- match.call(expand.dots = FALSE)
m <- match(c("formula", "data"), names(mf), 0L)
mf <- mf[c(1L, m)]
mf[[1L]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
ynm <- names(mf)[1]
mt <- attr(mf, "terms")
y <- model.response(mf, "any")
if (family$family == "binomial") {
#if (class(y) == "factor") {
if(inherits(y, "factor")){
y <- ifelse(y == levels(y)[1], 0, 1)
}
}
#additive
shapes1_add <- NULL; shapes2_add <- NULL; shapes_add <- NULL
xmat_add <- NULL; xnms_add <- NULL
tr <- NULL; pl <- NULL; umb <- NULL
tree.delta <- NULL; umbrella.delta <- NULL
tid1 <- NULL; tid2 <- NULL; tpos2 <- 0
uid1 <- NULL; uid2 <- NULL; upos2 <- 0
nums_add <- NULL; ks_add <- list(); sps_add <- NULL; xid_add <- 1
zmat <- NULL; zid <- NULL; zid0 <- NULL; zid1 <- NULL; zid2 <- NULL; znms <- NULL; is_param <- NULL; is_fac <- NULL; vals <- NULL; st <- 1; ed <- 1
ztb <- list(); iztb <- 1
iadd <- 0
varlist_add <- NULL
xmat0_add <- NULL
#warp
warp.delta <- NULL
nums_wp <- NULL; ks_wp <- list(); ks_wps <- list(); sps_wp <- NULL
xmat_wp <- NULL; x1_wp <- NULL; x2_wp <- NULL; xnms_wp <- NULL; nks0_wp <- NULL; ks0_wp <- NULL; dc <- NULL
x1_wps <- NULL; x2_wps <- NULL; dcss <- list()
#zmat <- NULL; zid <- NULL; zid1 <- NULL; zid2 <- NULL; znms <- NULL; is_fac <- NULL; is_param <- NULL; vals <- NULL; st <- 1; ed <- 1
iwps <- 0
varlist_wps <- NULL
#tri
tri.delta <- NULL
nums_tri <- NULL; ks_tri <- list(); ks_tris <- list(); nks_tris <- list(); sps_tri <- NULL
xmat_tri <- NULL; x1_tri <- NULL; x2_tri <- NULL; xnms_tri <- NULL; nks0_tri <- NULL; ks0_tri <- NULL; cvs <- NULL
x1_tris <- NULL; x2_tris <- NULL; cvss <- list()
#zmat <- NULL; zid <- NULL; zid1 <- NULL; zid2 <- NULL; znms <- NULL; is_fac <- NULL; is_param <- NULL; vals <- NULL; st <- 1; ed <- 1
#print (dim(mf))
itri <- 0
#print (head(mf))
for (i in 2:ncol(mf)) {
#additive
#print (attributes(mf[,i])$class)
if (!is.null(attributes(mf[,i])$categ)) {
if (is.numeric(attributes(mf[,i])$shape) & (attributes(mf[,i])$categ == "additive")) {
labels <- c(labels, "additive")
shapes1_add <- c(shapes1_add, attributes(mf[,i])$shape)
xmat_add <- cbind(xmat_add, mf[,i])
xnms_add <- c(xnms_add, attributes(mf[,i])$nm)
nums_add <- c(nums_add, attributes(mf[,i])$numknots)
sps_add <- c(sps_add, attributes(mf[,i])$space)
ks_add[[xid_add]] <- attributes(mf[,i])$knots
xid_add <- xid_add + 1
}
if (is.character(attributes(mf[,i])$shape) & (attributes(mf[,i])$categ == "additive")) {
labels <- c(labels, "additive")
shapes2_add <- c(shapes2_add, attributes(mf[,i])$shape)
if (attributes(mf[,i])$shape == "tree") {
pl <- c(pl, attributes(mf[,i])$pl)
treei <- tree.fun(mf[,i], attributes(mf[,i])$pl)
tree.delta <- rbind(tree.delta, treei)
tpos1 <- tpos2 + 1
tpos2 <- tpos2 + nrow(treei)
tid1 <- c(tid1, tpos1)
tid2 <- c(tid2, tpos2)
tr <- cbind(tr, mf[,i])
}
if (attributes(mf[,i])$shape == "umbrella") {
umbi <- umbrella.fun(mf[,i])
umbrella.delta <- rbind(umbrella.delta, umbi)
upos1 <- upos2 + 1
upos2 <- upos2 + nrow(umbi)
uid1 <- c(uid1, upos1)
uid2 <- c(uid2, upos2)
umb <- cbind(umb, mf[,i])
}
}
#warp
#if (is.character(attributes(mf[, i])$shape) & (attributes(mf[,i])$categ == "warp")) {
#test more! shape is not pairs like c(1,1)
if ((attributes(mf[,i])$categ == "warp")) {
iwps <- iwps + 1
labels <- c(labels, rep(paste("warp", iwps, sep = "_"), 2))
sps_wp <- attributes(mf[, i])$space
dcs <- attributes(mf[, i])$decreasing
dcss[[iwps]] <- dcs
ks0_wp <- attributes(mf[, i])$knots
nks0_wp <- attributes(mf[, i])$numknots
x1_wp <- (mf[, i])[, 1]
x1_wps <- cbind(x1_wps, x1_wp)
x2_wp <- (mf[, i])[, 2]
x2_wps <- cbind(x2_wps, x2_wp)
xmat_wp <- cbind(xmat_wp, mf[, i])
xnms_wp <- c(xnms_wp, attributes(mf[, i])$name)
#print (xnms_wp)
#print (dim(xmat_wp))
#print (nks0_wp)
#print (ks0_wp)
#print (sps_wp)
ans_warp <- makedelta_wps(x1t = x1_wp, x2t = x2_wp, m1_0 = nks0_wp[1], m2_0 = nks0_wp[2], k1 = ks0_wp$k1, k2 = ks0_wp$k2, space = sps_wp, decreasing = dcs)
warp.delta0 <- ans_warp$delta
k1 <- ans_warp$k1
k2 <- ans_warp$k2
#print (k1)
#print (k2)
ks_wp[[1]] <- k1
ks_wp[[2]] <- k2
ks_wps[[iwps]] <- ks_wp
if (iwps > 1) {
warp.delta0 <- warp.delta0[,-1]
}
varlist_wps <- c(varlist_wps, 1:ncol(warp.delta0)*0 + iwps)
warp.delta <- cbind(warp.delta, warp.delta0)
#save(warp.delta, file='warpd.Rda')
#print (dim(warp.delta))
#print (ks_wps)
}
#tri
if (is.character(attributes(mf[, i])$shape) & (attributes(mf[,i])$categ == "tri")) {
itri <- itri + 1
labels <- c(labels, rep(paste("tri", itri, sep = "_"), 2))
sps_tri <- attributes(mf[, i])$space
cvs <- attributes(mf[, i])$cvs
cvss[[itri]] <- cvs
ks0_tri <- attributes(mf[, i])$knots
nks0_tri <- attributes(mf[, i])$numknots
ks_tris[[itri]] <- ks0_tri
nks_tris[[itri]] <- nks0_tri
x1_tri <- (mf[, i])[, 1]
x1_tris <- cbind(x1_tris, x1_tri)
x2_tri <- (mf[, i])[, 2]
x2_tris <- cbind(x2_tris, x2_tri)
#xmat_tri <- cbind(x1_tri, x2_tri)
xmat_tri <- cbind(xmat_tri, mf[, i])
xnms_tri <- c(xnms_tri, attributes(mf[, i])$name)
}
#print (class((mf[, i])))
}
if (is.null(attributes(mf[,i])$shape)) {
if (!is.null(names(mf)[i])) {
znms <- c(znms, names(mf)[i])
}
if (!is.matrix(mf[,i])) {
zid <- c(zid, i)
is_param <- c(is_param, TRUE)
if (is.factor(mf[,i])) {
is_fac <- c(is_fac, TRUE)
ch_char <- suppressWarnings(is.na(as.numeric(levels(mf[, i]))))
if (any(ch_char)) {
vals <- c(vals, unique(levels(mf[, i]))[-1])
} else {
vals <- c(vals, as.numeric(levels(mf[, i]))[-1])
}
nlvs <- length(attributes(mf[,i])$levels)
ed <- st + nlvs - 2
zid1 <- c(zid1, st)
zid2 <- c(zid2, ed)
st <- st + nlvs - 1
zmat0 <- model.matrix(~ mf[, i])[, -1, drop = FALSE]
zmat <- cbind(zmat, zmat0)
ztb[[iztb]] <- mf[,i]
iztb <- iztb + 1
} else {
is_fac <- c(is_fac, FALSE)
zmat <- cbind(zmat, mf[, i])
ztb[[iztb]] <- mf[,i]
iztb <- iztb + 1
ed <- st
zid1 <- c(zid1, st)
zid2 <- c(zid2, ed)
st <- st + 1
vals <- c(vals, "")
}
} else {
is_param <- c(is_param, FALSE)
is_fac <- c(is_fac, FALSE)
zmat0 <- mf[, i]
mat_cols <- ncol(zmat0)
mat_rm <- NULL
#rm_num <- 0
for (irm in 1:mat_cols) {
if (all(round(diff(zmat0[, irm]), 8) == 0)) {
mat_rm <- c(mat_rm, irm)
}
}
if (!is.null(mat_rm)) {
zmat0 <- zmat0[, -mat_rm, drop = FALSE]
#rm_num <- rm_num + length(mat_rm)
}
zmat <- cbind(zmat, zmat0)
ztb[[iztb]] <- mf[,i]
iztb <- iztb + 1
vals <- c(vals, 1)
zid <- c(zid, i)
nlvs <- ncol(zmat0) + 1
ed <- st + nlvs - 2
zid1 <- c(zid1, st)
zid2 <- c(zid2, ed)
st <- st + nlvs - 1
}
}
}
dimnames(zmat)[[2]] <- NULL
if (family$family == "binomial" | family$family == "poisson" | family$family == "Gamma") {
wt.iter = TRUE
} else {wt.iter = FALSE}
#attr(xmat, "shape") <- shapes1
#print (labels)
if (any(labels == "additive") | !is.null(zmat)) {
xmat0_add <- xmat_add; shapes0_add <- shapes1_add; nums0_add <- nums_add; ks0_add <- ks_add; sps0_add <- sps_add; xnms0_add <- xnms_add; idx_s <- NULL; idx <- NULL
if (any(shapes1_add == 17)) {
kshapes <- length(shapes1_add)
obs <- 1:kshapes
idx_s <- obs[which(shapes1_add == 17)]; idx <- obs[which(shapes1_add != 17)]
xmat0_add[ ,1:length(idx_s)] <- xmat_add[ ,idx_s]
shapes0_add[1:length(idx_s)] <- shapes1_add[idx_s]
nums0_add[1:length(idx_s)] <- nums_add[idx_s]
sps0_add[1:length(idx_s)] <- sps_add[idx_s]
ks0_add[1:length(idx_s)] <- ks_add[idx_s]
xnms0_add[1:length(idx_s)] <- xnms_add[idx_s]
if (length(idx) > 0) {
xmat0_add[ ,(1 + length(idx_s)):kshapes] <- xmat_add[ ,idx]
shapes0_add[(1 + length(idx_s)):kshapes] <- shapes1_add[idx]
nums0_add[(1 + length(idx_s)):kshapes] <- nums_add[idx]
sps0_add[(1 + length(idx_s)):kshapes] <- sps_add[idx]
ks0_add[(1 + length(idx_s)):kshapes] <- ks_add[idx]
xnms0_add[(1 +length(idx_s)):kshapes] <- xnms_add[idx]
}
#xmat <- xmat0; nums <- nums0; ks <- ks0; sps <- sps0; xnms <- xnms0
}
shapes_add <- c(shapes1_add, shapes2_add)
}
#print (labels)
xnms <- c(xnms_wp, xnms_add, xnms_tri)
xmat <- cbind(xmat_wp, xmat_add, xmat_tri)
colnames(xmat) <- xnms
#boolz <- is.null(labels) & !is.null(zmat)
if (all(labels == "additive")) {
if (is.null(shapes_add)) {
nsim <- 0
}
ans <- cgam.fit(y = y, xmat = xmat0_add, zmat = zmat, shapes = shapes0_add, numknots = nums0_add, knots = ks0_add, space = sps0_add, nsim = nsim, family = family, cpar = cpar, wt.iter = wt.iter, umbrella.delta = umbrella.delta, tree.delta = tree.delta, weights = weights, zid = zid, zid1 = zid1, zid2 = zid2, sc_x = sc_x, sc_y = sc_y, idx_s = idx_s, idx = idx, var.est = var.est, data = data)
if (!is.null(uid1) & !is.null(uid2)) {
uid1 <- uid1 + ans$d0 + ans$capm
uid2 <- uid2 + ans$d0 + ans$capm
}
if (!is.null(tid1) & !is.null(tid2)) {
tid1 <- tid1 + ans$d0 + ans$capm + ans$capu
tid2 <- tid2 + ans$d0 + ans$capm + ans$capu
}
#new:
knots_add <- ans$knots
numknots_add <- ans$numknots
#new:
if (length(knots_add) > 0) {
names(knots_add) <- xnms_add
}
rslt <- list(etahat = ans$etahat, muhat = ans$muhat, vcoefs = ans$vcoefs,
xcoefs = ans$xcoefs, zcoefs = ans$zcoefs, ucoefs = ans$ucoefs,
tcoefs = ans$tcoefs, coefs = ans$coefs, cic = ans$cic, d0 = ans$d0,
edf0 = ans$edf0, etacomps = ans$etacomps, y = y,
xmat_add = xmat_add, zmat = zmat, ztb = ztb, tr = tr, umb = umb,
tree.delta = tree.delta, umbrella.delta = umbrella.delta, bigmat = ans$bigmat,
shapes = shapes_add, shapesx = shapes1_add, shapesx0 = shapes0_add,
prior.w = weights, wt = ans$wt, wt.iter = ans$wt.iter,
family = family, SSE0 = ans$sse0, SSE1 = ans$sse1,
pvals.beta = ans$pvals.beta, se.beta = ans$se.beta,
df.null = ans$df.null, df = ans$df, df.residual = ans$df.residual,
edf = ans$df_obs, null.deviance = ans$dev.null, deviance = ans$dev,
tms = mt, capm = ans$capm, capms = ans$capms, capk = ans$capk, capt = ans$capt,
capu = ans$capu, xid1 = ans$xid1, xid2 = ans$xid2, tid1 = tid1, tid2 = tid2,
uid1 = uid1, uid2 = uid2, zid = zid, vals = vals, zid1 = zid1, zid2 = zid2,
nsim = nsim, xnms_add = xnms_add, xnms = xnms, ynm = ynm, znms = znms,
is_param = is_param, is_fac = is_fac, knots = knots_add, numknots = numknots_add,
sps = sps_add, ms = ans$ms, cpar = ans$cpar, pl = pl, idx_s = idx_s, idx = idx,
xmat0 = ans$xmat2, knots0 = ans$knots2, numknots0 = ans$numknots2, sps0 = ans$sps2,
ms0 = ans$ms2, phihat = ans$phihat, pvs = ans$pvs,
s.edf = ans$s.edf, bstats = ans$bstats, pvsz = ans$pvsz,
z.edf = ans$z.edf, fstats = ans$fstats, vh = ans$vh, kts.var = ans$kts.var,
sc = ans$sc, sc_y = sc_y)
rslt$call <- cl
class(rslt) <- "cgam"
} else if (any(grepl("warp", labels, fixed = TRUE)) & !any(grepl("tri", labels, fixed = TRUE))) {
nprs <- sum(grepl("warp", labels, fixed = TRUE)) / 2
delta_add <- NULL
ms <- NULL
np_add <- 0
pb <- 0
knotsuse_add <- NULL
if (any(labels == "additive")) {
#delta_add <- NULL
if (length(shapes0_add) > 0) {
ans_add <- make_delta_add(xmat = xmat0_add, shapes = shapes0_add, numknots = nums0_add, knots = ks0_add, space = sps0_add)
delta_add <- ans_add$bigmat
ms <- ans_add$mslst
#np_add: smooth only, conv and conc
np_add <- ans_add$np
pb <- nrow(delta_add)
varlist_add <- ans_add$varlist
knotsuse_add <- ans_add$knotsuse
}
}
delta_ut <- NULL
if (!is.null(umbrella.delta)) {
delta_add <- rbind(delta_add, umbrella.delta)
delta_ut <- rbind(delta_ut, umbrella.delta)
}
if (!is.null(tree.delta)) {
delta_add <- rbind(delta_add, tree.delta)
delta_ut <- rbind(delta_ut, tree.delta)
}
ans <- wps.fit(x1t = x1_wps, x2t = x2_wps, y = y, zmat = zmat, xmat_add = xmat_add, delta_add = delta_add, delta_ut = delta_ut, varlist_add = varlist_add, shapes_add = shapes_add, np_add = np_add, w = weights, pen = pen, pnt = pnt, cpar = cpar, decrs = dcss, delta = warp.delta, kts = ks_wps, wt.iter = wt.iter, family = family, cic = cic, nsim = nsim, nprs = nprs, idx_s = idx_s, idx = idx, gcv = gcv, pvf = pvf)
rslt <- list(ks_wps = ans$kts, muhat = ans$muhat, SSE1 = ans$sse1, SSE0 = ans$sse0, edfc = ans$edf, edf0 = ans$edf0, delta = ans$delta, y = y, zmat = ans$zmat, ztb = ztb, zmat_0 = ans$zmat_0, xmat_wp = xmat_wp, xmat_add = xmat_add, xmat0_add = xmat0_add, xmat = xmat, shapes = shapes_add, coefs = ans$coefs, zcoefs = ans$zcoefs, pvals.beta = ans$pz,pval=ans$pval,bval=ans$bval, se.beta = ans$sez, gcv = ans$gcv, xnms_wp = xnms_wp, xnms_add = xnms_add, xnms = xnms, xid_add = xid_add, znms = znms, zid = zid, vals = vals, zid1 = zid1, zid2 = zid2, ynm = ynm, decrs = dcss, tms = mt, mf = mf, is_param = is_param, is_fac = is_fac, d0 = ans$d0, pb = pb, pen = ans$pen, cpar = ans$cpar, wt.iter = wt.iter, cic = ans$cic, family = family, nprs_wps = nprs, varlist_wps = varlist_wps, coef_wp = ans$coef_wp, varlist_add = varlist_add, np_add = np_add, coef_add = ans$coef_add, coef_ut = ans$coef_ut, etacomps = ans$etacomps, amat = ans$amat, dmat = ans$dmat, prior.w = weights, sig2hat = ans$sig2hat, ms = ms, knotsuse_add = knotsuse_add, vmat = ans$vmat)
class(rslt) <- "wps"
if (!is.null(delta_add)) {
class(rslt) <- c("wps", "cgam")
if (min(which(labels == "additive")) < min(which(grepl("warp", labels, fixed = TRUE)))) {
class(rslt) <- c("cgam", "wps")
}
}
} else if (any(grepl("tri", labels, fixed = TRUE))) {
nprs <- sum(grepl("tri", labels, fixed = TRUE)) / 2
nprs_wps <- sum(grepl("warp", labels, fixed = TRUE)) / 2
amat_wp <- NULL
dmat_wp <- NULL
delta_add <- NULL
knotsuse_add <- NULL
ms <- NULL
np_add <- 0
pb <- 0
if (any(labels == "additive")) {
if (length(shapes0_add) > 0) {
ans_add <- make_delta_add(xmat = xmat0_add, shapes = shapes0_add, numknots = nums0_add, knots = ks0_add, space = sps0_add)
delta_add <- ans_add$bigmat
np_add <- ans_add$np
pb <- nrow(delta_add)
varlist_add <- ans_add$varlist
ms <- ans_add$mslst
knotsuse_add <- ans_add$knotsuse
}
}
if (!is.null(umbrella.delta)) {
delta_add <- rbind(delta_add, umbrella.delta)
}
if (!is.null(tree.delta)) {
delta_add <- rbind(delta_add, tree.delta)
}
if (any(grepl("warp", labels, fixed = TRUE))) {
ans_wps <- makeamat_wps(ks_wps, nprs_wps)
amat_wp <- ans_wps$amat
dmat_wp <- ans_wps$dmat
valist_wps <- ans_wps$valist_wps
}
ans <- trispl.fit(x1t = x1_tris, x2t = x2_tris, y = y, zmat = zmat, xmat_add = xmat_add, delta_add = delta_add, varlist_add = varlist_add, shapes_add = shapes_add, np_add = np_add, xmat_wp = xmat_wp, delta_wp = warp.delta, varlist_wps = varlist_wps, amat_wp = amat_wp, dmat_wp = dmat_wp, w = weights, lambda = pen, pnt = TRUE, cpar = cpar, cvss = cvss, delta = tri.delta, kts = ks_tris, nkts = nks_tris, wt.iter = wt.iter, family = family, nsim = nsim, nprs = nprs)
rslt <- list(muhat = ans$muhat, etahat = ans$etahat, trimat = ans$trimat, y = y, zmat = ans$zmat, ztb = ztb, capk = ans$capk, xmat_tri = xmat_tri, xmat_add = xmat_add, xmat0_add = xmat0_add, xmat_wp = xmat_wp, xmat = xmat, shapes = shapes_add, coefs = ans$thhat, zcoefs = ans$zcoefs, se.beta = ans$se.beta, pvals.beta = ans$pvals.beta, gcv = ans$gcv, edf = ans$edf, edf0 = ans$edf0, cic = ans$cic, sse0 = ans$sse0, sse1 = ans$sse1, family = family, nprs = nprs, nprs_wps = nprs_wps, varlist_wps = varlist_wps, varlist_add = varlist_add, varlist_tri = ans$varlist, xnms_tri = xnms_tri, xnms_add = xnms_add, xnms_wp = xnms_wp, xnms = xnms, znms = znms, zid = zid, vals = vals, zid1 = zid1, zid2 = zid2, ynm = ynm, decrs = dcss, cvss = cvss, tms = mt, is_param = is_param, is_fac = is_fac, d0 = ans$d0, pen = ans$pen, cpar = cpar, wt.iter = wt.iter, np_add = np_add, pb = pb, coef_add = ans$coef_add, coef_tri = ans$coef_tri, coef_wp = ans$coef_wp, etacomps = ans$etacomps, ks_wps = ks_wps, knots_lst = ans$knots_lst, m12_lst = ans$m12_lst, trimat_lst = ans$trimat_lst, bmat_lst = ans$bmat_lst, capk_lst = ans$capk_lst, prior.w = weights, dmatc = ans$dmatc, amatc = ans$amatc, pmatc = ans$pmatc, sig2hat = ans$sig2hat, knotsuse_add = knotsuse_add, ms = ms)
class(rslt) <- "trispl"
if (!is.null(delta_add) & is.null(warp.delta)) {
if (labels[1] == "additive") {
class(rslt) <- c("cgam", "trispl")
} else {class(rslt) <- c("trispl", "cgam")}
}
if (!is.null(warp.delta) & is.null(delta_add)) {
#if (labels[1] == "warp") {
if (grepl("warp", labels[1], fixed = TRUE)) {
class(rslt) <- c("wps", "trispl")
} else {class(rslt) <- c("trispl", "wps")}
}
if (!is.null(warp.delta) & !is.null(delta_add)) {
if (labels[1] == "additive") {
class(rslt) <- c("cgam", "trispl", "wps")
} else if (grepl("warp", labels[1], fixed = TRUE)) {
class(rslt) <- c( "wps", "trispl", "cgam")
} else {class(rslt) <- c("trispl", "cgam", "wps")}
}
}
}
rslt$call <- cl
rslt$labels <- labels
return (rslt)
}
###############
#amat function#
###############
amat.fun <- function(x)
{
obs <- 1:length(x)
amat <- NULL
xu <- unique(x)
nx <- sort(xu)
hd <- head(nx, 1)
tl <- nx
while (length(tl) > 1) {
hd <- head(tl, 1)
tl <- tl[-1]
paired <- 0
for (i in 1:length(tl)) {
a1 <- 1:length(x)*0
if (hd * tl[i] > 0) {
if (hd < 0) {
if (tl[i] > hd) {
a1[min(obs[which(x == hd)])] <- -1; a1[min(obs[which(x == tl[i])])] <- 1
} else {
a1[min(obs[which(x == hd)])] <- 1; a1[min(obs[which(x == tl[i])])] <- -1
}
}
if (hd > 0) {
if (tl[i] < hd) {
a1[min(obs[which(x == hd)])] <- -1; a1[min(obs[which(x == tl[i])])] <- 1
} else {
a1[min(obs[which(x == hd)])] <- 1; a1[min(obs[which(x == tl[i])])] <- -1
}
}
#if (!all(a1 == 0) & paired == 0 ) {amat <- rbind(amat, a1); paired <- 1}
}
if (hd * tl[i] == 0) {
if (hd == 0) {
#if (tl[i] > 0) {
a1[min(obs[which(x == hd)])] <- 1; a1[min(obs[which(x == tl[i])])] <- -1
#}
} else {
a1[min(obs[which(x == hd)])] <- -1; a1[min(obs[which(x == tl[i])])] <- 1
}
}
if (!all(a1 == 0) & paired == 0 ) {amat <- rbind(amat, a1); paired <- 1}
}
}
dimnames(amat) <- NULL
amat
}
###############
#bmat function#
###############
bmat.fun <- function(x)
{
obs <- 1:length(x)
bmat <- NULL
hd <- head(x, 1)
tl <- x
j <- 0
while (length(tl) > 1) {
hd <- head(tl, 1)
tl <- tl[-1]
paired <- 0
j <- j + 1
for (i in 1:length(tl)) {
b1 <- 1:length(x)*0
if (hd == tl[i]) {b1[j] <- -1; b1[j + i] <- 1}
if (!all(b1 == 0) & paired == 0 ) {bmat <- rbind(bmat, b1); paired <- 1}
}
}
dimnames(bmat) <- NULL
bmat
}
##########
#cgam.fit#
##########
cgam.fit <- function(y, xmat, zmat, shapes, numknots, knots, space, nsim, family = gaussian(), cpar = 1.2, wt.iter = FALSE, umbrella.delta = NULL, tree.delta = NULL, weights = NULL, zid = zid, zid1 = zid1, zid2 = zid2, sc_x = FALSE, sc_y = FALSE, idx_s = NULL, idx = NULL, var.est = NULL, data = NULL) {
cicfamily <- CicFamily(family)
llh.fun <- cicfamily$llh.fun
#new: use log link in gamma
linkfun <- cicfamily$linkfun
etahat.fun <- cicfamily$etahat.fun
gr.fun <- cicfamily$gr.fun
wt.fun <- cicfamily$wt.fun
zvec.fun <- cicfamily$zvec.fun
muhat.fun <- cicfamily$muhat.fun
ysim.fun <- cicfamily$ysim.fun
deriv.fun <- cicfamily$deriv.fun
dev.fun <- cicfamily$dev.fun
n <- length(y)
sm <- 1e-7
#sm <- 1e-5
capl <- length(xmat) / n
if (capl < 1) {capl <- 0}
if (round(capl, 8) != round(capl, 1)) {stop ("Incompatible dimensions for xmat!")}
#new:
if (capl > 0 & sc_x) {
for (i in 1:capl) {xmat[,i] <- (xmat[,i] - min(xmat[,i])) / (max(xmat[,i]) - min(xmat[,i]))}
#for (i in 1:capl) {xmat[,i] <- (xmat[,i] - mean(xmat[,i])) / sd(xmat[,i])}
#for (i in 1:capl) {xmat[,i] <- xmat[,i] / sd(xmat[,i])}
}
#new:
sc <- 1
if (sc_y) {
sc <- sd(y)
y <- y / sc
}
capk <- length(zmat) / n
if (capk < 1) {capk <- 0}
if (round(capk, 8) != round(capk, 1)) {stop ("Incompatible dimensions for zmat!")}
#new:
capls <- sum(shapes == 17)
####################################################
#get basis functions for the constrained components#
####################################################
delta <- NULL
varlist <- NULL
xid1 <- NULL; xid2 <- NULL; xpos2 <- 0
knotsuse <- list(); numknotsuse <- NULL
mslst <- list()
#new:
capm <- 0
capms <- 0
if (capl - capls > 0) {
del1_ans <- makedelta(xmat[, 1], shapes[1], numknots[1], knots[[1]], space = space[1])
del1 <- del1_ans$amat
knotsuse[[1]] <- del1_ans$knots
mslst[[1]] <- del1_ans$ms
if(shapes[1] >= 9 & shapes[1] <= 17) {
numknotsuse <- c(numknotsuse, length(del1_ans$knots))
} else {
numknotsuse <- c(numknotsuse, nrow(del1))
}
m1 <- length(del1) / n
#new code: record the number of columns of del1 if shapes0[1] == 17:
if (shapes[1] == 17) {capms <- capms + m1}
var1 <- 1:m1*0 + 1
xpos1 <- xpos2 + 1
xpos2 <- xpos2 + m1
xid1 <- c(xid1, xpos1)
xid2 <- c(xid2, xpos2)
if (capl == 1) {
delta <- del1
varlist <- var1
} else {
for (i in 2:capl) {
#new code:
del2_ans <- makedelta(xmat[,i], shapes[i], numknots[i], knots[[i]], space = space[i])
del2 <- del2_ans$amat
knotsuse[[i]] <- del2_ans$knots
mslst[[i]] <- del2_ans$ms
if(shapes[i] >= 9 & shapes[i] <= 17) {
numknotsuse <- c(numknotsuse, length(del2_ans$knots))
} else {
numknotsuse <- c(numknotsuse, nrow(del2))
}
#numknotsuse <- c(numknotsuse, length(del2_ans$knots))
m2 <- length(del2) / n
#new code: record the number of columns of del2 if shapes0[i] == 17:
if (shapes[i] == 17) {capms <- capms + m2}
xpos1 <- xpos2 + 1
xpos2 <- xpos2 + m2
xid1 <- c(xid1, xpos1)
xid2 <- c(xid2, xpos2)
delta <- rbind(del1, del2)
varlist <- 1:(m1 + m2)*0
varlist[1:m1] <- var1
varlist[(m1 + 1):(m1 + m2)] <- (1:m2)*0 + i
var1 <- varlist
m1 <- m1 + m2
del1 <- delta
}
}
if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0 & capk > 0) {
bigmat <- rbind(1:n*0 + 1, t(zmat), t(xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13]), delta)
np <- 1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0 & capk == 0) {
bigmat <- rbind(1:n*0 + 1, t(xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13]), delta)
np <- 1 + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0 & capk > 0) {
bigmat <- rbind(1:n*0 + 1, t(zmat), delta)
np <- 1 + capk + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0 & capk == 0) {
bigmat <- rbind(1:n*0 + 1, delta)
np <- 1 + capms
} else {
print ("error in capk, shapes!")
}
#new:
capm <- length(delta) / n - capms
} else {
if (capk + capls > 0) {
#new:
if (capls < 1 & capk > 0) {
bigmat <- rbind(1:n*0 + 1, t(zmat))
np <- 1 + capk
} else if (capls > 0) {
delta <- NULL; varlist <- NULL
del1_ans <- makedelta(xmat[,1], 17, numknots[1], knots[[1]], space = space[1])
del1 <- del1_ans$amat
knotsuse[[1]] <- del1_ans$knots
mslst[[1]] <- del1_ans$ms
numknotsuse <- c(numknotsuse, length(del1_ans$knots))
m1 <- length(del1) / n
var1 <- 1:m1*0 + 1
xpos1 <- xpos2 + 1
xpos2 <- xpos2 + m1
xid1 <- c(xid1, xpos1)
xid2 <- c(xid2, xpos2)
if (capls == 1) {
delta <- del1
varlist <- var1
} else {
for (i in 2:capls) {
del2_ans <- makedelta(xmat[,i], 17, numknots[i], knots[[i]], space = space[i])
del2 <- del2_ans$amat
knotsuse[[i]] <- del2_ans$knots
mslst[[i]] <- del2_ans$ms
numknotsuse <- c(numknotsuse, length(del2_ans$knots))
m2 <- length(del2) / n
xpos1 <- xpos2 + 1
xpos2 <- xpos2 + m2
xid1 <- c(xid1, xpos1)
xid2 <- c(xid2, xpos2)
delta <- rbind(del1, del2)
varlist <- 1:(m1 + m2)*0
varlist[1:m1] <- var1
varlist[(m1 + 1):(m1 + m2)] <- (1:m2)*0 + i
var1 <- varlist
m1 <- m1 + m2
del1 <- delta
}
}
if (capk < 1){
bigmat <- rbind(1:n*0 + 1, delta)
capms <- length(delta) / n
np <- 1 + capms
} else {
bigmat <- rbind(1:n*0 + 1, t(zmat), delta)
capms <- length(delta) / n
np <- 1 + capk + capms
}
}
} else {bigmat <- matrix(1:n*0 + 1, nrow = 1); capm <- 0; capms <- 0; np <- 1}
}
if (!is.null(umbrella.delta)) {
bigmat <- rbind(bigmat, umbrella.delta)
capu <- length(umbrella.delta) / n
} else {capu <- 0}
if (!is.null(tree.delta)) {
bigmat <- rbind(bigmat, tree.delta)
capt <- length(tree.delta) / n
} else {capt <- 0}
if (!is.null(umbrella.delta) | !is.null(tree.delta))
delta_ut <- rbind(umbrella.delta, tree.delta)
if (capl + capk + capu + capt > 0) {
# if (capl + capu + capt > 0) {
#new:
if (capl - capls + capu + capt > 0) {
#new:initialize cvec
cvec <- NULL
#new: initialize face
face <- NULL
if (wt.iter) {
etahat <- etahat.fun(n, y, fml = family$family)
gr <- gr.fun(y, etahat, weights, fml = family$family)
wt <- wt.fun(y, etahat, n, weights, fml = family$family)
cvec <- wt * etahat - gr
} else {wt <- wt.fun(y, etahat, n, weights, fml = family$family)}
zvec <- zvec.fun(cvec, wt, y, fml = family$family)
# gmat <- t(bigmat %*% sqrt(diag(wt)))
#new: avoid memory allocation error
gmat <- t(bigmat)
for (i in 1:n) {gmat[i,] <- bigmat[,i] * sqrt(wt[i])}
dsend <- gmat[, (np + 1):(np + capm + capu + capt), drop = FALSE]
zsend <- gmat[, 1:np, drop = FALSE]
#ans <- coneB(zvec, t(dsend), zsend)
ans <- coneB(zvec, dsend, zsend)
face <- ans$face
etahat <- t(bigmat) %*% ans$coefs
#new: for monotinic variance estimation
vh <- NULL
kts.var <- NULL
if (!is.null(var.est)) {
#x.var <- var.est
#test more:
if (!is.null(data)) {
nms <- names(data)
nm <- attributes(var.est)$nm
if (nm %in% nms) {
x.var <- data[[nm]]
attributes(x.var) <- attributes(var.est)
}
} else {x.var <- var.est}
db.exp <- attributes(x.var)$db.exp
kts.var <- attributes(x.var)$var.knots
shape.var <- attributes(x.var)$shape
iter <- 0
diff.var <- 100
oldeta <- etahat
evec0 <- y - etahat
#bigwt <- 10*max(evec0)
bigwt <- 1000
while(diff.var > 1e-8 & iter < 10) {
iter <- iter + 1
evec <- y - etahat
fit.var <- varest(evec, x.var, shape=shape.var, var.knots=kts.var, db.exp=db.exp)
v1 <- fit.var$vhat
wt0 <- 1/v1
wt0[wt0 > bigwt] <- bigwt
wt <- wt.fun(y, etahat, n, weights = wt0, fml = family$family)
zvec <- zvec.fun(cvec, wt, y, fml = family$family)
gmat <- t(bigmat)
for (i in 1:n) {gmat[i,] <- bigmat[,i] * sqrt(wt[i])}
dsend <- gmat[, (np + 1):(np + capm + capu + capt), drop = FALSE]
zsend <- gmat[, 1:np, drop = FALSE]
ans <- coneB(zvec, dsend, zsend)
etahat <- t(bigmat) %*% ans$coefs
diff.var <- mean((etahat - oldeta)^2)
oldeta <- etahat
}
kts.var <- fit.var$var.knots
vh <- v1
}
if (wt.iter) {
muhat <- muhat.fun(etahat, fml = family$family)
diff <- 1
if (family$family == "binomial") {
mdiff <- abs(max(muhat) - 1) > sm
} else {mdiff <- TRUE}
nrep <- 0
##########
#iterate!#
##########
while (diff > sm & mdiff & nrep < n^2){
oldmu <- muhat
nrep <- nrep + 1
gr <- gr.fun(y, etahat, weights, fml = family$family)
wt <- wt.fun(y, etahat, n, weights, fml = family$family)
cvec <- wt * etahat - gr
#zvec <- cvec / sqrt(wt)
zvec <- zvec.fun(cvec, wt, y, fml = family$family)
# gmat <- t(bigmat %*% sqrt(diag(wt)))
gmat <- t(bigmat)
for (i in 1:n) {gmat[i,] <- bigmat[,i] * sqrt(wt[i])}
dsend <- gmat[, (np + 1):(np + capm + capu + capt), drop = FALSE]
zsend <- gmat[, 1:np, drop = FALSE]
#ans <- coneB(zvec, t(dsend), zsend)
ans <- coneB(zvec, dsend, zsend, face = face)
etahat <- t(bigmat) %*% ans$coefs
muhat <- muhat.fun(etahat, fml = family$family)
diff <- mean((muhat - oldmu)^2)
mdiff <- abs(max(muhat) - 1)
if (family$family == "binomial") {
mdiff <- abs(max(muhat) - 1) > sm
} else {mdiff <- TRUE}
}
}
yhat <- ans$yhat
coefskeep <- ans$coefs
########################
#if capk >= 0, we have:#
########################
zcoefs <- coefskeep[1:(capk + 1)]
######################
#we will always have:#
######################
vcoefs <- coefskeep[1:np]
#######################
#if capm > 0, we have:#
#######################
xcoefs <- NULL
#if (capm > 0) {
# xcoefs <- coefskeep[(np + 1):(np + capm)]
#}
#new:
if (capl > 0) {
xcoefs <- coefskeep[(np - capms + 1):(np + capm)]
}
#######################
#if capu > 0, we have:#
#######################
ucoefs <- NULL
if (capu > 0) {
ucoefs <- coefskeep[(np + 1 + capm):(np + capm + capu)]
}
#######################
#if capt > 0, we have:#
#######################
tcoefs <- NULL
if (capt > 0) {
tcoefs <- coefskeep[(np + 1 + capm + capu):(np + capm + capu + capt)]
}
#########################################################
#if we have at least one constrained predictor, we have:#
#########################################################
thvecs <- NULL
if (capl > 0) {
#new code:
dcoefs <- coefskeep[(np - capms + 1):(np + capm)]
#dcoefs <- coefskeep[(np + 1):(np + capm)]
#####################################################
#thvecs is f(x), where x has one of the eight shapes#
#####################################################
thvecs <- matrix(nrow = capl, ncol = n)
ncon <- 1
for (i in 1:capl) {
thvecs[i,] <- t(delta[varlist == i,]) %*% dcoefs[varlist == i]
#new:
#if (shapes[i] > 2 & shapes[i] < 5) {
if (shapes[i] > 2 & shapes[i] < 5 | shapes[i] > 10 & shapes[i] < 13) {
ncon <- ncon + 1
#thvecs[i,] <- thvecs[i,] + zcoefs[ncon] * xmat[,i]
thvecs[i,] <- thvecs[i,] + vcoefs[capk + ncon] * xmat[,i]
}
}
}
#new:order thvecs back
#print (idx_s)
#print (idx)
#if (!is.null(idx_s)) {
if (length(idx_s) > 0) {
thvecs0 <- thvecs
thvecs0[idx_s,] <- thvecs[1:length(idx_s), ]
#if (!is.null(idx)) {
if (length(idx) > 0) {
thvecs0[idx,] <- thvecs[(1+length(idx_s)):capl, ]
}
thvecs <- thvecs0
}
thvecs_ut <- NULL
if (capu + capt > 0) {
thvecs_ut <- t(delta_ut) %*% coefskeep[(np + 1 + capm):(np + capm + capu + capt)]
}
if (!is.null(thvecs_ut)) {
thvecs <- rbind(thvecs, t(thvecs_ut))
}
#new: problem when not gaussian
if (sc_y) {
y <- y*sc
etahat <- etahat*sc
for (i in 1:nrow(thvecs)) {
thvecs[i,] <- thvecs[i,] * sc
}
}
etakeep <- etahat
muhatkeep <- muhat.fun(etakeep, fml = family$family)
wtkeep <- wt
df_obs <- sum(abs(coefskeep) > 0)
#llh <- llh.fun(y, muhat, etahat, n, weights, fml = family$family)
if (family$family == "Gamma") {
if ((n - cpar * df_obs) <= 0) {
phihat <- sum(((y - muhatkeep) / muhatkeep)^2) / df_obs
} else {
phihat <- sum(((y - muhatkeep) / muhatkeep)^2) / (n - cpar * df_obs)
}
} else {phihat <- NULL}
#print (phihat)
llh <- llh.fun(y, muhatkeep, etakeep, phihat, n, weights, fml = family$family)
if (family$family == "poisson") {
mu0 <- mean(y)
eta0 <- log(mu0)
} else {mu0 <- NULL}
#new: get p-values for smooth components
pvs <- NULL
s.edf <- NULL
bstats <- NULL
if (is.numeric(shapes)) {
#changed to include shape==17
#if (all(shapes >= 9 & shapes <= 17)) {
if (any(shapes >= 9 & shapes <= 17)) {
for (i in 1:capl) {
if (shapes[i] >= 1 & shapes[i] <= 17 ){
ansi <- cgam.pv(y=y, xmat=xmat, zmat=zmat, shapes=shapes, delta=delta, np=np, capms=capms, numknotsuse=numknotsuse, varlist=varlist, family=family, weights=weights, test_id=i, nsims=100)
pvi <- ansi$pv
edfi <- 1.5*sum(xcoefs[varlist == i] > 1e-8)
bstati <- ansi$bstat
pvs <- c(pvs, pvi)
s.edf <- c(s.edf, edfi)
bstats <- c(bstats, bstati)
}
#print (pvs)
}
}
}
#new: get p-values for categorical predictors, not for each level
pvsz <- NULL
z.edf <- NULL
fstats <- NULL
#temp: use cgam.pvz only when there's smooth component
if (is.numeric(shapes)) {
#changed to include shape==17
if (all(shapes >= 9 & shapes <= 17)) {
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
prior.w <- weights
if (capk > 0) {
sse1 <- sum(prior.w * (y - muhatkeep)^2)
ansi <- cgam.pvz(y=y, bigmat=bigmat, df_obs=df_obs, sse1=sse1, np=np, zid=zid, zid1=zid1, zid2=zid2, muhat = muhatkeep, etahat = etakeep, coefskeep = coefskeep, wt.iter=wt.iter, family=family, weights=weights)
pvsz <- ansi$pvs
z.edf <- ansi$edfs
fstats <- ansi$fstats
}
}
}
} else if (capk + capls > 0 & capl - capls + capt + capu == 0) {
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
prior.w <- weights
vmat <- t(bigmat[1:np, , drop = FALSE])
if (wt.iter) {
nrep <- 0
muhat <- mean(y) + 1:n*0
etahat <- linkfun(muhat)
diff <- 1
if (family$family == "binomial") {
mdiff <- abs(max(muhat) - 1) > sm
} else {mdiff <- TRUE}
while (diff > sm & mdiff & nrep < n^2) {
nrep <- nrep + 1
oldmu <- muhat
zhat <- etahat + (y - muhat) * deriv.fun(muhat, fml = family$family)
#w <- diag(as.vector(prior.w / deriv.fun(muhat)))
#w <- diag(as.vector(prior.w * (deriv.fun(muhat, fml = family$family))^(-1)))
#b <- solve(t(vmat) %*% w %*% vmat) %*% t(vmat) %*% w %*% zhat
w <- as.vector(prior.w * (deriv.fun(muhat, fml = family$family))^(-1))
tvmat <- t(vmat)
for (i in 1:n) {tvmat[,i] <- tvmat[,i] * w[i]}
#print (tvmat)
b <- solve(tvmat %*% vmat) %*% tvmat %*% zhat
etahat <- vmat %*% b
muhat <- muhat.fun(etahat, fml = family$family)
diff <- mean((muhat - oldmu)^2)
mdiff <- abs(max(muhat) - 1)
if (family$family == "binomial") {
mdiff <- abs(max(muhat) - 1) > sm
} else {mdiff <- TRUE}
}
zcoefs <- b[1:(capk + 1)]
#se.beta <- sqrt(diag(solve(t(vmat) %*% w %*% vmat)))[1:(capk + 1)]
se.beta <- sqrt(diag(solve(tvmat %*% vmat)))[1:(capk + 1)]
zstat <- zcoefs / se.beta
pvals.beta <- 1 - pchisq(zstat^2, df = 1)
#new: gamma only
if (family$family == "Gamma") {
phihat <- sum(((y - muhatkeep) / muhatkeep)^2) / (n - np)
} else {phihat <- NULL}
} else {
#w <- diag(prior.w)
#b <- solve(t(vmat) %*% w %*% vmat) %*% t(vmat) %*% w %*% y
w <- prior.w
tvmat <- t(vmat)
for (i in 1:n) {tvmat[,i] <- tvmat[,i] * w[i]}
b <- solve(tvmat %*% vmat) %*% tvmat %*% y
etahat <- vmat %*% b
muhat <- muhat.fun(etahat, fml = family$family)
sdhat2 <- sum(prior.w * (y - muhat)^2) / (n - np)
zcoefs <- b[1:(capk + 1)]
se.beta <- sqrt(diag(solve(tvmat %*% vmat) * sdhat2))[1:(capk + 1)]
tstat <- zcoefs / se.beta
pvals.beta <- (1 - pt(abs(tstat), df = n - np)) * 2
#new: for var estimation
vh <- NULL
kts.var <- NULL
if (!is.null(var.est)) {
x.var <- var.est
db.exp <- attributes(x.var)$db.exp
kts.var <- attributes(x.var)$var.knots
shape.var <- attributes(x.var)$shape
iter <- 0
diff.var <- 100
oldeta <- etahat
evec0 <- y - oldeta
#bigwt <- 10*max(evec0)
bigwt <- 1000
while(diff.var > 1e-8 & iter < 10) {
iter <- iter + 1
evec <- y - etahat
fit.var <- varest(evec, x.var, shape=shape.var, var.knots=kts.var, db.exp=db.exp)
v1 <- fit.var$vhat
#w <- 1/v1
w0 <- 1/v1
w0[w0 > bigwt] <- bigwt
w <- w0
tvmat <- t(vmat)
for (i in 1:n) {tvmat[,i] <- tvmat[,i] * w[i]}
b <- solve(tvmat %*% vmat) %*% tvmat %*% y
etahat <- vmat %*% b
diff.var <- mean((etahat - oldeta)^2)
oldeta <- etahat
#print (diff.var)
}
kts.var <- fit.var$var.knots
vh <- v1
}
}
#add thvecs if capls > 0:
thvecs <- NULL
if (capls > 0) {
thvecs <- matrix(nrow = capls, ncol = n)
dcoefs <- b[(capk + 2):np]
for (i in 1:capls) {
thvecs[i,] <- t(delta[varlist == i,]) %*% dcoefs[varlist == i]
}
}
#new:
if (sc_y) {
y <- y*sc
etahat <- etahat*sc
muhat <- muhat.fun(etahat, fml = family$family)
for (i in 1:nrow(thvecs)) {
thvecs[i,] = thvecs[i,] * sc
}
}
llh <- llh.fun(y, muhat, etahat, phihat, n, weights, fml = family$family)
df_obs <- np
dfmean <- np
rslt <- new.env()
rslt$family <- family
rslt$wt.iter <- wt.iter
#rslt$wt <- diag(w)
rslt$wt <- w
rslt$bigmat <- bigmat
rslt$etahat <- etahat
rslt$muhat <- muhat
rslt$d0 <- np
rslt$capm <- 0
rslt$capms <- capms
rslt$capk <- capk
rslt$capu <- capu
rslt$capt <- capt
rslt$xid1 <- xid1 + np - capms
rslt$xid2 <- xid2 + np - capms
rslt$dfmean <- dfmean
rslt$edf0 <- dfmean
#rslt$llh <- llh
#if (nsim > 0) {
if (family$family == "binomial") {
nobs <- sum(prior.w)
} else {nobs <- n}
if ((nobs - np - cpar * (dfmean - np)) <= 0) {
rslt$cic <- llh + log(1 + 2 * dfmean / (dfmean - np))
} else {
#new:
if (n<=200){cpar=1.5}
rslt$cic <- llh + log(1 + 2 * dfmean / (nobs - np - cpar * (dfmean - np)))
}
#rslt$cic <- llh + log(1 + 2 * dfmean / (n - np - 1.5 * (dfmean - np)))
#}
rslt$zcoefs <- zcoefs
rslt$coefs <- b
rslt$vcoefs <- b
rslt$xcoefs <- b[(capk + 2):np]
rslt$se.beta <- se.beta
rslt$pvals.beta <- pvals.beta
rslt$dev <- dev.fun(y, muhat, etahat, weights, fml = family$family)$dev
rslt$dev.null <- dev.fun(y, muhat, etahat, weights, fml = family$family)$dev.null
rslt$df <- n - np
rslt$df.null <- n - 1
#rslt$df.residual <- n - np - 1.5 * (df_obs - np)
rslt$df.residual <- n - cpar * df_obs
rslt$vhat <- etahat
rslt$vmat <- vmat
rslt$etacomps <- thvecs
rslt$knots <- knotsuse
rslt$numknots <- numknotsuse
rslt$ms <- mslst
#new: used for predict when there are only shape == 17 x's
#rslt$xmat <- xmat
rslt$xmat2 <- xmat
rslt$knots2 <- knotsuse
rslt$numknots2 <- numknotsuse
rslt$ms2 <- mslst
rslt$vh <- vh
rslt$kts.var <- kts.var
return (rslt)
}
##########
#get cic#
##########
if (capl - capls + capu + capt > 0 & nsim > 0) {
dfs <- 1:nsim
#new: initialize face
face <- NULL
for (isim in 1:nsim) {
#set.seed(123)
ysim <- ysim.fun(n, mu0, fml = family$family)
if (wt.iter) {
etahat <- etahat.fun(n, ysim, fml = family$family)
gr <- gr.fun(ysim, etahat, weights, fml = family$family)
wt <- wt.fun(ysim, etahat, n, weights, fml = family$family)
cvec <- wt * etahat - gr
} else {wt <- wt.fun(ysim, etahat, n, weights, fml = family$family)}
zvec <- zvec.fun(cvec, wt, ysim, fml = family$family)
# gmat <- t(bigmat %*% sqrt(diag(wt)))
gmat <- t(bigmat)
for (i in 1:n) {gmat[i,] <- bigmat[,i] * sqrt(wt[i])}
dsend <- gmat[, (np + 1):(np + capm + capu + capt), drop = FALSE]
zsend <- gmat[, 1:np, drop = FALSE]
#ans <- try(coneB(zvec, t(dsend), zsend))
ans <- try(coneB(zvec, dsend, zsend))
face <- ans$face
#if (class(ans) == "try-error") next
if(inherits(ans, "try-error")) next
if (wt.iter) {
etahat <- t(bigmat) %*% ans$coefs
muhat <- muhat.fun(etahat, fml = family$family)
diff <- 1
if (family$family == "binomial") {
mdiff <- abs(max(muhat) - 1) > sm
} else {mdiff <- TRUE}
##########
#iterate!#
##########
nrep <- 0
while (diff > sm & nrep < n^2 & mdiff > sm) {
nrep <- nrep + 1
oldmu <- muhat
gr <- gr.fun(ysim, etahat, weights, fml = family$family)
wt <- wt.fun(ysim, etahat, n, weights, fml = family$family)
cvec <- wt * etahat - gr
#zvec <- cvec / sqrt(wt)
zvec <- zvec.fun(cvec, wt, y, fml = family$family)
# gmat <- t(bigmat %*% sqrt(diag(wt)))
gmat <- t(bigmat)
for (i in 1:n) {gmat[i,] <- bigmat[,i] * sqrt(wt[i])}
dsend <- gmat[, (np + 1):(np + capm + capu + capt), drop = FALSE]
zsend <- gmat[, 1:np, drop = FALSE]
#ans <- try(coneB(zvec, t(dsend), zsend))
ans <- try(coneB(zvec, dsend, zsend, face=face))
#if (class(ans) == "try-error") next
if(inherits(ans, "try-error")) next
etahat <- t(bigmat) %*% ans$coefs
muhat <- muhat.fun(etahat, fml = family$family)
diff <- mean((muhat - oldmu)^2)
if (family$family == "binomial") {
mdiff <- abs(max(muhat) - 1) > sm
} else {mdiff <- TRUE}
}
}
dfs[isim] <- sum(abs(ans$coefs) > 0)
}
dfmean <- mean(dfs)
#print (dfmean)
} else if (capl - capls + capu + capt > 0 & nsim == 0) {
dfmean <- NULL
}
###################################################
#if the user does not give any predictor, we have:#
###################################################
} else {
rslt <- new.env()
rslt$family <- family
rslt$wt.iter <- wt.iter
rslt$muhat <- 1:n*0 + mean(y)
rslt$etahat <- linkfun(muhat)
rslt$dfmean <- 1
print ("No predictor is provided")
return (rslt)
}
if (capl - capls + capu + capt > 0) {
#new:
#exclude the case we only have z or unrestricted smooth
xid1 <- xid1 + np - capms
xid2 <- xid2 + np - capms
#xid1 <- xid1 + np
#xid2 <- xid2 + np
rslt <- new.env()
rslt$phihat <- phihat
rslt$family <- family
rslt$wt.iter <- wt.iter
rslt$wt <- wtkeep
rslt$bigmat <- bigmat
rslt$etahat <- etakeep
rslt$muhat <- muhatkeep
rslt$d0 <- np
rslt$capm <- capm
rslt$capms <- capms
rslt$capk <- capk
rslt$capu <- capu
rslt$capt <- capt
rslt$xid1 <- xid1
rslt$xid2 <- xid2
rslt$coefs <- coefskeep
rslt$vcoefs <- vcoefs
rslt$xcoefs <- xcoefs
rslt$zcoefs <- zcoefs
rslt$ucoefs <- ucoefs
rslt$tcoefs <- tcoefs
rslt$dfmean <- dfmean
#rslt$llh <- llh
#if (nsim > 0) {
if (!is.null(dfmean)) {
#check!
#new: use dfmean - np if n - np - 1.5 * (dfmean - np) < 0
if ((n - np - cpar * (dfmean - np)) <= 0) {
rslt$cic <- llh + log(1 + 2 * dfmean / (dfmean - np))
} else {
#new:
if (n<=200){cpar=1.5}
rslt$cic <- llh + log(1 + 2 * dfmean / (n - np - cpar * (dfmean - np)))
}
} else {rslt$cic <- NULL}
rslt$edf0 <- dfmean
rslt$etacomps <- thvecs
vmat <- t(bigmat[1:np, , drop = FALSE])
rslt$vmat <- vmat
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
prior.w <- weights
#w <- diag(as.vector(prior.w / deriv.fun(muhatkeep, fml = family$family)))
w <- as.vector(prior.w / deriv.fun(muhatkeep, fml = family$family))
###############################################
#the case capk = 0 and capk >= 0 are combined:#
###############################################
#debugged: vhat -> muhat.fun(vhat)
vhat <- vmat %*% vcoefs
muvhat <- muhat.fun(vhat, fml = family$family)
#debugged: yhat -> muhatkeep
sse1 <- sum(prior.w * (y - muhatkeep)^2)
sse0 <- sum(prior.w * (y - muvhat)^2)
#new:
#if ((n - np - cpar * df_obs) <= 0) {
if ((n - cpar * df_obs) <= 0) {
#sdhat2 <- sse1 / (df_obs - np)
sdhat2 <- sse1 / df_obs
} else {
#sdhat2 <- sse1 / (n - np - 1.5 * (df_obs - np))
#sdhat2 <- sse1 / (n - np - cpar * df_obs)
sdhat2 <- sse1 / (n - cpar * df_obs)
}
#debugged: vmat -> vmat and duse
#new: coefskeep include zcoefs; bigmat include vmat
pmat <- vmat
capbm <- length(bigmat) / n
bigmat_nv <- bigmat[(np + 1):capbm, , drop = FALSE]
coefs_nv <- coefskeep[(np + 1):capbm]
duse <- coefs_nv > 1e-8
if (sum(duse) >= 1) {
pmat <- cbind(vmat, t(bigmat_nv[duse, , drop = FALSE]))
}
if (wt.iter) {
#new:
tpmat <- t(pmat)
for (i in 1:n) {tpmat[,i] <- tpmat[,i] * w[i]}
se2 <- solve(tpmat %*% pmat)
} else {
# se2 <- solve(t(pmat) %*% diag(prior.w) %*% pmat) * sdhat2
tpmat <- t(pmat)
for (i in 1:n) {tpmat[,i] <- tpmat[,i] * prior.w[i]}
se2 <- solve(tpmat %*% pmat) * sdhat2
}
se.beta <- 1:(capk + 1)*0
tstat <- 1:(capk + 1)*0
pvals.beta <- 1:(capk + 1)*0
rslt$zcoefs <- zcoefs
for (i in 1:(capk + 1)) {
se.beta[i] <- sqrt(se2[i,i])
tstat[i] <- zcoefs[i] / se.beta[i]
#new code: n - np - 1.5 * (df_obs - np) must be positive
#if ((n - np - cpar * df_obs) <= 0) {
if ((n - cpar * df_obs) <= 0) {
pvals.beta[i] <- 2 * (1 - pt(abs(tstat[i]), df_obs))
warning ('Effective degrees of freedom is close to the number of observations! Inference about parametric covariates is not reliable!')
} else {
#pvals.beta[i] <- 2 * (1 - pt(abs(tstat[i]), n - np - cpar * df_obs))
pvals.beta[i] <- 2 * (1 - pt(abs(tstat[i]), n - cpar * df_obs))
}
}
rslt$se.beta <- se.beta
rslt$pvals.beta <- pvals.beta
rslt$sse1 <- sse1
rslt$sse0 <- sse0
rslt$dev <- dev.fun(y, muhatkeep, etakeep, weights, fml = family$family)$dev
rslt$dev.null <- dev.fun(y, muhatkeep, etakeep, weights, fml = family$family)$dev.null
rslt$df <- n - np
rslt$df.null <- n - 1
#rslt$df.residual <- n - np - cpar * df_obs
rslt$df.residual <- n - cpar * df_obs
rslt$df_obs <- df_obs
rslt$vhat <- vhat
if (length(knotsuse) == 0) {
knotsuse <- NULL
}
#new: order back
knotsuse2 <- knotsuse
numknotsuse2 <- numknotsuse
mslst2 <- mslst
xmat2 <- xmat
#if (!is.null(idx_s)) {
if (length(idx_s) > 0) {
knotsuse0 <- knotsuse
numknotsuse0 <- numknotsuse
mslst0 <- mslst
knotsuse0[idx_s] <- knotsuse[1:length(idx_s)]
numknotsuse0[idx_s] <- numknotsuse[1:length(idx_s)]
mslst0[idx_s] <- mslst[1:length(idx_s)]
#if (!is.null(idx)) {
if (length(idx) > 0) {
knotsuse0[idx] <- knotsuse[(1+length(idx_s)):capl]
numknotsuse0[idx] <- numknotsuse[(1+length(idx_s)):capl]
mslst0[idx] <- mslst[(1+length(idx_s)):capl]
}
knotsuse <- knotsuse0
numknotsuse <- numknotsuse0
mslst <- mslst0
}
# the following has shape = 17 at the beginning: knots2 etc
rslt$knots2 <- knotsuse2
rslt$numknots2 <- numknotsuse2
rslt$ms2 <- mslst2
rslt$xmat2 <- xmat2
rslt$knots <- knotsuse
rslt$numknots <- numknotsuse
rslt$ms <- mslst
rslt$capms <- capms
rslt$cpar <- cpar
rslt$pvs <- pvs
rslt$s.edf <- s.edf
rslt$bstats <- bstats
#new:
rslt$pvsz <- pvsz
rslt$z.edf <- z.edf
rslt$fstats <- fstats
rslt$vh <- vh
rslt$kts.var <- kts.var
rslt$sc <- sc
#rslt$sdhat2 <- sdhat2
return (rslt)
}
}
###########
#CicFamily#
###########
CicFamily <- function(object,...)UseMethod("CicFamily")
CicFamily <- function(object) {
#temp:
#if (object$family == "ordered") {
# object$family = "gaussian"
#}
#new:
if (object$family == "gaussian") {
linkfun <- function (mu) mu
}
if (object$family == "poisson") {
linkfun <- function (mu) log(mu)
}
if (object$family == "binomial") {
linkfun <- binomial()$linkfun
}
if (object$family == "Gamma") {
#linkfun <- function (mu) log(mu)
linkfun <- Gamma(link="log")$linkfun
}
llh.fun <- function(y, muhat = NULL, etahat = NULL, phihat = NULL, n = NULL, weights = NULL, fml = object$family){
sm <- 1e-7
#sm <- 1e-5
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
w <- weights
#new: avoid Inf
if (fml == "poisson") {
llh <- 2 * sum(w[w!=0] * (muhat[w!=0] - y[w!=0] * etahat[w!=0])) / n
}
if (fml == "binomial") {
llh <- 0
if (all(0 <= y) & all(y <= 1)) {
for (i in 1:n) {
if (muhat[i] > 0 & muhat[i] < 1) {
llh <- llh + w[i] * (y[i] * log(muhat[i]) + (1 - y[i]) * log(1 - muhat[i]))
}
}
llh <- (-2/n) * llh
} else {
stop ("y values must be 0 <= y <= 1!")
}
}
if (fml == "gaussian") {
if (all(w == 1)) {
llh <- log(sum((y - etahat)^2))
} else {
llh <- log(sum(w[w!=0] * (y[w!=0] - etahat[w!=0])^2)) - sum(log(w[w!=0])) / n
}
}
if (fml == "Gamma") {
vuhat <- 1 / phihat
#print (vuhat)
#llh <- 2 * sum(w[w!=0] * (etahat[w!=0] + y[w!=0] * exp(-etahat[w!=0]))) / n
llh <- 2 / n * (vuhat * sum(w[w!=0] * (etahat[w!=0] + y[w!=0] * exp(-etahat[w!=0]))) + n * (log(gamma(vuhat)) - vuhat * log(vuhat)) - (vuhat-1) * sum(log(y)))
#print (llh)
}
llh
}
etahat.fun <- function(n, y, fml = object$family){
if (fml == "poisson") {
etahat <- 1:n*0 + log(mean(y))
}
if (fml == "binomial") {
etahat <- 1:n*0
}
if (fml == "Gamma") {
etahat <- 1:n*0 + log(mean(y))
}
etahat
}
gr.fun <- function(y, etahat = NULL, weights = NULL, fml = object$family){
n <- length(y)
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
w <- weights
if (fml == "poisson") {
gr <- w * (exp(etahat) - y)
}
if (fml == "binomial") {
if (all(etahat == 0)) {
gr <- w * (1/2 - y)
} else {
gr <- 1:n*0
for (i in 1:n) {
if (etahat[i] > 100) {
gr[i] <- w[i] * (1 - y[i])
} else {gr[i] <- w[i] * (exp(etahat[i]) / (1 + exp(etahat[i])) - y[i])}
}
}
}
if (fml == "Gamma") {
gr <- w * (1 - y * exp(-etahat))
}
gr
}
wt.fun <- function(y, etahat = NULL, n = NULL, weights = NULL, fml = object$family){
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
w <- weights
if (fml == "poisson") {
wt <- w * exp(etahat)
}
if (fml == "binomial") {
if (all(etahat == 0)){
#wt <- 1:n*0 + 1/4
wt <- w * (1:n*0 + 1/4)
} else {
wt <- 1:n*0
for (i in 1:n) {
if (etahat[i] > 100) {
wt[i] <- 0
} else {
wt[i] <- w[i] * exp(etahat[i]) / ((1 + exp(etahat[i]))^2)
}
}
}
}
if (fml == "gaussian") {
wt <- w # (1:n*0 + 1) / w
}
if (fml == "Gamma") {
wt <- w * y * exp(-etahat)
}
wt <- as.vector(wt)
wt
}
zvec.fun <- function(cvec = NULL, wt = NULL, y, sm = 1e-7, fml = object$family) {
n <- length(y)
if (fml == "gaussian") {
#zvec <- y
zvec <- wt^(1/2) * y
}
if (fml == "poisson") {
#zvec <- cvec / wt
zvec <- cvec / sqrt(wt)
}
if (fml == "binomial") {
zvec = 1:n*0
zvec[wt == 0] <- 1 / sm
zvec[wt > 0] <- cvec[wt > 0] / sqrt(wt[wt > 0])
}
if (fml == "Gamma") {
zvec <- cvec / sqrt(wt)
}
zvec
}
muhat.fun <- function(etahat, wt = NULL, fml = object$family){
n <- length(etahat)
if (fml == "poisson") {
muhat <- exp(etahat)
}
if (fml == "binomial") {
muhat <- 1:n*0
id1 = which(etahat > 100)
id2 = which(etahat <= 100)
muhat[id1] = 1
muhat[id2] = exp(etahat[id2]) / (1 + exp(etahat[id2]))
#muhat[wt == 0] <- 1
#for (i in 1:n) {
# if (etahat[i] > 100) {
# muhat[i] <- 1
# } else {
# muhat[i] <- exp(etahat[i]) / (1 + exp(etahat[i]))
# }
#}
}
if (fml == "gaussian") {
muhat <- etahat
}
if (fml == "Gamma") {
muhat <- exp(etahat)
}
muhat
}
# ysim.fun <- function(n, mu0 = NULL, fml = object$family, shp0 = NULL) {
# if (fml == "binomial") {
# ysim <- 1:n*0
# ysim[runif(n) < .5] <- 1
# }
# if (fml == "poisson") {
# if (!is.null(mu0)) {
# ysim <- rpois(n, mu0)
# }
# }
# if (fml == "gaussian") {
# ysim <- rnorm(n)
# }
# if (fml == "Gamma") {
# ysim <- rgamma(n, shape=1)
# }
# ysim
# }
ysim.fun <- function(n, mu0 = NULL, fml = object$family, shp0 = NULL, sd = NULL, phi = NULL) {
if (fml == "binomial") {
if(is.null(mu0)){
ysim <- 1:n*0
ysim[runif(n) < .5] <- 1
} else {
ysim <- rbinom(n, size = 1, prob = mu0)
}
}
if (fml == "poisson") {
if (!is.null(mu0)) {
ysim <- rpois(n, mu0)
}
}
if (fml == "gaussian") {
if(!is.null(phi)){
ysim <- mu0 + arima.sim(n = n, list(ar = phi), sd = sd)
}else{
if(is.null(mu0)){
ysim <- rnorm(n)
} else {
ysim <- mu0 + rnorm(n)
}
}
}
if (fml == "Gamma") {
ysim <- rgamma(n, shape=1)
}
ysim
}
deriv.fun <- function(muhat, fml = object$family) {
if (fml == "binomial") {
deriv <- 1 / (muhat * (1 - muhat))
}
if (fml == "poisson") {
deriv <- 1 / muhat
}
if (fml == "gaussian") {
deriv <- 1
}
if (fml == "Gamma") {
deriv <- 1 / muhat
}
deriv
}
dev.fun <- function(y, muhat, etahat, weights, fml = object$family){
n <- length(y)
sm <- 1e-7
#sm <- 1e-5
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
w <- weights
vmat <- matrix(1:n*0 + 1, ncol = 1)
if (fml == "poisson") {
#dev <- 2 * sum(w * (y * log(y / muhat) - y + muhat))
dev <- 0
for (i in 1:n) {
if (y[i] == 0) {
dev <- dev + 2 * w[i] * muhat[i]
} else {
dev <- dev + 2 * w[i] * (y[i] * log(y[i] / muhat[i]) - y[i] + muhat[i])
}
}
}
if (fml == "binomial") {
dev <- 0
for (i in 1:n) {
if (y[i] == 0 & w[i] != 0) {
dev <- dev + 2 * w[i] * log(w[i] / (w[i] - w[i] * muhat[i]))
} else if (y[i] == 1 & w[i] != 0) {
dev <- dev + 2 * w[i] * log(w[i] / (w[i] * muhat[i]))
} else if (0 < y[i] & y[i] < 1 & w[i] != 0) {
dev <- dev + 2 * w[i] * y[i] * log(w[i] * y[i] / (w[i] * muhat[i])) + 2 * (w[i] - w[i] * y[i]) * log((w[i] - w[i] * y[i]) / (w[i] - w[i] * muhat[i]))
} else {
stop ("y values must be 0 <= y <= 1!")
}
}
}
if (fml == "gaussian") {
dev <- sum(w * (y - muhat)^2)
}
if (fml == "Gamma") {
dev <- 0
for (i in 1:n) {
if (y[i] == 0) {
sm <- 1e-4
dev <- dev + 2 * w[i] * ((sm - muhat[i]) / muhat[i] - log(sm / muhat[i]))
} else {
dev <- dev + 2 * w[i] * ((y[i] - muhat[i]) / muhat[i] - log(y[i] / muhat[i]))
}
}
}
###################
#get null deviance#
###################
if (fml == "binomial" | fml == "poisson" | fml == "Gamma") {
diff <- 1
muhat0 <- mean(y) + 1:n*0
if (fml == "poisson") {
etahat0 <- log(muhat0)
}
if (fml == "binomial") {
etahat0 <- log(muhat0 / (1 - muhat0))
}
if (fml == "Gamma") {
etahat0 <- log(muhat0)
}
while (diff > sm) {
oldmu <- muhat0
zhat <- etahat0 + (y - muhat0) * deriv.fun(muhat0, fml = fml)
# wmat <- diag(as.vector(w / deriv.fun(muhat0, fml = fml)))
# b <- solve(t(vmat) %*% wmat %*% vmat) %*% t(vmat) %*% wmat %*% zhat
wm <- as.vector(w / deriv.fun(muhat0, fml = fml))
tvmat <- t(vmat)
for (i in 1:n) {tvmat[,i] <- tvmat[,i] * wm[i]}
b <- solve(tvmat %*% vmat) %*% tvmat %*% zhat
etahat0 <- vmat %*% b
muhat0 <- muhat.fun(etahat0, fml = fml)
diff <- mean((muhat0 - oldmu)^2)
}
if (fml == "poisson") {
#dev.null <- 2 * sum(w * (y * log(y / muhat0) - y + muhat0))
dev.null <- 0
for (i in 1:n) {
if (y[i] == 0) {
dev.null <- dev.null + 2 * w[i] * muhat0[i]
} else {
dev.null <- dev.null + 2 * w[i] * (y[i] * log(y[i] / muhat0[i]) - y[i] + muhat0[i])
}
}
}
if (fml == "binomial") {
dev.null <- 0
for (i in 1:n) {
if (y[i] == 0 & w[i] != 0) {
dev.null <- dev.null + 2 * w[i] * log(w[i] / (w[i] - w[i] * muhat0[i]))
} else if (y[i] == 1 & w[i] != 0) {
dev.null <- dev.null + 2 * w[i] * log(w[i] / (w[i] * muhat0[i]))
} else if (0 < y[i] & y[i] < 1 & w[i] != 0) {
dev.null <- dev.null + 2 * w[i] * y[i] * log(w[i] * y[i] / (w[i] * muhat0[i])) + 2 * (w[i] - w[i] * y[i]) * log((w[i] - w[i] * y[i]) / (w[i] - w[i] * muhat0[i]))
} else {
stop ("y values must be 0 <= y <= 1!")
}
}
}
if (fml == "Gamma") {
dev.null <- 0
for (i in 1:n) {
if (y[i] == 0) {
sm <- 1e-4
dev.null <- dev.null + 2 * w[i] * ((sm - muhat0[i]) / muhat0[i] - log(sm / muhat0[i]))
} else {
dev.null <- dev.null + 2 * w[i] * ((y[i] - muhat0[i]) / muhat0[i] - log(y[i] / muhat0[i]))
}
}
}
}
if (fml == "gaussian") {
# wmat <- diag(w)
# b <- solve(t(vmat) %*% wmat %*% vmat) %*% t(vmat) %*% wmat %*% y
tvmat <- t(vmat)
for (i in 1:n) {tvmat[,i] <- tvmat[,i] * w[i]}
b <- solve(tvmat %*% vmat) %*% tvmat %*% y
etahat0 <- vmat %*% b
muhat0 <- muhat.fun(etahat0, fml = fml)
dev.null <- sum(w * (y - muhat0)^2)
}
rslt <- new.env()
rslt$dev <- dev
rslt$dev.null <- dev.null
rslt
}
ans <- list(llh.fun = llh.fun, etahat.fun = etahat.fun, gr.fun = gr.fun, wt.fun = wt.fun, zvec.fun = zvec.fun, muhat.fun = muhat.fun, ysim.fun = ysim.fun, deriv.fun = deriv.fun, dev.fun = dev.fun, linkfun = linkfun)
class(ans) <- "CicFamily"
return (ans)
}
#######################
#eight shape functions#
#######################
#new: handle names like `Year of higest degree`
#test more!
get_varname <- function(expr) {
if (is.call(expr)) {
# Recursive extraction of the first symbol in a call
return(get_varname(expr[[2]]))
}
if (is.name(expr)) {
return(as.character(expr))
}
stop("Unsupported expression for variable name extraction.")
}
incr <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 1
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
decr <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 2
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
conv <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "nm") <- get_varname(pars$x)
attr(x, "shape") <- 3
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
conc <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "nm") <- get_varname(pars$x)
attr(x, "shape") <- 4
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
incr.conv <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "nm") <- get_varname(pars$x)
attr(x, "shape") <- 5
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
decr.conv <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "nm") <- get_varname(pars$x)
attr(x, "shape") <- 6
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
incr.conc <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "nm") <- get_varname(pars$x)
attr(x, "shape") <- 7
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
decr.conc <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "nm") <- get_varname(pars$x)
attr(x, "shape") <- 8
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
#s.incr <- function(x, numknots = 0, knots = 0, space = "E")
#{
# cl <- match.call()
# pars <- match.call()[-1]
# attr(x, "nm") <- deparse(pars$x)
# attr(x, "shape") <- 9
# attr(x, "numknots") <- numknots
# attr(x, "knots") <- knots
# attr(x, "space") <- space
# attr(x, "categ") <- "additive"
# #class(x) <- "additive"
# x
#}
#s.decr <- function(x, numknots = 0, knots = 0, space = "E")
#{
# cl <- match.call()
# pars <- match.call()[-1]
# attr(x, "nm") <- deparse(pars$x)
# attr(x, "shape") <- 10
# attr(x, "numknots") <- numknots
# attr(x, "knots") <- knots
# attr(x, "space") <- space
# attr(x, "categ") <- "additive"
# #class(x) <- "additive"
# x
#}
s.incr <- function(x, numknots = 0, knots = 0, var.knots = 0, space = "Q", db.exp = FALSE)
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 9
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
attr(x, "db.exp") <- db.exp
attr(x, "var.knots") <- var.knots
#class(x) <- "additive"
x
}
s.decr <- function(x, numknots = 0, knots = 0, var.knots = 0, space = "Q", db.exp = FALSE)
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 10
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
attr(x, "db.exp") <- db.exp
attr(x, "var.knots") <- var.knots
#class(x) <- "additive"
x
}
s.conv <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 11
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
s.conc <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 12
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
s.incr.conv <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 13
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
s.incr.conc <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 14
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
s.decr.conv <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 15
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
s.decr.conc <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 16
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
s <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 17
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
######################################################
#tree function: give the tree shape to x and return x#
######################################################
tree <- function(x, pl = NULL)
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- "tree"
#stop (print (x))
#print (class(x))
if (is.null(pl)) {
if (is.numeric(x)) {
if (0%in%x) {
pl <- 0
} else {pl <- min(x)}
} else {
xu <- unique(x)
pl <- xu[1]
}
} else {
if (!(pl%in%x)) {
stop ("placebo level is not a level of the tree variable!")
}
}
attr(x, "pl") <- pl
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
##################################################
#tree.fun: make delta to a tree ordering variable#
##################################################
#tree.fun <- function(x)
#{
# if (min(x) != 0) {
# stop ("A tree ordering variable must have its placebo equal to 0!")
# }
# if (!all(round(x, 0) == x)) {
# stop ("All elements of a tree ordering variable must be integers!")
# }
# if (any(x < 0))
# stop ("All elements of a tree ordering variable must be positive!")
# nx <- x
# obs <- 1:length(x)
# delta <- matrix(0, nrow = length(attributes(factor(x))$levels) - 1, ncol = length(x))
# pl <- min(nx)
# for (i in 1:nrow(delta)) {
# nx <- nx[which(nx != pl)]
# pl <- min(nx)
# index <- obs[x == pl]
# delta[i, index] <- 1
# }
# attr(delta, "shape") <- "tree"
# delta
#}
tree.fun <- function(x, pl = NULL)
{
#if (pl %in% x) {
if (is.null(pl)) {
if (is.numeric(x)) {
if (0%in%x) {
pl <- 0
} else {pl <- min(x)}
} else {
xu <- unique(x)
pl <- xu[1]
}
} else {
if (!(pl%in%x)) {
stop ("placebo level is not a level of the tree variable!")
}
}
pos <- x %in% pl
xu <- unique(x)
nx <- xu[xu != pl]
delta <- matrix(0, nrow = (length(xu) - 1), ncol = length(x))
for (i in 1:nrow(delta)) {
xi = nx[i]
delta[i, !pos & x %in% xi] <- 1
pos <- pos | x %in% xi
}
#} else {stop ("placebo level is not a level of the tree variable!")}
attr(delta, "shape") <- "tree"
delta
}
##############################################################
#umbrella function: give the umbrella shape to x and return x#
##############################################################
umbrella <- function(x)
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- "umbrella"
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
###########################################################
#umbrella.fun: make delta to an umbrella ordering variable#
###########################################################
umbrella.fun <- function(x)
{
amat <- amat.fun(x)
bmat <- bmat.fun(x)
constr <- t(rbind(amat, bmat))
vmat <- qr.Q(qr(constr), complete = TRUE)[, -(1:(qr(constr)$rank)), drop = FALSE]
if (!is.null(bmat)) {
wperp <- t(rbind(t(vmat), bmat))
wmat <- qr.Q(qr(wperp), complete = TRUE)[, -(1:(qr(wperp)$rank)), drop = FALSE]
atil <- amat %*% wmat
delta <- t(wmat %*% t(atil) %*% solve(atil %*% t(atil)))
} else {
delta <- t(t(amat) %*% solve(amat %*% t(amat)))
}
attr(delta, "shape") <- "umbrella"
delta
}
###################################################
#find delta for a specific predictor x and a shape#
#use splines2 pkg
###################################################
# makedelta = function(x, sh, numknots = 0, knots = 0, space = "E", suppre = FALSE, interp = FALSE, shpselect = FALSE) {
# #if (!interp) {
# #x = (x - min(x)) / (max(x) - min(x))
# #}
# n = length(x)
# # find unique x values
# #round(x,8) will make 0 edge in amat!
# #xu = sort(unique(round(x, 8)))
# #new: center and scale to avoid numerical instability
# if(sh < 9){
# xu = sort(unique(x))
# } else {
# xu = unique(x)
# }
#
# n1 = length(xu)
# sm = 1e-7
# ms = NULL
# # increasing or decreasing
# if (sh < 3) {
# amat = matrix(0, nrow = n1 - 1, ncol = n)
# for (i in 1: (n1 - 1)) {
# amat[i, x > xu[i]] = 1
# }
# if (sh == 2) {amat = -amat}
# if (!interp) {
# # for (i in 1:(n1 - 1)) {
# # #new: use ms in predict.cgam
# # ms = c(ms, mean(amat[i, ]))
# # amat[i, ] = amat[i, ] - mean(amat[i, ])
# # }
# ms = apply(amat, 1, mean)
# amat = apply(amat, 1, function(e) scale(e, scale = FALSE))
# }
# } else if (sh == 3 | sh == 4) {
# # convex or concave
# amat = matrix(0, nrow = n1 - 2 ,ncol = n)
# #for (i in 1: (n1 - 2)) {
# # amat[i, x > xu[i]] = x[x > xu[i]] - xu[i]
# #}
# for (i in 1: (n1 - 2)) {
# amat[i, x > xu[i+1]] = x[x > xu[i+1]] - xu[i+1]
# }
# if (sh == 4) {amat = -amat}
# xm = cbind(1:n*0+1,x)
# xpx = solve(t(xm) %*% xm)
# pm = xm %*% xpx %*% t(xm)
# #new: use ms in predict.cgam
# if (!interp) {
# ms = amat %*% t(pm)
# #amat = amat - amat %*% t(pm)
# amat = amat - ms
# }
# } else if (sh > 4 & sh < 9) {
# amat = matrix(0, nrow = n1 - 1, ncol = n)
# if (sh == 5) { ### increasing convex
# for (i in 1:(n1 - 1)) {
# amat[i, x > xu[i]] = (x[x > xu[i]] - xu[i]) / (max(x) - xu[i])
# }
# if (!interp) {
# #for (i in 1:(n1 - 1)) {
# # ms = c(ms, mean(amat[i, ]))
# # amat[i,] = amat[i,] - mean(amat[i,])
# #}
# ms = apply(amat, 1, mean)
# amat = apply(amat, 1, function(e) scale(e, scale = FALSE))
# }
# } else if (sh == 6) { ## decreasing convex
# for (i in 1:(n1 - 1)) {
# amat[i, x < xu[i + 1]] = (x[x < xu[i + 1]] - xu[i + 1]) / (min(x) - xu[i + 1])
# }
# if (!interp) {
# #for (i in 1:(n1 - 1)) {
# # ms = c(ms, mean(amat[i, ]))
# # amat[i,] = amat[i,] - mean(amat[i, ])
# #}
# ms = apply(amat, 1, mean)
# amat = apply(amat, 1, function(e) scale(e, scale = FALSE))
# }
# #print (ms)
# } else if (sh == 7) { ## increasing concave
# for (i in 1:(n1 - 1)) {
# amat[i, x < xu[i + 1]] = (x[x < xu[i + 1]] - xu[i + 1]) / (min(x) - xu[i + 1])
# }
# if (!interp) {
# #for (i in 1:(n1 - 1)) {
# # ms = c(ms, mean(amat[i, ]))
# # amat[i,] = -amat[i,] + mean(amat[i,])
# #}
# ms = apply(amat, 1, mean)
# amat = apply(amat, 1, function(e) scale(e, scale = FALSE))
# amat = -amat
# }
# } else if (sh == 8) {## decreasing concave
# for (i in 1:(n1 - 1)) {
# amat[i, x > xu[i]] = (x[x > xu[i]] - xu[i]) / (max(x) - xu[i])
# }
# if (!interp) {
# #for (i in 1:(n1 - 1)) {
# # ms = c(ms, mean(amat[i, ]))
# # amat[i,] = -amat[i,] + mean(amat[i,])
# #}
# ms = apply(amat, 1, mean)
# amat = apply(amat, 1, function(e) scale(e, scale = FALSE))
# amat = -amat
# }
# }
# } else if (sh > 8 & sh < 18) {
# #new: add two knots
# #if (all(knots == 0) & numknots == 0) {
# if (length(knots) < 2 & numknots == 0) {
# if (sh == 9 | sh == 10) {#1 2
# #k = trunc(n1^(1/5)) + 4
# if (n1 <= 50) {
# k = 5
# } else if (n1>50 && n1<100) {
# k = 6
# } else if (n1>= 100 && n1<200) {
# k = 7
# } else {
# k = trunc(n1^(1/5)) + 6
# }
# } else {
# #k = trunc(n1^(1/7) + 4)
# if (n1 <= 50) {
# k = 5
# } else if (n1>50 && n1<100) {
# k = 6
# } else if (n1>= 100 && n1<200) {
# k = 7
# } else {
# k = trunc(n1^(1/7)) + 6
# }
# }
# if (space == "Q") {
# t = quantile(xu, probs = seq(0, 1, length = k), names = FALSE)
# }
# if (space == "E") {
# #t = 0:k / k * (max(x) - min(x)) + min(x)
# #t = 0:(k-1) / (k-1) * (max(x) - min(x)) + min(x)
# t = seq.int(min(x), max(x), length.out = k)
# }
# #} else if (any(knots != 0) & numknots == 0) {
# } else if (length(knots) >= 2 & numknots == 0) {
# t = knots
# #} else if (all(knots == 0) & numknots != 0) {
# } else if (length(knots) < 2 & numknots != 0) {
# if (space == "Q") {
# t = quantile(xu, probs = seq(0, 1, length = numknots), names = FALSE)
# }
# if (space == "E") {
# #k = numknots
# #new: numknots should be the # of all knots
# k = numknots - 1
# #if (sh == 9 | sh == 10) {#1 2
# # k = trunc(n1^(1/5)) + 4
# #} else {k = trunc(n1^(1/7) + 4)}
# #t = 0:k/k * (max(x) - min(x)) + min(x)
# t = seq.int(min(x), max(x), length.out = numknots)
# }
# #} else if (any(knots != 0) & numknots != 0) {
# } else if (length(knots) >= 2 & numknots != 0) {
# #t0 = quantile(xu, probs = seq(0, 1, length = numknots), names = FALSE)
# t = knots
# if (!suppre) {
# print("'knots' is used! 'numknots' is not used!")
# }
# #print ("'knots' is used!")
# #if (numknots != length(knots)) {
# # if (!suppre) {
# # print("length(knots) is not equal to 'numknots'! 'knots' is used!")
# # }
# #} else if (any(t0 != knots)) {
# # if (!suppre) {
# # print("equal x-quantiles knots != 'knots'! 'knots' is used! ")
# # }
# #}
# }
# if (sh == 9) {#1
# #amat_ans = monincr(x, t, interp)
# #amat = amat_ans$sigma |> t()
# #ms = amat_ans$ms
# #cat('use monincr!', '\n')
# #new: use splines2 pkg to make it faster
#
# nt = length(t)
# amat = iSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# # #cat('use splines2!', '\n')
# ms = colMeans(amat)
# #
# #make the basis orthogonal to 1
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 10) {#2
# #amat_ans = mondecr(x, t, interp)
# #amat = amat_ans$sigma |> t()
# #ms = amat_ans$ms
#
# nt = length(t)
# amat = -iSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# #cat('use splines2!', '\n')
# ms = colMeans(amat)
#
# #make the basis orthogonal to 1
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 11) {#3
# #amat_ans = convex(x, t, interp)
# #amat = amat_ans$sigma
# #amat = t(amat)
# #ms = amat_ans$ms
#
# nt = length(t)
# amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# #cat('use splines2!', '\n')
# ms = colMeans(amat)
#
# if(!interp){
# xm = cbind(1, x)
# pm = xm %*% solve(crossprod(xm), t(xm))
# amat = amat - pm %*% amat
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 12) {#4
# # amat_ans = concave(x, t, interp)
# # amat = amat_ans$sigma
# # amat = t(amat)
# # ms = amat_ans$ms
#
# nt = length(t)
# amat = -cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# #cat('use splines2!', '\n')
# #ms = colMeans(amat)
#
# if(!interp){
# xm = cbind(1, x)
# pm = xm %*% solve(crossprod(xm), t(xm))
# amat = amat - pm %*% amat
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 13) {#5
# #amat_ans = incconvex(x, t, interp)
# #amat = amat_ans$sigma
# #amat = t(amat)
# #ms = amat_ans$ms
#
# nt = length(t)
# amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# x_sc = (x - min(x)) / (max(x) - min(x))
# amat = cbind(amat, x_sc)
# #cat('use splines2!', '\n')
# ms = colMeans(amat)
#
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 14) {#6
# #amat_ans = incconcave(x, t, interp)
# #amat = amat_ans$sigma
# #ms = amat_ans$ms
# #amat = t(amat)
#
# nt = length(t)
# amat = -cSpline(-x, knots = -rev(t[-c(1, nt)]), Boundary.knots = -c(t[nt], t[1]), degree = 1)
# x_sc = (-x - min(-x)) / (max(-x) - min(-x))
# amat = cbind(-x_sc, amat)
# #cat('use splines2!', '\n')
# ms = colMeans(amat)
#
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 15) {#7
# #amat_ans = -incconcave(x, t, interp)
# # amat_ans = incconcave(x, t, interp)
# # amat = -amat_ans$sigma
# # if (!interp) {
# # ms = -amat_ans$ms
# # }
# # amat = t(amat)
#
# nt = length(t)
# amat = cSpline(-x, knots = -rev(t[-c(1, nt)]), Boundary.knots = -c(t[nt], t[1]), degree = 1)
# x_sc = (-x - min(-x)) / (max(-x) - min(-x))
# amat = cbind(x_sc, amat)
# #cat('use splines2!', '\n')
# ms = colMeans(amat)
#
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# # nt = length(t)
# # amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# # amat = cbind(amat, x)
# # cat('use splines2!', '\n')
# # ms = colMeans(amat)
# # nt = length(t)
# # amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# # amat = cbind(amat, -x)
# # cat('use splines2!', '\n')
# # ms = colMeans(amat)
#
# } else if (sh == 16) {#8
# #amat_ans = -incconvex(x, t, interp)
# # amat_ans = incconvex(x, t, interp)
# # amat = -amat_ans$sigma |> t()
# # if (!interp) {
# # ms = -amat_ans$ms
# # }
#
# nt = length(t)
# amat = -cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# x_sc = (x - min(x)) / (max(x) - min(x))
# amat = cbind(amat, -x_sc)
# #cat('use splines2!', '\n')
# if (!interp) {
# ms = colMeans(amat)
# }
#
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 17) {#unconstrained
# #amat_ans = incconvex(x, t, interp)
# #amat = amat_ans$sigma |> t()
# #ms = amat_ans$ms
#
# nt = length(t)
# amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# x_sc = (x - min(x)) / (max(x) - min(x))
# amat = cbind(amat, x_sc)
# #cat('use splines2!', '\n')
# ms = colMeans(amat)
#
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# #amat = -incconcave(x, t)
# #amat = rbind(x, t(bcspl(x, m = length(t), knots = t)$bmat))
# #amat = rbind(x, convex(x, t))
# }
# }
# #if (sh < 9) {
# # rslt = list(amat = amat, knots = 0, ms = ms)
# #} else {
# # rslt = list(amat = amat, knots = t, ms = ms)
# #}
# if (sh < 9) {t = 0}
# rslt = list(amat = amat, knots = t, ms = ms)
# rslt
# }
###################################################
#find delta for a specific predictor x and a shape#
###################################################
makedelta = function(x, sh, numknots = 0, knots = 0, space = "E", suppre = FALSE, interp = FALSE) {
#if (!interp) {
#x = (x - min(x)) / (max(x) - min(x))
#}
n = length(x)
# find unique x values
#round(x,8) will make 0 edge in amat!
#xu = sort(unique(round(x, 8)))
#new: center and scale to avoid numerical instabillity
xu = sort(unique(x))
n1 = length(xu)
sm = 1e-7
ms = NULL
# increasing or decreasing
if (sh < 3) {
amat = matrix(0, nrow = n1 - 1, ncol = n)
for (i in 1: (n1 - 1)) {
amat[i, x > xu[i]] = 1
}
if (sh == 2) {amat = -amat}
if (!interp) {
for (i in 1:(n1 - 1)) {
#new: use ms in predict.cgam
ms = c(ms, mean(amat[i, ]))
amat[i, ] = amat[i, ] - mean(amat[i, ])
}
}
} else if (sh == 3 | sh == 4) {
# convex or concave
amat = matrix(0, nrow = n1 - 2 ,ncol = n)
#for (i in 1: (n1 - 2)) {
# amat[i, x > xu[i]] = x[x > xu[i]] - xu[i]
#}
for (i in 1: (n1 - 2)) {
amat[i, x > xu[i+1]] = x[x > xu[i+1]] - xu[i+1]
}
if (sh == 4) {amat = -amat}
xm = cbind(1:n*0+1,x)
xpx = solve(t(xm) %*% xm)
pm = xm %*% xpx %*% t(xm)
#new: use ms in predict.cgam
if (!interp) {
ms = amat %*% t(pm)
#amat = amat - amat %*% t(pm)
amat = amat - ms
}
} else if (sh > 4 & sh < 9) {
amat = matrix(0, nrow = n1 - 1, ncol = n)
if (sh == 5) { ### increasing convex
for (i in 1:(n1 - 1)) {
amat[i, x > xu[i]] = (x[x > xu[i]] - xu[i]) / (max(x) - xu[i])
}
if (!interp) {
for (i in 1:(n1 - 1)) {
ms = c(ms, mean(amat[i, ]))
amat[i,] = amat[i,] - mean(amat[i,])
}
}
} else if (sh == 6) { ## decreasing convex
for (i in 1:(n1 - 1)) {
amat[i, x < xu[i + 1]] = (x[x < xu[i + 1]] - xu[i + 1]) / (min(x) - xu[i + 1])
}
if (!interp) {
for (i in 1:(n1 - 1)) {
ms = c(ms, mean(amat[i, ]))
amat[i,] = amat[i,] - mean(amat[i, ])
}
}
#print (ms)
} else if (sh == 7) { ## increasing concave
for (i in 1:(n1 - 1)) {
amat[i, x < xu[i + 1]] = (x[x < xu[i + 1]] - xu[i + 1]) / (min(x) - xu[i + 1])
}
if (!interp) {
for (i in 1:(n1 - 1)) {
ms = c(ms, mean(amat[i, ]))
amat[i,] = -amat[i,] + mean(amat[i,])
}
}
} else if (sh == 8) {## decreasing concave
for (i in 1:(n1 - 1)) {
amat[i, x > xu[i]] = (x[x > xu[i]] - xu[i]) / (max(x) - xu[i])
}
if (!interp) {
for (i in 1:(n1 - 1)) {
ms = c(ms, mean(amat[i, ]))
amat[i,] = -amat[i,] + mean(amat[i,])
}
}
}
} else if (sh > 8 & sh < 18) {
#new: add two knots
#if (all(knots == 0) & numknots == 0) {
if (length(knots) < 2 & numknots == 0) {
if (sh == 9 | sh == 10) {#1 2
#k = trunc(n1^(1/5)) + 4
if (n1 <= 50) {
k = 5
} else if (n1>50 && n1<100) {
k = 6
} else if (n1>= 100 && n1<200) {
k = 7
} else {
k = trunc(n1^(1/5)) + 6
}
} else {
#k = trunc(n1^(1/7) + 4)
if (n1 <= 50) {
k = 5
} else if (n1>50 && n1<100) {
k = 6
} else if (n1>= 100 && n1<200) {
k = 7
} else {
k = trunc(n1^(1/7)) + 6
}
}
if (space == "Q") {
t = quantile(xu, probs = seq(0, 1, length = k), names = FALSE)
}
if (space == "E") {
#t = 0:k / k * (max(x) - min(x)) + min(x)
t = 0:(k-1) / (k-1) * (max(x) - min(x)) + min(x)
}
#} else if (any(knots != 0) & numknots == 0) {
} else if (length(knots) >= 2 & numknots == 0) {
t = knots
#} else if (all(knots == 0) & numknots != 0) {
} else if (length(knots) < 2 & numknots != 0) {
if (space == "Q") {
t = quantile(xu, probs = seq(0, 1, length = numknots), names = FALSE)
}
if (space == "E") {
#k = numknots
#new: numknots should be the # of all knots
k = numknots - 1
#if (sh == 9 | sh == 10) {#1 2
# k = trunc(n1^(1/5)) + 4
#} else {k = trunc(n1^(1/7) + 4)}
t = 0:k / k * (max(x) - min(x)) + min(x)
}
#} else if (any(knots != 0) & numknots != 0) {
} else if (length(knots) >= 2 & numknots != 0) {
#t0 = quantile(xu, probs = seq(0, 1, length = numknots), names = FALSE)
t = knots
if (!suppre) {
print("'knots' is used! 'numknots' is not used!")
}
#print ("'knots' is used!")
#if (numknots != length(knots)) {
# if (!suppre) {
# print("length(knots) is not equal to 'numknots'! 'knots' is used!")
# }
#} else if (any(t0 != knots)) {
# if (!suppre) {
# print("equal x-quantiles knots != 'knots'! 'knots' is used! ")
# }
#}
}
if (sh == 9) {#1
#amat_ans = monincr(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = iSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# #cat('use splines2!', '\n')
ms = colMeans(amat)
#make the basis orthogonal to 1
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 10) {#2
#amat_ans = mondecr(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = -iSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
#cat('use splines2!', '\n')
ms = colMeans(amat)
#make the basis orthogonal to 1
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 11) {#3
#amat_ans = convex(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
#cat('use splines2!', '\n')
ms = colMeans(amat)
if(!interp){
xm = cbind(1, x)
pm = xm %*% solve(crossprod(xm), t(xm))
amat = amat - pm %*% amat
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 12) {#4
#amat_ans = concave(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = -cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
#cat('use splines2!', '\n')
ms = colMeans(amat)
if(!interp){
xm = cbind(1, x)
pm = xm %*% solve(crossprod(xm), t(xm))
amat = amat - pm %*% amat
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 13) {#5
#amat_ans = incconvex(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
#will give NaN when predicting for a single data point!
#x_sc = (x - min(x)) / (max(x) - min(x))
x_sc = x
amat = cbind(amat, x_sc)
#cat('use splines2!', '\n')
ms = colMeans(amat)
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 14) {#6
#amat_ans = incconcave(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = -cSpline(-x, knots = -rev(t[-c(1, nt)]), Boundary.knots = -c(t[nt], t[1]), degree = 1)
#wrong!
#x_sc = (-x - min(-x)) / (max(-x) - min(-x))
x_sc = -x
amat = cbind(-x_sc, amat)
#cat('use splines2!', '\n')
ms = colMeans(amat)
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 15) {#7
##amat_ans = -incconcave(x, t, interp)
#amat_ans = incconcave(x, t, interp)
#amat = -amat_ans$sigma
#if (!interp) {
# ms = -amat_ans$ms
#}
nt = length(t)
amat = cSpline(-x, knots = -rev(t[-c(1, nt)]), Boundary.knots = -c(t[nt], t[1]), degree = 1)
#wrong!
#x_sc = (-x - min(-x)) / (max(-x) - min(-x))
x_sc = -x
amat = cbind(x_sc, amat)
#cat('use splines2!', '\n')
ms = colMeans(amat)
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 16) {#8
##amat_ans = -incconvex(x, t, interp)
#amat_ans = incconvex(x, t, interp)
#amat = -amat_ans$sigma
#if (!interp) {
# ms = -amat_ans$ms
#}
nt = length(t)
amat = -cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
#wrong!
#x_sc = (x - min(x)) / (max(x) - min(x))
x_sc = x
amat = cbind(amat, -x_sc)
#cat('use splines2!', '\n')
#if (!interp) {
ms = colMeans(amat)
#}
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 17) {#unconstrained
#amat_ans = incconvex(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
#wrong!
#x_sc = (x - min(x)) / (max(x) - min(x))
x_sc = x
amat = cbind(amat, x_sc)
#cat('use splines2!', '\n')
ms = colMeans(amat)
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
}
}
#if (sh < 9) {
# rslt = list(amat = amat, knots = 0, ms = ms)
#} else {
# rslt = list(amat = amat, knots = t, ms = ms)
#}
if (sh < 9) {t = 0}
rslt = list(amat = amat, knots = t, ms = ms)
rslt
}
#####
#make basis for additive components
make_delta_add = function(xmat, shapes, numknots, knots, space) {
capl = ncol(xmat)
if (capl < 1) {capl = 0}
if (round(capl, 8) != round(capl, 1)) {stop ("Incompatible dimensions for xmat!")}
capls = sum(shapes == 17)
delta = NULL
varlist = NULL
knotsuse = list(); numknotsuse = NULL
mslst = list()
capm = 0
capms = 0
del1_ans = makedelta(xmat[, 1], shapes[1], numknots[1], knots[[1]], space = space[1], interp = FALSE)
del1 = del1_ans$amat
knotsuse[[1]] = del1_ans$knots
mslst[[1]] = del1_ans$ms
numknotsuse = c(numknotsuse, length(del1_ans$knots))
m1 = nrow(del1)
#new code: record the number of columns of del1 if shapes0[1] == 17:
if (shapes[1] == 17) {capms = capms + m1}
var1 = 1:m1*0 + 1
if (capl == 1) {
delta = del1
varlist = var1
} else {
for (i in 2:capl) {
del2_ans = makedelta(xmat[,i], shapes[i], numknots[i], knots[[i]], space = space[i], interp = FALSE)
del2 = del2_ans$amat
knotsuse[[i]] = del2_ans$knots
mslst[[i]] = del2_ans$ms
numknotsuse = c(numknotsuse, length(del2_ans$knots))
m2 = nrow(del2)
#new code: record the number of columns of del2 if shapes0[i] == 17:
if (shapes[i] == 17) {capms = capms + m2}
delta = rbind(del1, del2)
varlist = 1:(m1 + m2)*0
varlist[1:m1] = var1
varlist[(m1 + 1):(m1 + m2)] = (1:m2)*0 + i
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0) {
bigmat = rbind(t(xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13]), delta)
np = sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0) {
bigmat = delta
np = capms
}
rslt = list(bigmat=bigmat, np=np, varlist=varlist, knotsuse=knotsuse, mslst=mslst)
return(rslt)
}
# Monotone increasing
monincr = function(xs, t, interp = FALSE) {
n = length(xs)
#xs = (xs - min(xs)) / (max(xs) - min(xs))
x = sort(xs)
k = length(t) - 2
m = k + 2
sigma = matrix(0, nrow = m, ncol = n)
obs = 1:n
knt = 1:m
for (i in 1:(k+2)) {knt[i] = min(obs[abs(x - t[i]) == min(abs(x - t[i]))])}
for (j in 1:(k-1)) {
index = x >= t[1] & x <= t[j]
sigma[j, index] = 0
index = x > t[j] & x <= t[j+1]
sigma[j, index] = (x[index] - t[j])^2 / (t[j+2] - t[j]) / (t[j+1] - t[j])
index = x > t[j+1] & x <= t[j+2]
sigma[j, index] = 1 - (x[index] - t[j+2])^2 / (t[j+2] - t[j+1]) / (t[j+2] - t[j])
index = x > t[j+2] #& x <= t[m]
sigma[j, index] = 1
}
index = x >= t[1] & x <= t[k]
sigma[k, index] = 0
index = x > t[k] & x <= t[k+1]
sigma[k, index] = (x[index] - t[k])^2 / (t[k+2] - t[k]) / (t[k+1] - t[k])
index = x > t[k+1] & x <= t[k+2]
sigma[k, index] = 1 - (x[index] - t[k+2])^2 / (t[k+2] - t[k+1]) / (t[k+2] - t[k])
index = x >= t[1] & x <= t[2]
sigma[k+1, index] = 1 - (t[2] - x[index])^2 / (t[2] - t[1])^2
index = x > t[2]
sigma[k+1, index] = 1
index = x >= t[1] & x <= t[k+1]
sigma[k+2, index] = 0
index = x > t[k+1] & x <= t[k+2]
sigma[k+2, index] = (x[index] - t[k+1])^2 / (t[k+2] - t[k+1])^2
#new:
ms = NULL
if (!interp) {
ms = apply(sigma, 1, mean)
for (i in 1:m) {
sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
} else {
for (i in 1:m) {
#sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
}
rslt = list(sigma = sigma, ms = ms)
rslt
}
########################################################
# Monotone decreasing
mondecr = function(xs, t, interp = FALSE) {
#xs = (xs - min(xs)) / (max(xs) - min(xs))
x = sort(xs)
n = length(x)
k = length(t) - 2
m = k + 2
sigma = matrix(0, nrow = m, ncol = n)
obs = 1:n
#knt = 1:m
#for (i in 1:(k + 2)) {knt[i] = min(obs[abs(x - t[i]) == min(abs(x - t[i]))])}
#t = x[knt]
for (j in 1:(k - 1)) {
index = x >= t[1] & x <= t[j]
sigma[j, index] = 1
index = x > t[j] & x <= t[j+1]
sigma[j, index] = 1 - (x[index] - t[j])^2 / (t[j+2] - t[j]) / (t[j+1] - t[j])
index = x > t[j+1] & x <= t[j+2]
sigma[j, index] = (x[index] - t[j+2])^2 / (t[j+2] - t[j+1]) / (t[j+2] - t[j])
index = x > t[j+2]
sigma[j, index] = 0
}
index = x >= t[1] & x <= t[k]
sigma[k, index] = 1
index = x > t[k] & x <= t[k+1]
sigma[k, index] = 1 - (x[index] - t[k])^2 / (t[k+2] - t[k]) / (t[k+1] - t[k])
index = x > t[k+1] & x <= t[k+2]
sigma[k, index] = (x[index] - t[k+2])^2 / (t[k+2] - t[k+1]) / (t[k+2] - t[k])
index = x >= t[1] & x <= t[2]
sigma[k+1, index] = (t[2] - x[index])^2 / (t[2] - t[1])^2
index = x > t[2]
sigma[k+1, index] = 0
index = x >= t[1] & x <= t[k+1]
sigma[k+2, index] = 1
index = x > t[k+1] & x <= t[k+2]
sigma[k+2, index] = 1 - (x[index] - t[k+1])^2 / (t[k+2] - t[k+1])^2
ms = NULL
if (!interp) {
ms = apply(sigma, 1, mean)
for (i in 1:m) {
sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
} else {
for (i in 1:m) {
#sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
}
rslt = list(sigma = sigma, ms = ms)
rslt
}
########################################################
# Convex
convex = function(xs, t, interp = FALSE) {
#xs = (xs - min(xs)) / (max(xs) - min(xs))
x = sort(xs)
n = length(x)
k = length(t) - 2
m = k + 2
sigma = matrix(0, nrow = m, ncol = n)
obs = 1:n
#knt = 1:m
#for (i in 1:(k+2)) {knt[i] = min(obs[abs(x - t[i]) == min(abs(x - t[i]))])}
for (j in 1:(k-1)) {
index = x >= t[1] & x <= t[j]
sigma[j, index] = 0
index = x > t[j] & x <= t[j+1]
sigma[j, index] = (x[index] - t[j])^3 / (t[j+2] - t[j]) / (t[j+1] - t[j]) / 3
index = x > t[j+1] & x <= t[j+2]
sigma[j, index] = x[index] - t[j+1] - (x[index] - t[j+2])^3 / (t[j+2] - t[j]) / (t[j+2] - t[j+1]) / 3 + (t[j+1] - t[j])^2 / 3 /(t[j+2] - t[j]) - (t[j+2] - t[j+1])^2 / 3 / (t[j+2] - t[j])
index = x > t[j+2]
sigma[j, index] = (x[index] - t[j+1]) + (t[j+1] - t[j])^2 / 3 / (t[j+2] - t[j]) - (t[j+2] - t[j+1])^2 / 3 / (t[j+2] - t[j])
}
index = x >= t[1] & x <= t[k]
sigma[k, index] = 0
index = x > t[k] & x <= t[k+1]
sigma[k, index] = (x[index] - t[k])^3 / (t[k+2] - t[k]) / (t[k+1] - t[k]) / 3
index = x > t[k+1] & x <= t[k+2]
sigma[k, index] = x[index] - t[k+1] - (x[index] - t[k+2])^3 / (t[k+2] - t[k]) / (t[k+2] - t[k+1]) / 3 + (t[k+1] - t[k])^2 / 3 / (t[k+2] -t[k]) - (t[k+2] - t[k+1])^2 / 3 / (t[k+2] - t[k])
index = x >= t[1] & x <= t[2]
sigma[k+1, index] = x[index] - t[1] + (t[2] - x[index])^3 / (t[2] - t[1])^2 / 3 - (t[2] - t[1]) / 3 #-(t[2]-t[1])^3/(t[2]-t[1])^2/3 #
index = x > t[2]
sigma[k+1, index] = x[index] - t[1] - (t[2] - t[1]) / 3 #-(t[2]-t[1])^3/(t[2]-t[1])^2/3#
index = x >= t[1] & x <= t[k+1]
sigma[k+2, index] = 0
index = x > t[k+1] & x <= t[k+2]
sigma[k+2, index] = (x[index] - t[k+1])^3 / (t[k+2] - t[k+1])^2 / 3
ms = NULL
if (!interp) {
xm = cbind(1:n*0+1, x)
pm = xm %*% solve(t(xm) %*% xm) %*% t(xm)
ms = matrix(0, nrow = nrow(sigma), ncol = ncol(sigma))
for (i in 1:m) {
ms[i,] = pm %*% sigma[i,]
ms[i,] = ms[i, rank(xs)]
#rng=max(sigma[i,])
#sigma[i,]=sigma[i,]/rng
sigma[i,] = sigma[i,] - pm %*% sigma[i,]
sigma[i,] = sigma[i, rank(xs)]
}
} else {
for (i in 1:m) {
#sigma[i,] = sigma[i,] - pm %*% sigma[i,]
sigma[i,] = sigma[i, rank(xs)]
}
}
rslt = list(sigma = sigma, ms = ms)
rslt
}
########################################################
# Concave
concave = function(xs, t, interp = FALSE) {
#xs = (xs - min(xs)) / (max(xs) - min(xs))
x = sort(xs)
n = length(x)
k = length(t) - 2
m = k + 2
sigma = matrix(0, nrow = m, ncol = n)
obs = 1:n
#knt = 1:m
#for (i in 1:(k+2)) {knt[i] = min(obs[abs(x - t[i]) == min(abs(x - t[i]))])}
#t = x[knt]
for (j in 1:k) {
index = x >= t[1] & x <= t[j]
sigma[j, index] = x[index] - t[1]
index = x > t[j] & x <= t[j+1]
sigma[j, index] = t[j] - t[1] + ((t[j+1] - t[j])^3 - (t[j+1] - x[index])^3) / 3 / (t[j+1] - t[j]) / (t[j+2] - t[j]) + (x[index] - t[j]) * (t[j+2] - t[j+1]) / (t[j+2] - t[j])
index = x > t[j+1] & x <= t[j+2]
sigma[j, index] = t[j] - t[1] + (t[j+1] - t[j])^2 / 3 / (t[j+2] - t[j]) + (t[j+2] - t[j+1]) * (t[j+1] - t[j]) / (t[j+2] - t[j]) + ((t[j+2] - t[j+1])^3 - (t[j+2] - x[index])^3) / 3 / (t[j+2] - t[j+1]) / (t[j+2] - t[j])
index = x > t[j+2]
sigma[j, index] = t[j] - t[1] + (t[j+1] - t[j])^2 / 3 / (t[j+2] - t[j]) + (t[j+2] - t[j+1]) * (t[j+1] - t[j]) / (t[j+2] - t[j]) + (t[j+2] - t[j+1])^2 / 3 / (t[j+2] - t[j])
}
index = x >= t[1] & x <= t[2]
sigma[k+1, index] = -(t[2] - x[index])^3 / 3 / (t[2] - t[1])^2
index = x > t[2]
sigma[k+1, index] = 0
index = x >= t[1] & x <= t[k+1]
sigma[k+2, index] = x[index] - t[1]
index = x > t[k+1] & x <= t[k+2]
sigma[k+2, index] = t[k+1] - t[1] + ((t[k+2] - t[k+1])^2 * (x[index] - t[k+1]) - (x[index] - t[k+1])^3 / 3) / (t[k+2] - t[k+1])^2
ms = NULL
if (!interp) {
xm = cbind(1:n*0+1, x)
pm = xm %*% solve(t(xm) %*% xm) %*% t(xm)
ms = matrix(0, nrow = nrow(sigma), ncol = ncol(sigma))
for (i in 1:m) {
ms[i,] = pm %*% sigma[i,]
ms[i,] = ms[i, rank(xs)]
sigma[i,] = sigma[i,] - pm %*% sigma[i,]
sigma[i,] = sigma[i, rank(xs)]
}
} else {
for (i in 1:m) {
#sigma[i,] = sigma[i,] - pm %*% sigma[i,]
sigma[i,] = sigma[i, rank(xs)]
}
}
rslt = list(sigma = sigma, ms = ms)
rslt
}
########################################################
# Increasing and Convex
incconvex = function(xs, t, interp = FALSE) {
#xs = (xs - min(xs)) / (max(xs) - min(xs))
x = sort(xs)
n = length(x)
k = length(t) - 2
m = k + 3
sigma = matrix(0, nrow = m, ncol = n)
obs = 1:n
#knt = 1:(k+2)
#for (i in 1:(k+2)) {knt[i] = min(obs[abs(x - t[i]) == min(abs(x - t[i]))])}
for (j in 1:(k-1)) {
index = x >= t[1] & x <= t[j]
sigma[j, index] = 0
index = x > t[j] & x <= t[j+1]
sigma[j, index] = (x[index] - t[j])^3 / (t[j+2] - t[j]) / (t[j+1] - t[j]) / 3
index = x > t[j+1] & x <= t[j+2]
sigma[j, index] = x[index] - t[j+1] - (x[index] - t[j+2])^3 / (t[j+2] - t[j]) / (t[j+2] - t[j+1]) / 3 + (t[j+1] - t[j])^2 / 3 /(t[j+2] - t[j]) - (t[j+2] - t[j+1])^2 / 3 / (t[j+2] - t[j])
index = x > t[j+2]
sigma[j, index] = (x[index] - t[j+1]) + (t[j+1] - t[j])^2 / 3 / (t[j+2] - t[j]) - (t[j+2] - t[j+1])^2 / 3 / (t[j+2] - t[j])
}
index = x >= t[1] & x <= t[k]
sigma[k, index] = 0
index = x > t[k] & x <= t[k+1]
sigma[k, index] = (x[index] - t[k])^3 / (t[k+2] - t[k]) / (t[k+1] - t[k]) / 3
index = x > t[k+1] & x <= t[k+2]
sigma[k, index] = x[index] - t[k+1] - (x[index] - t[k+2])^3 / (t[k+2] - t[k]) / (t[k+2] - t[k+1]) / 3 + (t[k+1] - t[k])^2 / 3 / (t[k+2] - t[k]) - (t[k+2] - t[k+1])^2 / 3 / (t[k+2] - t[k])
index = x >= t[1] & x <= t[2]
sigma[k+1, index] = x[index] - t[1] + (t[2] - x[index])^3 / (t[2] - t[1])^2 / 3 - (t[2] - t[1]) / 3
index = x > t[2]
sigma[k+1, index] = x[index] - t[1] - (t[2] - t[1]) / 3
index = x >= t[1] & x <= t[k+1]
sigma[k+2, index] = 0
index = x > t[k+1] & x <= t[k+2]
sigma[k+2, index] = (x[index] - t[k+1])^3 / (t[k+2] - t[k+1])^2 / 3
sigma[k+3,] = x
ms = NULL
if (!interp) {
ms = apply(sigma, 1, mean)
for (i in 1:m) {
sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
} else {
for (i in 1:m) {
#sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
}
rslt = list(sigma = sigma, ms = ms)
rslt
}
########################################################
# Increasing and Concave
incconcave = function(xs, t, interp = FALSE) {
#xs = (xs - min(xs)) / (max(xs) - min(xs))
x = sort(xs)
n = length(x)
k = length(t) - 2
m = k + 3
sigma = matrix(0, nrow = m, ncol = n)
obs = 1:n
#knt = 1:(k+2)
#for(i in 1:(k+2)) {knt[i] = min(obs[abs(x - t[i]) == min(abs(x - t[i]))])}
for (j in 1:k) {
index = x >= t[1] & x <= t[j]
sigma[j, index] = x[index] - t[1]
index = x > t[j] & x <= t[j+1]
sigma[j, index] = t[j] - t[1] + ((t[j+1] - t[j])^3 - (t[j+1] - x[index])^3) / 3 / (t[j+1] - t[j]) / (t[j+2] - t[j]) + (x[index] - t[j]) * (t[j+2] - t[j+1]) / (t[j+2] - t[j])
index = x > t[j+1] & x <= t[j+2]
sigma[j, index] = t[j] - t[1] + (t[j+1] - t[j])^2 / 3 / (t[j+2] - t[j]) + (t[j+2] - t[j+1]) * (t[j+1] - t[j]) / (t[j+2] - t[j]) + ((t[j+2] - t[j+1])^3 - (t[j+2] - x[index])^3) / 3 / (t[j+2] - t[j+1]) / (t[j+2] - t[j])
index = x > t[j+2]
sigma[j, index] = t[j] - t[1] + (t[j+1] - t[j])^2 / 3 / (t[j+2] - t[j]) + (t[j+2] - t[j+1]) * (t[j+1] - t[j]) / (t[j+2] - t[j]) + (t[j+2] - t[j+1])^2 / 3 /(t[j+2] - t[j])
}
index = x >= t[1] & x <= t[2]
sigma[k+1, index] = -(t[2] - x[index])^3 / 3 / (t[2] - t[1])^2
index = x > t[2]
sigma[k+1, index] = 0
index = x >= t[1] & x <= t[k+1]
sigma[k+2, index] = x[index] - t[1]
index = x > t[k+1] & x <= t[k+2]
sigma[k+2, index] = t[k+1] - t[1] + ((t[k+2] - t[k+1])^2 * (x[index] - t[k+1]) - (x[index] - t[k+1])^3 / 3) / (t[k+2] - t[k+1])^2
sigma[k+3, ] = x
ms = NULL
if (!interp) {
ms = apply(sigma, 1, mean)
for (i in 1:m) {
sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
} else {
for (i in 1:m) {
#sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
}
rslt = list(sigma = sigma, ms = ms)
rslt
}
##############
#summary.cgam#
##############
summary.cgam <- function(object,...) {
if (!is.null(object$zcoefs)) {
family <- object$family
df.residual <- object$df.residual
wt.iter <- object$wt.iter
coefs <- object$zcoefs
se <- object$se.beta
tval <- coefs / se
pvalbeta <- object$pvals.beta
n <- length(coefs)
sse0 <- object$SSE0
sse1 <- object$SSE1
cic <- object$cic
deviance <- object$deviance
null.deviance <- object$null.deviance
df <- object$df
df.null <- object$df.null
zid <- object$zid
#zid1 <- object$zid1 - 1 - length(shapes)
#zid2 <- object$zid2 - 1 - length(shapes)
#new: zid1, zid2 just index zmat not bigmat
zid1 <- object$zid1
zid2 <- object$zid2
tms <- object$tms
is_param <- object$is_param
is_fac <- object$is_fac
vals <- object$vals
pvs <- object$pvs
s.edf <- object$s.edf
bstats <- object$bstats
if (wt.iter) {
rslt1 <- data.frame("Estimate" = round(coefs, 4), "StdErr" = round(se, 4), "z.value" = round(tval, 4), "p.value" = round(pvalbeta, 4))
rownames(rslt1)[1] <- "(Intercept)"
if (n > 1) {
lzid <- length(zid1)
for (i in 1:lzid) {
pos1 <- zid1[i]; pos2 <- zid2[i]
for (j in pos1:pos2) {
if (!is_param[i]) {
rownames(rslt1)[j + 1] <- paste(attributes(tms)$term.labels[zid[i] - 1], rownames(rslt1)[j + 1], sep = "")
} else {
rownames(rslt1)[j + 1] <- paste(attributes(tms)$term.labels[zid[i] - 1], vals[j], sep = "")
}
}
}
}
rslt1 <- as.matrix(rslt1)
#new:
rslt2 <- NULL
if (!is.null(pvs)) {
rslt2 <- data.frame("edf" = round(s.edf, 4), "mixture of Beta" = round(bstats, 4), "p.value" = round(pvs, 4))
#rownames(rslt2) <- attributes(tms)$term.labels
#debugged: check more
if (!is.null(zid)) {
rownames(rslt2) <- (attributes(tms)$term.labels)[-(zid-1)]
} else {
rownames(rslt2) <- (attributes(tms)$term.labels)
#if (any(object$shapes < 9) & length(pvs) < length(object$shapes)) {
#if (any(object$shapes < 9)) {
# rm_id = which(object$shapes < 9)
# rownames(rslt2) <- (attributes(tms)$term.labels)[-rm_id]
#} else {
# rownames(rslt2) <- (attributes(tms)$term.labels)
#}
}
}
} else {
rslt1 <- data.frame("Estimate" = round(coefs, 4), "StdErr" = round(se, 4), "t.value" = round(tval, 4), "p.value" = round(pvalbeta, 4))
rownames(rslt1)[1] <- "(Intercept)"
if (n > 1) {
lzid <- length(zid1)
for (i in 1:lzid) {
pos1 <- zid1[i]; pos2 <- zid2[i];
for (j in pos1:pos2) {
if (!is_param[i]) {
rownames(rslt1)[j + 1] <- paste(attributes(tms)$term.labels[zid[i] - 1], rownames(rslt1)[j + 1], sep = "")
} else {
rownames(rslt1)[j + 1] <- paste(attributes(tms)$term.labels[zid[i] - 1], vals[j], sep = "")
}
}
}
}
rslt1 <- as.matrix(rslt1)
rslt2 <- NULL
if (!is.null(pvs)) {
rslt2 <- data.frame("edf" = round(s.edf, 4), "mixture of Beta" = round(bstats, 4), "p.value" = round(pvs, 4))
#debugged: check more
if (!is.null(zid)) {
rownames(rslt2) <- (attributes(tms)$term.labels)[-(zid-1)]
} else {
#new: remove the group name for cgamm
if(inherits(object, "cgamm")){
rownames(rslt2) <- rev(rev((attributes(tms)$term.labels))[-1])
} else {
rownames(rslt2) <- (attributes(tms)$term.labels)
}
#if (any(object$shapes < 9) & length(pvs) < length(object$shapes)) {
#if (any(object$shapes < 9)) {
# rm_id = which(object$shapes < 9)
# rownames(rslt2) <- (attributes(tms)$term.labels)[-rm_id]
#} else {
# rownames(rslt2) <- (attributes(tms)$term.labels)
#}
}
}
}
#if (!is.null(sse0) & !is.null(sse1)) {
#rslt2 <- cbind(SSE.Linear = sse0, SSE.Full = sse1)
#new:
# rslt2 <- data.frame("SSE.Linear" = sse0, "SSE.Full" = sse1)
# rownames(rslt2)[1] <- ""
# ans <- list(call = object$call, coefficients = rslt1, residuals = rslt2, zcoefs = coefs, cic = cic, null.deviance = null.deviance, df.null = df.null, deviance = deviance, df = df, df.residual = df.residual, family = family)
# class(ans) <- "summary.cgam"
# ans
#} else {
ans <- list(call = object$call, coefficients = rslt1, coefficients2 = rslt2,
zcoefs = coefs, cic = cic, null.deviance = null.deviance, df.null = df.null,
deviance = deviance, df = df, df.residual = df.residual, family = family)
class(ans) <- "summary.cgam"
ans
#}
} else {
ans <- list(zcoefs = object$zcoefs)
class(ans) <- "summary.cgam"
ans
}
}
#############
#summary.wps#
#############
summary.wps <- function(object,...) {
rslt1 <- NULL
rslt2 <- NULL
cic <- NULL
is_param <- object$is_param
is_fac <- object$is_fac
vals <- object$vals
tms <- object$tms
if (!is.null(object$zmat)) {
coefs <- object$zcoefs
se <- object$se.beta
#tval <- object$tz
pvalbeta <- object$pvals.beta
tval <- coefs / se
n <- length(coefs)
#sse0 <- object$SSE0
#sse1 <- object$SSE1
zid <- object$zid
#new: zid1, zid2 just index zmat not bigmat
zid1 <- object$zid1
zid2 <- object$zid2
#tms <- object$tms
#zmat <- object$zmat
#is_mat <- object$is_mat
#new:
cic <- object$cic
rslt1 <- data.frame("Estimate" = round(coefs, 4), "StdErr" = round(se, 4), "t.value" = round(tval, 4), "p.value" = round(pvalbeta, 4))
#rownames(rslt1)[1] <- "(Intercept)"
if (n >= 1) {
lzid <- length(zid1)
for (i in 1:lzid) {
pos1 <- zid1[i]; pos2 <- zid2[i]
for (j in pos1:pos2) {
if (!is_param[i]) {
rownames(rslt1)[j] <- paste(attributes(tms)$term.labels[zid[i] - 1], rownames(rslt1)[j], sep = "")
} else {
rownames(rslt1)[j] <- paste(attributes(tms)$term.labels[zid[i] - 1], vals[j], sep = "")
}
}
}
}
rslt1 <- as.matrix(rslt1)
#ans <- list(call = object$call, coefficients = rslt1, coefficients2 = rslt2, zcoefs = coefs, cic = cic)
#class(ans) <- "summary.wps"
#ans
#}
}
if (!is.null(object$pval)) {
#new:
pval <- object$pval; bval <- object$bval; edf <- object$edfc
if (!is.null(pval)) {
rslt2 <- data.frame("edf" = round(edf, 4), "Beta" = round(bval, 4), "p.value" = round(pval, 4))
#debugged: check more
zid <- object$zid
if (!is.null(zid)) {
rownames(rslt2) <- (attributes(tms)$term.labels)[-(zid-1)]
} else {
rownames(rslt2) <- (attributes(tms)$term.labels)
}
}
}
ans <- list(call = object$call, coefficients = rslt1, coefficients2 = rslt2, cic = cic)
class(ans) <- "summary.wps"
ans
}
#####################
#print.cgam #
#####################
print.cgam = function (x, ...)
{
print(x$family)
cat("Call:\n")
print(x$call)
cat("\n")
if(!is.null(x$deviance)) {
cat("Null deviance: ",round(x$null.deviance,4), "", "on", x$df.null, "", "degrees of freedom", "\n")
cat("Residual deviance: ",round(x$deviance,4), "", "on", x$df.residual, "", "observed degrees of freedom", "\n")
}
if (!is.null(x$cic)) {
cat("CIC: ", round(x$cic,4))
}
invisible(x)
}
#####################
#print.summary.cgam #
#####################
print.summary.cgam <- function(x,...) {
if (!is.null(x$zcoefs)) {
#if (!is.null(x$se.beta)) {
cat("Call:\n")
print(x$call)
cat("\n")
cat("Coefficients:")
cat("\n")
printCoefmat(x$coefficients, P.values = TRUE, has.Pvalue = TRUE)
cat("\n")
if (x$family$family == "binomial") {
cat("(Dispersion parameter for binomial family taken to be 1)", "\n")
}
if (x$family$family == "poisson") {
cat("(Dispersion parameter for poisson family taken to be 1)", "\n")
}
if (x$family$family == "gaussian") {
cat("(Dispersion parameter for gaussian family taken to be ", round(x$deviance/x$df,4),")","\n", sep="")
}
cat("\n")
cat("Null deviance: ",round(x$null.deviance,4), "", "on", x$df.null, "", "degrees of freedom", "\n")
cat("Residual deviance: ",round(x$deviance,4), "", "on", x$df.residual, "", "observed degrees of freedom", "\n")
#if (is.null(x$cic)) {
# message("CIC value is not available when there is no shape-restricted predictor")
#} else {message("CIC: ", round(x$cic,4))}
if (!is.null(x$coefficients2)) {
cat("\n")
#cat("Approximate significance of smooth terms: \n")
cat("Approximate significance of constrained components: \n")
printCoefmat(x$coefficients2, P.values = TRUE, has.Pvalue = TRUE)
}
if (!is.null(x$cic)) {
cat("CIC: ", round(x$cic,4))
}
#if (!is.null(x$residuals)) {
# cat("==============================================================", "\n")
# cat("Call:\n")
# print(x$call)
# cat("\n")
# printCoefmat(x$residuals, P.values = TRUE, has.Pvalue = TRUE)
#}
} else {
print ("No linear predictor is defined")
#print ("Residual degree of freedom is negative!")
}
}
####################
#print.summary.wps #
####################
print.summary.wps <- function(x,...) {
if (!is.null(x$coefficients)) {
#if (!is.null(x$se.beta)) {
cat("Call:\n")
print(x$call)
cat("\n")
cat("Coefficients:")
cat("\n")
printCoefmat(x$coefficients, P.values = TRUE, has.Pvalue = TRUE)
cat("\n")
if (!is.null(x$cic)) {
cat("CIC: ", round(x$cic,4), "\n", sep = "")
}
}
if (!is.null(x$coefficients2)) {
cat("\n")
cat("Approximate significance of constrained surface component: \n")
printCoefmat(x$coefficients2, P.values = TRUE, has.Pvalue = TRUE)
}
}
##############
#predict.cgam#
##############
predict.cgam = function(object, newdata, interval = c("none", "confidence", "prediction"), type = c("response", "link"), level = 0.95, n.mix = 500,...) {
#print (is.data.frame(newData))
#print (newData)
#new:
#easy fix...avoid errors in this complicated function...
newData = newdata
family = object$family
cicfamily = CicFamily(family)
muhat.fun = cicfamily$muhat.fun
if (!inherits(object, "cgam")) {
warning("calling predict.cgam(<fake-cgam-object>) ...")
}
if (missing(newData) || is.null(newData)) {
#if (missing(newData)) {
etahat = object$etahat
muhat = muhat.fun(etahat, fml = family$family)
#ans = list(fit = muhat, etahat = etahat, newbigmat = object$bigmat)
ans = list(fit = muhat)
return (ans)
}
if (!is.data.frame(newData)) {
#newData = as.data.frame(newData)
stop ("newData must be a data frame!")
}
#shapes = object$shapes
#new: used for ci
prior.w = object$prior.w
vh = object$vh
y = object$y
#new: only use shapes for x != umb or tree
shapes = object$shapesx
np = object$d0; capm = object$capm; capms = object$capms; capk = object$capk; capt = object$capt; capu = object$capu
#new:
xid10 = object$xid1; xid20 = object$xid2;
uid1 = object$uid1; uid2 = object$uid2; tid1 = object$tid1; tid2 = object$tid2
#new:
xmat0 = object$xmat0; knots0 = object$knots0; numknots0 = object$numknots0; sps0 = object$sps0; ms0 = object$ms0
zmat = object$zmat; umb = object$umb; tr = object$tr
#new:
ztb = object$ztb; zid1 = object$zid1; zid2 = object$zid2; iz = 1
bigmat = object$bigmat; umbrella.delta = object$umbrella.delta; tree.delta = object$tree.delta
coefs = object$coefs; zcoefs = object$zcoefs; vcoefs = object$vcoefs; xcoefs0 = object$xcoefs; ucoefs = object$ucoefs; tcoefs = object$tcoefs
tt = object$tms
Terms = delete.response(tt)
#model.frame will re-organize newData in the original order in formula
m = model.frame(Terms, newData)
#print (m)
newdata = m
#print (head(newdata))
#new:
newx0 = NULL; newxv = NULL; newx = NULL; newx_s = NULL; newu = NULL; newt = NULL; newz = NULL; newv = NULL
#newz = list(); iz = 1;
rn = nrow(newdata)
#print (rn)
#new:
newetahat = 0; newmuhat = 0
#new: newx_sbasis
newxbasis = NULL; newx_sbasis = NULL; newubasis = NULL; newtbasis = NULL; newbigmat = NULL
#######################
#local helper function#
#######################
my_line = function(xp = NULL, y, x, end, start) {
slope = NULL
intercept = NULL
yp = NULL
slope = (y[end] - y[start]) / (x[end] - x[start])
intercept = y[end] - slope * x[end]
yp = intercept + slope * xp
ans = new.env()
ans$slope = slope
ans$intercept = intercept
ans$yp = yp
ans
}
#get shape attributes and elem out of newdata
for (i in 1:ncol(newdata)) {
if (is.null(attributes(newdata[,i])$shape)) {
if (is.factor(newdata[,i])) {
lvli = levels(newdata[,i])
ztbi = levels(ztb[[iz]])
newdatai = NULL
if (!any(lvli %in% ztbi)) {
stop ("new factor level must be among factor levels in the fit!")
} else {
id1 = which(ztbi %in% lvli)
#if (any(id1 > 1)) {
#delete the base level
klvls = length(ztbi)
if (klvls > 1) {
newimat = matrix(0, nrow = rn, ncol = klvls-1)
for (i1 in 1:rn) {
if (newdata[i1,i] != ztbi[1]) {
id_col = which(ztbi %in% newdata[i1,i]) - 1
newimat[i1,id_col] = 1
}
}
#for (i1 in 1: klvls) {
# which(levels(newdatai) == ztbi[i1])
# for (i2 in 1:rn) {
# if (levels(newdatai[i2, i1]) == lvli[i2]) {
# if (lvli[i2] != ztbi[1]) {
# newimat[i2, i1] = 1
# }
# }
# }
#}
#ztb_use = ztbi[-1]
#nc = length(id1[id1 > 1])
#newdatai = matrix(0, nrow = rn, ncol = nc)
#for (ic in 1:nc) {
# id2 = which(newdata[,i] == ztb_use[ic])
# newdatai[id2, ic] = 1
#}
newdatai = newimat
}
}
#if (length(levels(newdata[,i])) > 2) {
# klvls = length(levels(newdata[,i]))
# vals = as.numeric(levels(newdata[,i]))
# newimat = matrix(0, nrow = rn, ncol = klvls - 1)
# for (i1 in 1: (klvls - 1)) {
# for (i2 in 1:rn) {
# if (newdatai[i2] == vals[i1 + 1]) {
# newimat[i2, i1] = 1
# }
# }
# }
# newdatai = newimat
#}
} else {
newdatai = newdata[,i]
}
newz = cbind(newz, newdatai)
iz = iz + 1
#print (head(newz))
}
if (is.numeric(attributes(newdata[,i])$shape)) {
newx0 = cbind(newx0, newdata[,i])
if ((attributes(newdata[,i])$shape > 2 & attributes(newdata[,i])$shape < 5) | (attributes(newdata[,i])$shape > 10 & attributes(newdata[,i])$shape < 13)) {
newxv = cbind(newxv, newdata[,i])
}
}
if (is.character(attributes(newdata[,i])$shape)) {
if (attributes(newdata[,i])$shape == "tree") {
newt = cbind(newt, newdata[,i])
}
if (attributes(newdata[,i])$shape == "umbrella") {
newu = cbind(newu, newdata[,i])
}
}
}
#print (head(newt))
#print (head(newu))
#print (head(newx0))
#print (head(newxv))
#print (head(newz))
#print (head(newv))
#new: separate x and x_s, move shape 17 to the beginning
idx_s <- NULL
if (!is.null(shapes)) {
if (any(shapes == 17)) {
kshapes <- length(shapes)
obs <- 1:kshapes
idx_s <- obs[which(shapes == 17)]; idx <- obs[which(shapes != 17)]
newx1 <- newx0
shapes0 <- 1:kshapes*0
newx1[,1:length(idx_s)] <- newx0[,idx_s]
shapes0[1:length(idx_s)] <- shapes[idx_s]
if (length(idx) > 0) {
newx1[,(1 + length(idx_s)):kshapes] <- newx0[,idx]
shapes0[(1 + length(idx_s)):kshapes] <- shapes[idx]
}
newx0 <- newx1; shapes <- shapes0
}
#new:xmat is ordinal, xmat_s is smooth
xmat = xmat_s = NULL
newx = newx_s = NULL
knots = NULL
ms_x = ms = NULL
sh_x = sh = NULL
if (all(shapes < 9)) {
newx = newx0
xid1 = xid10; xid2 = xid20
xmat = xmat0
#new:
sh_x = shapes
ms_x = ms0
} else if (all(shapes > 8)) {
newx_s = newx0
xid1_s = xid10; xid2_s = xid20
xmat_s = xmat0
numknots = numknots0
knots = knots0
sps = sps0
sh = shapes
ms = ms0
} else if (any(shapes > 8) & any(shapes < 9)) {
newx = newx0[, shapes < 9, drop = FALSE]
xmat = xmat0[, shapes < 9, drop = FALSE]
#new:
sh_x = shapes[shapes < 9]
ms_x = ms0[shapes < 9]
xid1 = xid10[shapes < 9]; xid2 = xid20[shapes < 9]
newx_s = newx0[, shapes > 8, drop = FALSE]
xmat_s = xmat0[, shapes > 8, drop = FALSE]
sh = shapes[shapes > 8]
ms = ms0[shapes > 8]
xid1_s = xid10[shapes > 8]; xid2_s = xid20[shapes > 8]
numknots = numknots0[shapes > 8]
knots = knots0[shapes > 8]
sps = sps0[shapes > 8]
}
}
#if (!is.null(shapes) & any(shapes == 17)) {
if (!is.null(shapes)) {
vcoefs = vcoefs[1:(1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13))]
} else {vcoefs = vcoefs[1:(1 + capk)]}
if (capk > 0) {
vcoefs_nz = vcoefs[-c(2:(1 + capk))]
} else {vcoefs_nz = vcoefs}
newv = cbind(1:rn*0 + 1, newz, newxv)
newv_nz = cbind(1:rn*0 + 1, newxv)
#print (newv_nz)
#print (vcoefs)
#etahat_v = as.vector(newv %*% vcoefs)
etahat_v_nz = as.vector(newv_nz %*% vcoefs_nz)
#print (etahat_v_nz)
#new:
etahat_s = 1:rn*0; newx_sbasis = NULL; xs_coefs = NULL; var_xs = NULL
if (!is.null(newx_s)) {
ks = ncol(newx_s)
del = NULL
for (i in 1:ks) {
xi = xmat_s[,i]
nxi = newx_s[,i]
if (any(nxi > max(xi)) | any(nxi < min(xi))) {
stop ("No extrapolation is allowed in cgam prediction!")
}
#new: scale accordingly
#nxi = (nxi - min(xi)) / (max(xi) - min(xi))
pos1 = xid1_s[i] - (1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13))
pos2 = xid2_s[i] - (1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13))
xs_coefs = c(xs_coefs, xcoefs0[pos1:pos2])
msi = ms[[i]]
deli_ans = makedelta(nxi, sh[i], numknots[i], knots[[i]], space = sps[i], suppre = TRUE, interp = TRUE)
deli = deli_ans$amat
if (sh[i] > 10 & sh[i] < 13) {
#x = xmat_s[,i]
xs = sort(xi)
ord = order(xi)
nx = length(xi)
obs = 1:nx
nr = nrow(deli)
nc = length(nxi)
ms2 = matrix(0, nrow = nr, ncol = nc)
for (i1 in 1:nc) {
for (i2 in 1:nr) {
ms2[i2, i1] = my_line(xp = nxi[i1], y = msi[i2, ][ord], x = xs, end = nx, start = 1)$yp
}
}
deli = deli - ms2
} else {
deli = deli - msi
}
#new:
var_xs = c(var_xs, 1:nrow(deli)*0 + i)
del = rbind(del, deli)
}
newx_sbasis = t(del)
etahat_s = as.vector(newx_sbasis %*% xs_coefs)
}
etahat_x = 1:rn*0; newxbasis = NULL; xcoefs = NULL; var_x = NULL
if (!is.null(newx)) {
kx = ncol(xmat)
del = NULL
for (i in 1:kx) {
xi = xmat[,i]
#new:
nxi = newx[,i]
if (any(nxi > max(xi)) | any(nxi < min(xi))) {
stop ("No extrapolation is allowed in cgam prediction!")
}
#new: scale accordingly
#nxi = (nxi - min(xi)) / (max(xi) - min(xi))
shi = sh_x[i]
pos1 = xid1[i] - (1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13))
pos2 = xid2[i] - (1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13))
xcoefs = c(xcoefs, xcoefs0[pos1:pos2])
deli = pred_del(xi, shi, nxi, ms_x[[i]])
#new:
var_x = c(var_x, 1:nrow(deli)*0 + i)
del = rbind(del, deli)
}
#new:
newxbasis = t(del)
etahat_x = as.vector(newxbasis %*% xcoefs)
}
#new:
etahat_u = 1:rn*0; newuedge = NULL
if (!is.null(newu)) {
for (j in 1:ncol(umb)) {
u = umb[,j]
nu = length(u)
us = sort(u)
ord = order(u)
if (any(newu[,j] > max(u)) | any(newu[,j] < min(u))) {
stop ("no extrapolation is allowed in cgam!")
}
#u_edges = t(umbrella.fun(u))
pos1 = uid1[j]; pos2 = uid2[j]
u_edges = t(bigmat[pos1:pos2, , drop = FALSE])
nuedge = ncol(u_edges)
newuedge0 = matrix(0, nrow = rn, ncol = nuedge)
for (i in 1:nuedge) {
ue = u_edges[,i]; udist = round(diff(ue), 4); s = sign(udist)
ueord = ue[ord]; udistord = round(diff(ueord), 4); sord = sign(udistord)
obs = 1:(nu-1)
posin = obs[sord != 0] + 1
pos = unique(c(1, posin, nu))
uk = us[pos]
uek = ueord[pos]
npos = length(pos)
nd = length(newu[,j])
for (l in 1:(npos-1)) {
if (any(newu[,j] == uk[npos])) {
ids = which(newu[,j] == uk[npos])
newuedge0[ids,i] = uek[npos]
}
if (any(newu[,j] >= uk[l]) & any(newu[,j] < uk[l+1])) {
ids = which(newu[,j] >= uk[l] & newu[,j] < uk[l+1])
newuedge0[ids,i] = uek[l]
}
}
}
newuedge = cbind(newuedge, newuedge0)
}
newubasis = newuedge
etahat_u = as.vector(newubasis %*% ucoefs)
}
# we don't have a newtbasis
# estimate tree
etahat_t = 1:rn*0
#print (newt)
if (!is.null(newt)) {
#each column of tru is a "table" of all levels of a tree var
tru = unique(tr)#; placebo = min(tru)
#tr_etahat = 0
for (i in 1: ncol(newt)) {
pos1 = tid1[i] - np - capm - capu
pos2 = tid2[i] - np - capm - capu
newtu = unique(newt[,i])
#tcoefi = tcoefs[pos1:pos2]
#check! add 0 to be the coef for placebo
tcoefi = c(0, tcoefs[pos1:pos2])
if (!all(newtu %in% tru[,i])) {
stop ("new tree ordering factor must be among the old tree ordering factors!")
}
#placebo = min(tru[,i])
#new:
placebo = object$pl[i]
if (any(newtu != placebo)) {
#id_cf = which(tru[,i] %in% newtu) - 1 #no coef for placebo
#tr_etahat = tr_etahat + tcoefi[id_cf]
#id_cf = which(newtu > placebo)
id_cf = which(newtu != placebo)
t_use = newtu[id_cf]
nt = length(t_use)
for (it in 1:nt) {
etahat_t[newt[,i] == t_use[it]] = etahat_t[newt[,i] == t_use[it]] + tcoefi[tru[,i] == t_use[it]]
}
}
}
#etahat_t = tr_etahat
}
#print (etahat_v)
#print (etahat_s)
#print (etahat_x)
#print (etahat_u)
#print (etahat_t)
etahat_z = 1:rn*0; zcf = NULL
#print (newt)
#print (newdata)
if (!is.null(newz)) {
#delete the coef for 1
zcoefs = zcoefs[-1]
etahat_z = newz %*% zcoefs
#ztbu = unique(ztb)#; placebo = min(ztbu)
#lz = ncol(newz)
#for (i in 1:lz) {
# pos1 = zid1[i]
# pos2 = zid2[i]
# zcoefi = zcoefs[pos1:pos2]
# zlvi = zcoefs[pos1:pos2]
# etahat_z[newz[,i] == 1] = etahat_z[newz[,i] == 1] + zcoefi
#}
}
#print (etahat_z)
etahat_v = etahat_v_nz + etahat_z
newetahat = etahat_v + etahat_s + etahat_x + etahat_u + etahat_t
newmuhat = as.vector(muhat.fun(newetahat, fml = family$family))
if (!is.null(newt)) {
newtbasis = t(tree.delta[,1:nrow(newData),drop = FALSE])
}
#print (newv)
#newbigmat = t(cbind(newv, newx_sbasis, newxbasis, newubasis, newtbasis))
#ans = list(v = newv, xbs = newxbasis, x_sbs = newx_sbasis, ubs = newubasis, tbs = newtbasis, bigmat = newbigmat, vcoefs = vcoefs, xcoefs = xcoefs, xs_coefs = xs_coefs, ucoefs = ucoefs, etahat = newetahat, muhat = newmuhat)
#ans = list(muhat = newmuhat)
#muhat = newmuhat
if ("none" %in% interval) {
ans = list(fit = newmuhat, object = object)
#new: add prediction interval
} else if (interval == "confidence" | interval == "prediction") {
n = ncol(bigmat)
nc = ncol(xmat0)
spl = splpr = NULL
m_acc = 0
object$ms0 -> ms0
#sh = 17 first
object$shapesx0 -> shapes
#new:
varlist = NULL
for (i in 1:nc) {
msi = ms0[[i]]
shpi = shapes[i]
ki = knots0[[i]]
xi = xmat0[,i]
xipr = newx0[,i]
deli = makedelta(xi, shpi, knots = ki)
#print (i)
#if (i == 2) {
# stop (print (msi))
#}
spli = deli$amat
varlist = c(varlist, rep(i, nrow(spli)))
if (shpi >= 9) {
dpri = makedelta(xipr, shpi, knots = ki, suppre = TRUE, interp = TRUE)
splpri = dpri$amat
if (shpi > 10 & shpi < 13) {
xs = sort(xi)
ord = order(xi)
#nx = length(xi)
#nx is n
obs = 1:n
nr = nrow(splpri)
#nc = length(xipr)
#rn is the length of a new vector
ms2 = matrix(0, nrow = nr, ncol = rn)
for (i1 in 1:rn) {
for (i2 in 1:nr) {
ms2[i2, i1] = my_line(xp = xipr[i1], y = msi[i2, ][ord], x = xs, end = n, start = 1)$yp
}
}
splpri = splpri - ms2
} else {
splpri = splpri - msi
}
} else {splpri = pred_del(xi, shpi, xipr, msi)}
mi = dim(spli)[1]
m_acc = m_acc + mi
spl = rbind(spl, spli)
splpr = rbind(splpr, splpri)
}
capk = object$capk
p = 1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13)
zmat = t(bigmat[1:p, ,drop = FALSE])
if (family$family == "gaussian") {
#nloop = 1000
nloop = n.mix
#nsec will be too big for ordinal, ignore for now
nsec = 2^m_acc
#print (dim(zmat))
if (is.null(prior.w)) {
prior.w = rep(1, n)
}
if (!all(prior.w == 1)) {
for (i in 1:n) {
spl[,i] = spl[,i] * sqrt(prior.w[i])
zmat[i,] = zmat[i,] * sqrt(prior.w[i])
}
}
if (!is.null(vh)) {
wvec = 1/vh
} else if (is.null(vh) & !is.null(prior.w)) {
wvec = prior.w
} else if (is.null(vh) & is.null(prior.w)) {
wvec = rep(1, n)
}
if (!all(wvec == 1)) {
for (i in 1:n) {
spl[,i] = spl[,i] * sqrt(wvec[i])
zmat[i,] = zmat[i,] * sqrt(wvec[i])
}
}
yw = y * sqrt(wvec)
#ans1 = coneB(yw, spl, zmat)
ans1 = coneB(yw, t(spl), zmat)
face = ans1$face
muhat = ans1$yhat
#muhat = object$muhat
muhat0 = muhat / sqrt(wvec)
#muhat0 = object$muhat
#muhat = muhat0 * sqrt(prior.w)
#print (ans1$df)
#print (ans1$coef)
sighat = sqrt(sum((yw - muhat)^2) / (n - 1.5*ans1$df)) ## varest is too large but "conservative"
#sighat = sqrt(sum((yw - muhat)^2) / (n - 1.5*object$df_obs))
nv = p
## estimate sector probabilties
#set.seed(1)
#sector = Matrix(1:nsec*0,nrow=1)
#sector = big.matrix(1:nsec*0,nrow=1)
#sector = 1:nsec*0
#for (iloop in 1:nloop) {
# ysim = muhat0 + rnorm(n)*sighat
# ysim = ysim * sqrt(wvec)
# #ans = coneB(ysim, spl, zmat)
# ans = coneB(ysim, t(spl), zmat, face = face)
# cf = round(ans$coefs[(nv+1):(m_acc+nv)], 10)
# sec = 1:m_acc*0
# sec[cf > 0] = 1
# r = makebin(sec) + 1
# sector[r] = sector[r] + 1
#}
### calculate the mixture hat matrix:
#bsec = matrix(0, nrow=nsec,ncol=2)
#bsec[,1] = 1:nsec
#bsec[,2] = sector / nsec
#keep = sector > 0
#bsec = bsec[keep,]
#ns = dim(bsec)[1]
#bsec[,2] = bsec[,2] / sum(bsec[,2])
#new: not use sector = 1:nsec*0; simulate for 1,000 times and record the faces used more than once
# if times / nloop < 1e-3, then delete
sector = NULL
times = NULL
df = NULL
#first column shows sector; second column shows times
for (iloop in 1:nloop) {
ysim = muhat0 + rnorm(n)*sighat
ysim = ysim * sqrt(prior.w)
ans = coneB(ysim, t(spl), zmat, face = face)
cf = round(ans$coefs[(nv+1):(m_acc+nv)], 10)
sec = 1:m_acc*0
sec[cf > 0] = 1
sector = rbind(sector, sec)
r = makebin(sec) + 1
#sector[r] = sector[r] + 1
if (iloop == 1) {
df = rbind(df, c(r, 1))
} else {
if (r %in% df[,1]) {
ps = which(df[,1] %in% r)
df[ps,2] = df[ps,2] + 1
} else {
df = rbind(df, c(r, 1))
}
}
}
#remove times/sum(times) < 1e-3??
sm_id = which((df[,2]/nloop) < 1e-3)
if (any(sm_id)) {
df = df[-sm_id, ,drop=FALSE]
}
#new:
ns = nrow(df)
bsec = df
bsec[,2] = bsec[,2] / sum(bsec[,2])
ord = order(bsec[,1])
bsec = bsec[ord, ,drop=FALSE]
### calculate the mixture cov(alpha) matrix:
obs = 1:m_acc;oobs = 1:(m_acc+nv)
acov = matrix(0, nrow = m_acc+nv, ncol = m_acc+nv)
for (is in 1:ns) {
if (bsec[is,2] > 0) {
jvec = getbin(bsec[is,1], m_acc)
if (sum(jvec) == 1) {
smat = cbind(zmat, spl[which(jvec==1),])
} else if (sum(jvec) == 0) {
smat = zmat
} else {
smat = cbind(zmat, t(spl[which(jvec==1),]))
}
acov1 = bsec[is,2]*solve(t(smat)%*%smat)
acov2 = matrix(0,nrow=m_acc+nv,ncol=m_acc+nv)
jobs = 1:(m_acc+nv)>0
jm = 1:m_acc>0
jm[obs[jvec==0]] = FALSE
jobs[(nv+1):(m_acc+nv)] = jm
nobs = oobs[jobs==TRUE]
for (i in 1:sum(jobs)) {
acov2[nobs[i],jobs] = acov1[i,]
}
acov = acov+acov2
}
}
acov = acov*sighat^2
#only xmatpr and splpr have interpolation points
xmatpr = cbind(newv, t(splpr))
#muhatpr = xmatpr %*% ans1$coefs
#temp:
muhatpr = xmatpr %*% object$coefs[1:ncol(xmatpr), ,drop=FALSE]
#new: C.I. level
mult = qnorm((1 - level)/2, lower.tail=FALSE)
#hl = 2*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
if (interval == "confidence") {
hl = mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
}
if (interval == "prediction") {
hl = mult*sqrt(sighat^2+diag(xmatpr%*%acov%*%t(xmatpr)))
}
#ans = list(fit = muhatpr, lower = muhatpr - hl, upper = muhatpr + hl)
} else {
## initialize
m = nrow(bigmat)
#amat is different from the original code, because we put zmat at the first p columns in cgam
#amat = matrix(0, nrow = (m-p), ncol = m)
#for(i in (p+1):m){amat[i,i]=1}
#the constraint is amat%*%bh >= 0; not constrain vmat
amat = diag(m-p)
zerom = matrix(0, nrow=nrow(amat), ncol=p)
amat = cbind(zerom, amat)
#alp0 = 1:m*0
#eta0 = del%*%alp0
#eta0 = 1:n*0
#mu0 = 1:n*0 + 0.5
z = 1:n*0
## get the dimension of the face
deltil = t(bigmat)
w = object$wt
#print (any(w < 0))
for(i in 1:m){deltil[,i]=deltil[,i]*sqrt(w)}
umat = chol(crossprod(deltil))
uinv = solve(umat)
atil = amat%*%uinv
bh = coef(object)
#check
etahat = object$etahat
muhat = fitted(object)
#z = etahat + (y - muhat)/muhat/(1-muhat)
#ch = muhat > 1e-5 & muhat < 1-(1e-5)
#z[ch] = etahat[ch] + (y[ch]-muhat[ch])/muhat[ch]/(1-muhat[ch])
#z[!ch] = etahat[!ch]
#w[ch] = muhat[ch]*(1-muhat[ch])
#w[!ch] = 1e-5
#z=eta0+(y-mu0)/mu0/(1-mu0)
ch = muhat > 1e-5 & muhat < 1-(1e-5)
z[ch] = etahat[ch] + (y[ch]-muhat[ch])/muhat[ch]/(1-muhat[ch])
z[!ch] = etahat[!ch]
w[ch] = muhat[ch]*(1-muhat[ch])
w[!ch] = 1e-5
ztil = z*sqrt(w)
#z = etahat + (y - muhat) / family$variance(muhat)
#print (family$variance(muhat)): sometimes give a value that is almost zero and it creates NA in thhat
#ztil = z*sqrt(w)
rw = round(amat%*% bh, 6) == 0
#print (rw)
#print (sum(rw))
if(sum(rw) == 0){
raj = 0
edf = m
} else {
ajc = atil[rw,]
raj = rankMatrix(t(ajc))[1]
edf = min(m, 1.2*(m-raj))
}
## thhat is final cone projection
thhat = deltil %*% bh
#print (thhat)
#print (ztil)
#shat = sum((ztil - thhat)^2)/(n - edf)
#correction: 2/16/2025; shat is always 1.
shat = 1
#print (shat)
nloop = 100
cmat = matrix(0, nrow = m, ncol = m)
imat = diag(m)
for(iloop in 1:nloop){
zsim = thhat + rnorm(n)*shat
zsimtil = t(uinv) %*% t(deltil) %*% zsim
#if (iloop == 1) {
asim = coneA(zsimtil, atil)
# face = asim$face
#} else {
# if (length(face) >= 1) {
# asim = coneA(zsimtil, atil, face = face)
# } else{asim = coneA(zsimtil, atil)}
#}
## get the matrix wm: cols span row space orthogonal to rows of A_J^c
rw = round(atil %*% asim$thetahat, 6) == 0
#print (shat)
#print (rw)
if(sum(rw) == 0){
#pjmat = t(atil) %*% solve(atil %*% t(atil)) %*% atil
#pjmat = t(atil) %*% solve(tcrossprod(atil), atil)
#correction: 2/16/2025;
pjmat = imat
} else {
ajc = atil[rw,]
if(length(ajc) == m){
wm = ajc/sqrt(sum(ajc^2))
wm = matrix(wm, ncol=1)
}else{
aqr = qr(t(ajc))
wm = qr.Q(aqr)[,1:aqr$rank]
}
pjmat = -wm%*%t(wm)
for(i in 1:m){pjmat[i,i] = pjmat[i,i]+1}
}
cmat = cmat + uinv %*% pjmat %*% t(uinv)/nloop
}
cmat = cmat*shat
#coveta = diag(del%*%cmat%*%t(del))
xmatpr = cbind(newv, t(splpr))
#coveta = diag(del%*%cmat%*%t(del))
coveta = diag(xmatpr%*%cmat%*%t(xmatpr))
etapr = xmatpr%*%bh
#muhatpr = 1 - 1/(1+exp(etapr))
muhatpr = family$linkinv(etapr)
#new: C.I. level
mult = qnorm((1 - level)/2, lower.tail=FALSE)
#if (interval == "confidence") {
uppeta = etapr + mult*sqrt(coveta)
loweta = etapr - mult*sqrt(coveta)
uppmu = family$linkinv(uppeta)
lowmu = family$linkinv(loweta)
#uppmu = 1 - 1/(1+exp(uppeta))
#lowmu = 1 - 1/(1+exp(loweta))
#}
}
#new: thvs are for individual c.i. bands and surfaces
#smooth additive terms only, no umbrella or tree
if (family$family == "gaussian") {
dcoefs = object$coefs[(np - capms + 1):(np + capm),,drop=FALSE]
etacomps = object$etacomps
capl = nrow(etacomps)
thvs_upp = thvs_lwr = matrix(0, nrow = capl, ncol = rn)
ncon = 1
# temp: constrained smooth terms covariance
acov2 = acov[-c(1:np),-c(1:np)]
for (i in 1:capl) {
ddi = t(splpr[varlist == i, ,drop=FALSE])
acovi = acov2[varlist == i, varlist == i]
hli = mult*sqrt(diag(ddi %*% acovi %*% t(ddi)))
ei = ddi%*%dcoefs[varlist == i, ,drop=FALSE]
thvs_upp[i,] = ei + hli
thvs_lwr[i,] = ei - hli
}
# order thvs back
if (length(idx_s) > 0) {
thvs0_upp = thvs_upp
thvs0_upp[idx_s,] = thvs_upp[1:length(idx_s), ]
thvs0_lwr = thvs_lwr
thvs0_lwr[idx_s,] = thvs_lwr[1:length(idx_s), ]
if (length(idx) > 0) {
thvs0_upp[idx,] = thvs_upp[(1+length(idx_s)):capl, ]
thvs0_lwr[idx,] = thvs_lwr[(1+length(idx_s)):capl, ]
}
thvs_upp = thvs0_upp
thvs_lwr = thvs0_lwr
}
#new: problem when not gaussian
if (object$sc_y) {
for (i in 1:nrow(thvs_upp)) {
thvs_upp[i,] = thvs_upp[i,] * object$sc
thvs_lwr[i,] = thvs_lwr[i,] * object$sc
}
}
}
#new: NASA's idea for monotonic CI
if (family$family == "gaussian") {
lwr = muhatpr - hl
upp = muhatpr + hl
} else {
lwr = loweta
upp = uppeta
}
#for now, only handles one predictor
if (length(object$shapes) == 1) {
ord = order(newx0) #need a better way for > 1 predictor case
lwr_tmp = lwr[ord]
upp_tmp = upp[ord]
lwr_tmp_u = unique(lwr_tmp)
upp_tmp_u = unique(upp_tmp)
check_ps_lwr = diff(lwr_tmp_u)
check_ps_upp = diff(upp_tmp_u)
if (object$shapes == 9) {
ps_lwr = which(check_ps_lwr < 0)
n_ps_lwr = length(ps_lwr)
if(n_ps_lwr > 0){
#NASA's for loop, the easier way is not working now....
n = length(lwr_tmp)
for(i in 1:(n - 1)){
if(lwr_tmp[i + 1] < lwr_tmp[i]){
lwr_tmp[i + 1] = lwr_tmp[i]
}
}
}
#lwr_tmp[ps_lwr + 1] = lwr_tmp[ps_lwr]
ps_upp = which(check_ps_upp < 0)
n_ps_upp = length(ps_upp)
if(n_ps_upp > 0) {
n = length(upp_tmp)
for(i in (n - 1):1){
if(upp_tmp[i] > upp_tmp[i + 1]){
upp_tmp[i] = upp_tmp[i + 1]
}
}
}
#upp_tmp[ps_upp] = upp_tmp[ps_upp + 1]
}
if (object$shapes == 10) {
ps_lwr = which(check_ps_lwr > 0)
n_ps_lwr = length(ps_lwr)
if(n_ps_lwr > 0){
n = length(lwr_tmp)
for(i in (n - 1):1){
if(lwr_tmp[i] < lwr_tmp[i + 1]){
lwr_tmp[i] = lwr_tmp[i + 1]
}
}
}
#lwr_tmp[ps_lwr] = lwr_tmp[ps_lwr + 1]
ps_upp = which(check_ps_upp > 0)
n_ps_upp = length(ps_upp)
if(n_ps_upp > 0) {
n = length(upp_tmp)
for(i in 1:(n - 1)){
if(upp_tmp[i + 1] > upp_tmp[i]){
upp_tmp[i + 1] = upp_tmp[i]
}
}
}
#upp_tmp[ps_upp + 1] = upp_tmp[ps_upp]
}
lwr = lwr_tmp[order(ord)]
upp = upp_tmp[order(ord)]
#loweta = lwr
#uppeta = upp
#lwr = lwr_tmp
#upp = upp_tmp
}
if ("response" %in% type) {
lwr = family$linkinv(lwr)
upp = family$linkinv(upp)
}
if (family$family == "gaussian") {
ans = list(fit = muhatpr, lower = lwr, upper = upp, acov = acov, object = object, mult = mult, thvs_upp = thvs_upp, thvs_lwr = thvs_lwr)
#ans = list(fit = muhatpr, lower = muhatpr - hl, upper = muhatpr + hl, acov = acov, object = object, mult = mult, thvs_upp = thvs_upp, thvs_lwr = thvs_lwr)
} else { #else if (family$family == "binomial") {
if ("response" %in% type) {
ans = list(fit = muhatpr, lower = lwr, upper = upp, object = object, mult = mult)
#ans = list(fit = muhatpr, lower = lowmu, upper = uppmu, object = object, mult = mult)
} else if ("link" %in% type) {
ans = list(fit = etapr, lower = lwr, upper = upp, object = object, mult = mult)
#ans = list(fit = etapr, lower = loweta, upper = uppeta, object = object, mult = mult)
}
}
}
class(ans) = "cgamp"
return (ans)
}
#############################
#predict delta for ordinal x#
#############################
pred_del = function(x, sh, xp, ms) {
n = length(xp)
#x = (x - min(x)) / (max(x) - min(x))
xu = sort(unique(x))
n1 = length(xu)
sigma = NULL
#######################
#local helper function#
#######################
my_line = function(xp = NULL, y, x, end, start) {
slope = NULL
intercept = NULL
yp = NULL
slope = (y[end] - y[start]) / (x[end] - x[start])
intercept = y[end] - slope * x[end]
yp = intercept + slope * xp
ans = new.env()
ans$slope = slope
ans$intercept = intercept
ans$yp = yp
ans
}
# increasing or decreasing
if (sh < 3) {
sigma = matrix(0, nrow = n1 - 1, ncol = n)
for (i in 1: (n1 - 1)) {
sigma[i, xp > xu[i]] = 1
}
if (sh == 2) {sigma = -sigma}
for (i in 1:(n1 - 1)) {sigma[i, ] = sigma[i, ] - ms[i]}
}
if (sh == 3 | sh == 4) {
# convex or concave
sigma = matrix(0, nrow = n1 - 2, ncol = n)
#for (i in 1: (n1 - 2)) {
# sigma[i, x > xu[i]] = x[x > xu[i]] - xu[i]
#}
for (i in 1: (n1 - 2)) {
sigma[i, xp > xu[i+1]] = xp[xp > xu[i+1]] - xu[i+1]
}
if (sh == 4) {sigma = -sigma}
#xm = cbind(1:n*0+1, xp)
#xpx = solve(t(xm) %*% xm)
#pm = xm %*% xpx %*% t(xm)
#sigma = sigma - sigma %*% t(pm)
xs = sort(x)
ord = order(x)
nx = length(x)
obs = 1:nx
m = nrow(ms)
ms0 = matrix(0, nrow = m, ncol = n)
for (i1 in 1:n) {
for (i2 in 1:m) {
ms0[i2, i1] = my_line(xp = xp[i1], y = ms[i2, ][ord], x = xs, end = nx, start = 1)$yp
}
}
sigma = sigma - ms0
}
if (sh > 4 & sh < 9) {
sigma = matrix(0, nrow = n1 - 1, ncol = n)
if (sh == 5) { ### increasing convex
for (i in 1:(n1 - 1)) {
sigma[i, xp > xu[i]] = (xp[xp > xu[i]] - xu[i]) / (max(x) - xu[i])
}
for (i in 1:(n1 - 1)) {sigma[i,] = sigma[i,] - ms[i]}
} else if (sh == 6) { ## decreasing convex
for (i in 1:(n1 - 1)) {
sigma[i, xp < xu[i + 1]] = (xp[xp < xu[i + 1]] - xu[i + 1]) / (min(x) - xu[i + 1])
}
for (i in 1:(n1 - 1)) {sigma[i,] = sigma[i,] - ms[i]}
#print (ms)
} else if (sh == 7) { ## increasing concave
for (i in 1:(n1 - 1)) {
sigma[i, xp < xu[i + 1]] = (xp[xp < xu[i + 1]] - xu[i + 1]) / (min(x) - xu[i + 1])
}
for (i in 1:(n1 - 1)) {sigma[i,] = -sigma[i,] + ms[i]}
} else if (sh == 8) {## decreasing concave
for (i in 1:(n1 - 1)) {
sigma[i, xp > xu[i]] = (xp[xp > xu[i]] - xu[i]) / (max(x) - xu[i])
}
for (i in 1:(n1 - 1)) {sigma[i,] = -sigma[i,] + ms[i]}
}
}
return (sigma)
}
##############
#predict.wps#
# >= pairs + additive + z
##############
predict.wps = function(object, newData, interval = c("none", "confidence", "prediction"), type = c("response", "link"), level = 0.95, ...) {
#new:
family = object$family
cicfamily = CicFamily(family)
muhat.fun = cicfamily$muhat.fun
if (!inherits(object, "wps")) {
warning("calling predict.wps(<fake-wps-object>) ...")
}
if (missing(newData) || is.null(newData)) {
#if (missing(newData)) {
#etahat = object$etahat
#muhat = muhat.fun(etahat, fml = family$family)
#ans = list(fit = muhat, etahat = etahat, newbigmat = object$bigmat)
ans = list(fit = object$muhat)
return (ans)
}
if (!is.data.frame(newData)) {
#newData = as.data.frame(newData)
stop ("newData must be a data frame!")
}
#shapes = object$shapes
#new: used for ci
ahat = object$coefs
coef_wp = object$coef_wp
prior.w = object$prior.w
pen = object$pen
dmat = object$dmat
amat = object$amat
y = object$y
##zmat includes one vector and also conc, conv, shape=17, additive
#no more
zmat = object$zmat
#vmat includes one vector and also conc, conv, shape=17
#vmat = object$vmat
#delta includes everything
delta = object$delta
tt = object$tms
Terms = delete.response(tt)
#model.frame will re-organize newData in the original order in formula
m = model.frame(Terms, newData)
newdata = m
#print (head(newdata))
#new:
newx0 = NULL; newxv = NULL; newx = NULL; newx_s = NULL; newu = NULL; newt = NULL; newz = NULL; newv = NULL
#newz = list();
ztb = object$ztb; zid1 = object$zid1; zid2 = object$zid2; iz = 1
rn = nrow(newdata)
#at least one pair in decrs and ks_wps
decrs = object$decrs
ks_wps = object$ks_wps
sps_wps = list()
dcss = list()
x1_wps = x2_wps = list()
iwps = 0
varlist = object$varlist_wps
#varlist = varlist[-1]
#######################
#local helper function#
#######################
my_line = function(xp = NULL, y, x, end, start) {
slope = NULL
intercept = NULL
yp = NULL
slope = (y[end] - y[start]) / (x[end] - x[start])
intercept = y[end] - slope * x[end]
yp = intercept + slope * xp
ans = new.env()
ans$slope = slope
ans$intercept = intercept
ans$yp = yp
ans
}
#get shape attributes and elem out of newdata
for (i in 1:ncol(newdata)) {
if (is.null(attributes(newdata[,i])$shape)) {
if (is.factor(newdata[,i])) {
lvli = levels(newdata[,i])
ztbi = levels(ztb[[iz]])
newdatai = NULL
if (!any(lvli %in% ztbi)) {
stop ("new factor level must be among factor levels in the fit!")
} else {
id1 = which(ztbi %in% lvli)
klvls = length(ztbi)
if (klvls > 1) {
newimat = matrix(0, nrow = rn, ncol = klvls-1)
for (i1 in 1:rn) {
if (newdata[i1,i] != ztbi[1]) {
id_col = which(ztbi %in% newdata[i1,i]) - 1
newimat[i1,id_col] = 1
}
}
newdatai = newimat
}
}
} else {
newdatai = newdata[,i]
}
newz = cbind(newz, newdatai)
iz = iz + 1
}
if (length(attributes(newdata[,i])$decreasing)>1) {
iwps = iwps + 1
#sps_wp = attributes(newdata[, i])$space
#sps_wps[[iwps]] = sps_wp
dcs = attributes(newdata[, i])$decreasing
dcss[[iwps]] = dcs
x1_wp = (newdata[, i])[, 1]
x1_wps[[iwps]] = x1_wp
x2_wp = (newdata[, i])[, 2]
x2_wps[[iwps]] = x2_wp
}
if (is.numeric(attributes(newdata[,i])$shape)) {
newx0 = cbind(newx0, newdata[,i])
if ((attributes(newdata[,i])$shape > 2 & attributes(newdata[,i])$shape < 5) | (attributes(newdata[,i])$shape > 10 & attributes(newdata[,i])$shape < 13)) {
newxv = cbind(newxv, newdata[,i])
}
}
#if (is.character(attributes(newdata[,i])$shape)) {
# if (attributes(newdata[,i])$shape == "tree") {
# newt = cbind(newt, newdata[,i])
# }
# if (attributes(newdata[,i])$shape == "umbrella") {
# newu = cbind(newu, newdata[,i])
# }
#}
}
#conc, or conv + shape=17 + other shapes + zmat (including one) + wps
m_acc_add = 0
spl_add = splpr_add = NULL
if (!is.null(newx0)) {
shapes = object$shapes
#put s=17 first as in wps.fit
if (any(shapes == 17)) {
kshapes = length(shapes)
obs = 1:kshapes
idx_s = obs[which(shapes == 17)]; idx = obs[which(shapes != 17)]
newx1 = newx0
shapes0 = 1:kshapes*0
newx1[,1:length(idx_s)] = newx0[,idx_s]
shapes0[1:length(idx_s)] = shapes[idx_s]
if (length(idx) > 0) {
newx1[,(1 + length(idx_s)):kshapes] = newx0[,idx]
shapes0[(1 + length(idx_s)):kshapes] = shapes[idx]
}
newx0 = newx1; shapes = shapes0
}
nc = ncol(newx0)
ms = object$ms
knotsuse_add = object$knotsuse_add
#17 is first
xmat0_add = object$xmat0_add
for (i in 1:nc) {
msi = ms[[i]]
shpi = shapes[i]
ki = knotsuse_add[[i]]
xi = xmat0_add[,i]
xipr = newx0[,i]
if (any(xipr > max(ki)) | any(xipr < min(ki))) {
stop ("No extrapolation is allowed in cgam prediction!")
}
#if (shpi >= 9) {
dpri = makedelta(xipr, shpi, knots = ki, suppre = TRUE, interp = TRUE)
splpri = dpri$amat
if (shpi > 10 & shpi < 13) {
xs = sort(xi)
ord = order(xi)
#nx = length(xi)
#nx is n
obs = 1:n
nr = nrow(splpri)
#nc = length(xipr)
#rn is the length of a new vector
ms2 = matrix(0, nrow = nr, ncol = rn)
for (i1 in 1:rn) {
for (i2 in 1:nr) {
ms2[i2, i1] = my_line(xp = xipr[i1], y = msi[i2, ][ord], x = xs, end = n, start = 1)$yp
}
}
splpri = splpri - ms2
} else {
splpri = splpri - msi
}
#} else {splpri = pred_del(xi, shpi, xipr, msi)}
mi = dim(splpri)[1]
m_acc_add = m_acc_add + mi
#splpr_add = rbind(splpr_add, splpri)
splpr_add = cbind(splpr_add, t(splpri))
}
}
#temp
#newv = cbind(1:rn*0 + 1, newz, newxv)
#newv = cbind(newxv, splpr_add, 1:rn*0 + 1, newz)
newv = cbind(newxv, splpr_add, newz)
np = ncol(newv)
n = length(y)
splpr = NULL
splpr_lst = mus = list()
m_acc = 0
#loop through total number of wps pairs
for (i in 1:iwps) {
k1 = ks_wps[[i]][[1]]
k2 = ks_wps[[i]][[2]]
nxi1 = x1_wps[[i]]
nxi2 = x2_wps[[i]]
if (any(nxi1 > max(k1)) | any(nxi1 < min(k1)) | any(nxi2 > max(k2)) | any(nxi2 < min(k2))) {
stop ("No extrapolation is allowed in cgam prediction!")
}
#sps_wp = sps_wps[[i]]
#space, m1_0, m2_0 don't matter
deli = makedelta_wps(nxi1, nxi2, m1_0 = length(k1), m2_0 = length(k2), k1, k2, space = c("E",
"E"), decreasing = decrs[[i]], interp = TRUE)
splpri = deli$delta
#remove the constant vector
#if (i > 1) {
#splpri = splpri[,-1]
#}
mi = dim(splpri)[2]
m_acc = m_acc + mi
#spl = rbind(spl, spli)
splpr = cbind(splpr, splpri)
splpr_lst[[i]] = splpri
#ignore z for now
#mui = cbind(1, splpri) %*% c(ahat[1], ahat[which(varlist == i)+np])
#print (dim(splpri))
#print (length(ahat))
mui = splpri %*% ahat[which(varlist == i)]+np
mus[[i]] = muhat.fun(mui, fml = family$family)
}
m_acc = m_acc + m_acc_add
xmatpr = cbind(newv, splpr)
muhatpr = xmatpr %*% ahat
muhatpr = muhat.fun(muhatpr, fml = family$family)
if ("none" %in% interval) {
ans = list(fit = muhatpr, xmatpr = xmatpr, spls = splpr_lst, mus = mus)
#new: add prediction interval
} else if (interval == "confidence" | interval == "prediction") {
if (family$family == "gaussian") {
#bmat includes constant + zmat, not weighted
bmat = delta
np = object$d0
nloop = 100
#nsec will be too big for ordinal, ignore for now
#nsec = 2^m_acc
#print (dim(zmat))
if (is.null(prior.w)) {
prior.w = rep(1, n)
}
if (!all(prior.w == 1)) {
for (i in 1:n) {
bmat[,i] = bmat[,i] * sqrt(prior.w[i])
#spl[,i] = spl[,i] * sqrt(prior.w[i])
zmat[i,] = zmat[i,] * sqrt(prior.w[i])
vmat[i,] = vmat[i,] * sqrt(prior.w[i])
}
}
#spl is constrained splines: additive + wps
#spl = bmat[,-c(1:np),drop=FALSE]
#spl = bmat
#if (np >= 1) {
# spl = bmat[,-c(1:np),drop=FALSE]
#}
#muhat0 = (object$muhat)/sqrt(prior.w)
#muhat0: unweighted
muhat0 = object$muhat
sighat = (object$sig2hat)^(1/2)
nv = np
## estimate sector probabilties
#new: not use sector = 1:nsec*0; simulate for 1,000 times and record the faces used more than once
# if times / nloop < 1e-3, then delete
sector = NULL
times = NULL
df = NULL
faces = list()
#set.seed(1)
#first column shows sector; second column shows times
for (iloop in 1:nloop) {
ysim = muhat0 + rnorm(n)*sighat
ysim = ysim * sqrt(prior.w)
#ans = coneB(ysim, t(spl), zmat, face = face)
#cf = round(ans$coefs[(nv+1):(m_acc+nv)], 10)
qv0 = crossprod(bmat)
dv0 = crossprod(dmat)
#pen2 = find_pen(aims = edf, Q = qv0, B = bmat, D = dv0, PNT = TRUE, Y = ysim, D0 = dmat)
#nxi1 = x1_wps[[1]]
#nxi2 = x2_wps[[1]]
#mat = cbind(1, nxi1, nxi2, nxi1*nxi2)
#mu_para = mat %*% solve(t(mat) %*% mat) %*% t(mat) %*% ysim
#ssr = sum((ysim - mu_para)^2)
#sc = ssr / (n - ncol(mat))
#pen = max(1e-6, 1 * sc)
qv = qv0 + pen * dv0
cv = crossprod(bmat, ysim)
#amat = diag(m)
#amat[1, ] = 0
#ans = qprog(qv, cv, amat, 1:nrow(amat)*0, msg = FALSE)
#cf = round(ans$thetahat[(np+1):(m_acc+np)],10)
#sec = 1:m_acc*0
#sec[cf > 0] = 1
umat = chol(qv)
uinv = solve(umat)
atil = amat %*% uinv
cvec = t(uinv) %*% t(bmat) %*% ysim
ans = coneA(cvec, atil, msg = FALSE)
#phihat = ans$thetahat
#ahat = uinv %*% phihat
#new: use polar cone instead
face = ans$face
faces[[iloop]] = face
sec = 1:nrow(amat)*0
sec[face] = 1
#sec = 1:nrow(amat)*0+1
#cf = round(ans$thetahat,10)
#sec[cf > 0] = 0
r = makebin(sec) + 1
if (iloop == 1) {
df = rbind(df, c(r, 1))
sector = rbind(sector, sec)
} else {
if (r %in% df[,1]) {
ps = which(df[,1] %in% r)
df[ps,2] = df[ps,2] + 1
} else {
df = rbind(df, c(r, 1))
sector = rbind(sector, sec)
}
}
}
#remove times/sum(times) < 1e-3??
sm_id = which((df[,2]/nloop) < 1e-3)
if (any(sm_id)) {
df = df[-sm_id, ,drop=FALSE]
sector = sector[-sm_id, ,drop=FALSE]
}
#new:
ns = nrow(df)
bsec = df
bsec[,2] = bsec[,2] / sum(bsec[,2])
ord = order(bsec[,1])
bsec = bsec[ord, ,drop=FALSE]
sector = sector[ord, ,drop=FALSE]
### calculate the mixture cov(alpha) matrix:
#spl = t(spl)
#obs = 1:m_acc;oobs = 1:(m_acc+nv)
#acov = matrix(0, nrow = m_acc+nv, ncol = m_acc+nv)
#for (is in 1:ns) {
# if (bsec[is,2] > 0) {
# jvec = getbin(bsec[is,1], m_acc)
# if (sum(jvec) == 1) {
# smat = cbind(vmat, spl[,which(jvec==1),drop=FALSE])
# } else if (sum(jvec) == 0) {
# smat = vmat
# } else {
# smat = cbind(vmat, spl[,which(jvec==1),drop=FALSE])
# }
# acov1 = bsec[is,2]*solve(t(smat)%*%smat)
# acov2 = matrix(0,nrow=m_acc+nv,ncol=m_acc+nv)
# jobs = 1:(m_acc+nv)>0
# jm = 1:m_acc>0
# jm[obs[jvec==0]] = FALSE
# jobs[(nv+1):(m_acc+nv)] = jm
# nobs = oobs[jobs==TRUE]
# for (i in 1:sum(jobs)) {
# acov2[nobs[i],jobs] = acov1[i,]
# }
# acov = acov+acov2
# }
#}
#get covariance of phihat first
#umat = chol(qv)
#uinv = solve(umat)
#atil = amat %*% uinv
dp = -atil
for (i in 1:nrow(dp)) {
dpi = dp[i,,drop=F]
dpi = dpi/sqrt(tcrossprod(dpi)[1])
dp[i,]=dpi
}
dp = t(dp)
imat = diag(nrow(qv))
acov0 = matrix(0, nrow=nrow(qv), ncol=ncol(qv))
for (is in 1:ns) {
if (bsec[is,2] > 0) {
#jvec = getbin(bsec[is,1], ncol(dp))
jvec = sector[is, ]
if (sum(jvec) == 0) {
pmat_is = imat
} else {
smat = dp[,which(jvec==1),drop=FALSE]
#if (qr(smat)$rank < ncol(smat)) {
#save(smat,file='smat.Rda')
#fc = bsec[is,1]
#pj = bsec[is,2]
#save(jvec, file='jvec.Rda')
#save(fc, file='fc.Rda')
#save(pj, file='pj.Rda')
#save(faces, file='faces.Rda')
#save(bsec, file='bsec.Rda')
#smat = qr.Q(qr(smat), complete = TRUE)[, 1:(qr(smat)$rank), drop = FALSE]
#}
pmat_is_p = smat %*% solve(crossprod(smat), t(smat))
pmat_is = (imat-pmat_is_p)
}
acov0 = acov0 + bsec[is,2]*pmat_is%*%t(uinv)%*%qv0%*%uinv%*%pmat_is
}
}
acov = uinv%*%acov0%*%t(uinv)*sighat^2
#only xmatpr and splpr have interpolation points
#xmatpr = cbind(newv, splpr)
#muhatpr = xmatpr %*% object$coefs
#temp:
#muhatpr = xmatpr %*% object$coefs[1:ncol(xmatpr), ,drop=FALSE]
#new: C.I. level
mult = qnorm((1 - level)/2, lower.tail=FALSE)
#hl = 2*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
#hl = mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
#ans = list(fit = muhatpr, lower = muhatpr - hl, upper = muhatpr + hl)
}
if (interval == "confidence") {
hl = mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
}
if (interval == "prediction") {
hl = mult*sqrt(sighat^2+diag(xmatpr%*%acov%*%t(xmatpr)))
}
ans = list(fit = muhatpr, lower = muhatpr - hl, upper = muhatpr + hl, object = object, acov = acov, mult = mult, newz = newz)
}
class(ans) = "wpsp"
return (ans)
}
##############
#predict.trispl
#not finished: 1 pair + z only
##############
predict.trispl = function(object, newData, interval = c("none", "confidence", "prediction"), type = c("response", "link"), level = 0.95, ...) {
#new:
family = object$family
cicfamily = CicFamily(family)
muhat.fun = cicfamily$muhat.fun
if (!inherits(object, "trispl")) {
warning("calling predict.trispl(<fake-trispl-object>) ...")
}
if (missing(newData) || is.null(newData)) {
#if (missing(newData)) {
#etahat = object$etahat
#muhat = muhat.fun(etahat, fml = family$family)
#ans = list(fit = muhat, etahat = etahat, newbigmat = object$bigmat)
ans = list(fit = object$muhat)
return (ans)
}
if (!is.data.frame(newData)) {
#newData = as.data.frame(newData)
stop ("newData must be a data frame!")
}
#shapes = object$shapes
#new: used for ci
ahat = object$coefs
coef_tri = object$coef_tri
prior.w = object$prior.w
pen = object$pen
dmat = object$pmatc
amat = object$amatc
#delta includes everything
delta = object$dmatc
capk_lst = object$capk_lst
trimat_lst = object$trimat_lst
y = object$y
n = length(y)
#zmat does't include one vector in trispl
zmat = object$zmat
#vmat includes one vector and also conc, conv, shape=17
#vmat = object$vmat
tt = object$tms
Terms = delete.response(tt)
#model.frame will re-organize newData in the original order in formula
m = model.frame(Terms, newData)
newdata = m
#print (head(newdata))
#new:
newx0 = NULL; newxv = NULL; newx = NULL; newx_s = NULL; newu = NULL; newt = NULL; newz = NULL; newv = NULL
#newz = list();
ztb = object$ztb; zid1 = object$zid1; zid2 = object$zid2; iz = 1
rn = nrow(newdata)
#at least one pair in decrs and ks_wps
#decrs = object$decrs
#ks_wps = object$ks_wps
#sps_wps = list()
#dcss = list()
#x1_wps = x2_wps = list()
iwps = 0
#varlist = object$varlist_wps
#varlist = varlist[-1]
itri = 0
convexity = object$cvss
cvss = list()
x1_tris = x2_tris = list()
icvs = 0
varlist_tri = object$varlist_tri
ks_tri = object$knots_lst
#######################
#local helper function#
#######################
my_line = function(xp = NULL, y, x, end, start) {
slope = NULL
intercept = NULL
yp = NULL
slope = (y[end] - y[start]) / (x[end] - x[start])
intercept = y[end] - slope * x[end]
yp = intercept + slope * xp
ans = new.env()
ans$slope = slope
ans$intercept = intercept
ans$yp = yp
ans
}
#get shape attributes and elem out of newdata
for (i in 1:ncol(newdata)) {
if (is.null(attributes(newdata[,i])$shape)) {
if (is.factor(newdata[,i])) {
lvli = levels(newdata[,i])
ztbi = levels(ztb[[iz]])
newdatai = NULL
if (!any(lvli %in% ztbi)) {
stop ("new factor level must be among factor levels in the fit!")
} else {
id1 = which(ztbi %in% lvli)
klvls = length(ztbi)
if (klvls > 1) {
newimat = matrix(0, nrow = rn, ncol = klvls-1)
for (i1 in 1:rn) {
if (newdata[i1,i] != ztbi[1]) {
id_col = which(ztbi %in% newdata[i1,i]) - 1
newimat[i1,id_col] = 1
}
}
newdatai = newimat
}
}
} else {
newdatai = newdata[,i]
}
newz = cbind(newz, newdatai)
iz = iz + 1
} else if (length(attributes(newdata[,i])$decreasing)>1) {
iwps = iwps + 1
#sps_wp = attributes(newdata[, i])$space
#sps_wps[[iwps]] = sps_wp
dcs = attributes(newdata[, i])$decreasing
dcss[[iwps]] = dcs
x1_wp = (newdata[, i])[, 1]
x1_wps[[iwps]] = x1_wp
x2_wp = (newdata[, i])[, 2]
x2_wps[[iwps]] = x2_wp
} else if (is.numeric(attributes(newdata[,i])$shape)) {
newx0 = cbind(newx0, newdata[,i])
if ((attributes(newdata[,i])$shape > 2 & attributes(newdata[,i])$shape < 5) | (attributes(newdata[,i])$shape > 10 & attributes(newdata[,i])$shape < 13)) {
newxv = cbind(newxv, newdata[,i])
}
} else if (is.character(attributes(newdata[,i])$shape) && (attributes(newdata[,i])$categ == "tri")) {
itri = itri + 1
cvs = attributes(newdata[,i])$cvs
cvss[[itri]] = cvs
x1_tri = (newdata[,i])[, 1]
x1_tris[[itri]] = x1_tri
x2_tri = (newdata[,i])[, 2]
x2_tris[[itri]] = x2_tri
}
}
#conc, or conv + shape=17 + other shapes + zmat (including one) + wps
m_acc_add = 0
spl_add = splpr_add = NULL
if (!is.null(newx0)) {
shapes = object$shapes
#put s=17 first as in wps.fit
if (any(shapes == 17)) {
kshapes = length(shapes)
obs = 1:kshapes
idx_s = obs[which(shapes == 17)]; idx = obs[which(shapes != 17)]
newx1 = newx0
shapes0 = 1:kshapes*0
newx1[,1:length(idx_s)] = newx0[,idx_s]
shapes0[1:length(idx_s)] = shapes[idx_s]
if (length(idx) > 0) {
newx1[,(1 + length(idx_s)):kshapes] = newx0[,idx]
shapes0[(1 + length(idx_s)):kshapes] = shapes[idx]
}
newx0 = newx1; shapes = shapes0
}
nc = ncol(newx0)
ms = object$ms
knotsuse_add = object$knotsuse_add
#17 is first
xmat0_add = object$xmat0_add
for (i in 1:nc) {
msi = ms[[i]]
shpi = shapes[i]
ki = knotsuse_add[[i]]
xi = xmat0_add[,i]
xipr = newx0[,i]
if (any(xipr > max(ki)) | any(xipr < min(ki))) {
stop ("No extrapolation is allowed in cgam prediction!")
}
#if (shpi >= 9) {
dpri = makedelta(xipr, shpi, knots = ki, suppre = TRUE, interp = TRUE)
splpri = dpri$amat
if (shpi > 10 & shpi < 13) {
xs = sort(xi)
ord = order(xi)
#nx = length(xi)
#nx is n
obs = 1:n
nr = nrow(splpri)
#nc = length(xipr)
#rn is the length of a new vector
ms2 = matrix(0, nrow = nr, ncol = rn)
for (i1 in 1:rn) {
for (i2 in 1:nr) {
ms2[i2, i1] = my_line(xp = xipr[i1], y = msi[i2, ][ord], x = xs, end = n, start = 1)$yp
}
}
splpri = splpri - ms2
} else {
splpri = splpri - msi
}
#} else {splpri = pred_del(xi, shpi, xipr, msi)}
mi = dim(splpri)[1]
m_acc_add = m_acc_add + mi
#splpr_add = rbind(splpr_add, splpri)
splpr_add = cbind(splpr_add, t(splpri))
}
}
#temp
#newv = cbind(1:rn*0 + 1, newz, newxv)
#for tri.fit, don't include the constant vector
#newv = cbind(newxv, splpr_add, 1:rn*0 + 1, newz)
#newv = cbind(newxv, splpr_add, newz)
#np = ncol(newv)
#m_acc = 0
splpr = NULL
splpr_lst = mus = list()
#loop through total number of wps pairs
for (i in 1:itri) {
k1 = ks_tri[[i]][,1]
m1 = length(k1)
k2 = ks_tri[[i]][,2]
m2 = length(k2)
nxi1 = x1_tris[[i]]
nxi2 = x2_tris[[i]]
trimat = trimat_lst[[i]]
capk = capk_lst[[i]]
if (any(nxi1 > max(k1)) | any(nxi1 < min(k1)) | any(nxi2 > max(k2)) | any(nxi2 < min(k2))) {
stop ("No extrapolation is allowed in cgam prediction!")
}
#sps_wp = sps_wps[[i]]
#space, m1_0, m2_0 don't matter
deli = makedelta_tri(nxi1, nxi2, m1, m2, k1, k2, trimat, capk, space = c("E",
"E"), cvs = convexity[[i]], interp = TRUE)
splpri = deli
#mi = dim(splpri)[2]
#m_acc = m_acc + mi
#spl = rbind(spl, spli)
splpr = cbind(splpr, splpri)
splpr_lst[[i]] = splpri
#ignore z for now
#mui = cbind(1, splpri) %*% c(ahat[1], ahat[which(varlist == i)+np])
#mus[[i]] = muhat.fun(mui, fml = family$family)
}
# m_acc = m_acc + m_acc_add
#in tri.fit: additive + trispl + z + wps (ignore)
xmatpr = cbind(splpr_add, splpr, newz)
muhatpr = xmatpr %*% ahat
muhatpr = muhat.fun(muhatpr, fml = family$family)
if ("none" %in% interval) {
ans = list(fit = muhatpr, xmatpr = xmatpr, spls = splpr_lst, mus = mus, object = object)
#new: add prediction interval
} else if (interval == "confidence" | interval == "prediction") {
if (family$family == "gaussian") {
#bmat includes constant + zmat, not weighted
bmat = delta
np = object$d0
nloop = 500
#nsec will be too big for ordinal, ignore for now
#nsec = 2^m_acc
#print (dim(zmat))
if (is.null(prior.w)) {
prior.w = rep(1, n)
}
if (!all(prior.w == 1)) {
for (i in 1:n) {
bmat[,i] = bmat[,i] * sqrt(prior.w[i])
#spl[,i] = spl[,i] * sqrt(prior.w[i])
#zmat[i,] = zmat[i,] * sqrt(prior.w[i])
#vmat[i,] = vmat[i,] * sqrt(prior.w[i])
}
}
#spl is constrained splines: additive + wps
#spl = bmat[,-c(1:np),drop=FALSE]
#muhat0 = (object$muhat)/sqrt(prior.w)
#muhat0: unweighted
muhat0 = object$muhat
sighat = (object$sig2hat)^(1/2)
#no use:
nv = np
## estimate sector probabilties
#new: not use sector = 1:nsec*0; simulate for 1,000 times and record the faces used more than once
# if times / nloop < 1e-3, then delete
sector = NULL
times = NULL
df = NULL
#faces = list()
#set.seed(1)
#first column shows sector; second column shows times
for (iloop in 1:nloop) {
#print (iloop)
ysim = muhat0 + rnorm(n)*sighat
ysim = ysim * sqrt(prior.w)
#ans = coneB(ysim, t(spl), zmat, face = face)
#cf = round(ans$coefs[(nv+1):(m_acc+nv)], 10)
qv0 = crossprod(bmat)
dv0 = crossprod(dmat)
#pen2 = find_pen(aims = edf, Q = qv0, B = bmat, D = dv0, PNT = TRUE, Y = ysim, D0 = dmat)
qv = qv0 + pen * dv0
cv = crossprod(bmat, ysim)
umat = chol(qv)
uinv = solve(umat)
atil = amat %*% uinv
cvec = t(uinv) %*% t(bmat) %*% ysim
ans = coneA(cvec, atil, msg = FALSE)
#phihat = ans$thetahat
#ahat = uinv %*% phihat
#new: use polar cone instead
face = ans$face
#faces[[iloop]] = face
sec = 1:nrow(amat)*0
sec[face] = 1
#sec = 1:nrow(amat)*0+1
#cf = round(ans$thetahat,10)
#sec[cf > 0] = 0
r = makebin(sec) + 1
if (iloop == 1) {
df = rbind(df, c(r, 1))
sector = rbind(sector, sec)
} else {
if (r %in% df[,1]) {
ps = which(df[,1] %in% r)
df[ps,2] = df[ps,2] + 1
} else {
df = rbind(df, c(r, 1))
sector = rbind(sector, sec)
}
}
}
#remove times/sum(times) < 1e-3??
sm_id = which((df[,2]/nloop) < 1e-3)
if (any(sm_id)) {
df = df[-sm_id, ,drop=FALSE]
sector = sector[-sm_id, ,drop=FALSE]
}
#new:
ns = nrow(df)
bsec = df
bsec[,2] = bsec[,2] / sum(bsec[,2])
ord = order(bsec[,1])
bsec = bsec[ord, ,drop=FALSE]
sector = sector[ord, ,drop=FALSE]
### calculate the mixture cov(alpha) matrix:
dp = -atil
for (i in 1:nrow(dp)) {
dpi = dp[i,,drop=F]
dpi = dpi/sqrt(tcrossprod(dpi)[1])
dp[i,]=dpi
}
dp = t(dp)
imat = diag(nrow(qv))
acov0 = matrix(0, nrow=nrow(qv), ncol=ncol(qv))
for (is in 1:ns) {
if (bsec[is,2] > 0) {
#jvec = getbin(bsec[is,1], ncol(dp))
jvec = sector[is, ]
if (sum(jvec) == 0) {
pmat_is = imat
} else {
smat = dp[,which(jvec==1),drop=FALSE]
pmat_is_p = smat %*% solve(crossprod(smat), t(smat))
pmat_is = (imat-pmat_is_p)
}
acov0 = acov0 + bsec[is,2]*pmat_is%*%t(uinv)%*%qv0%*%uinv%*%pmat_is
}
}
acov = uinv%*%acov0%*%t(uinv)*sighat^2
#only xmatpr and splpr have interpolation points
#xmatpr = cbind(newv, splpr)
#muhatpr = xmatpr %*% object$coefs
#temp:
#muhatpr = xmatpr %*% object$coefs[1:ncol(xmatpr), ,drop=FALSE]
#new: C.I. level
mult = qnorm((1 - level)/2, lower.tail=FALSE)
#hl = 2*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
#hl = mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
#ans = list(fit = muhatpr, lower = muhatpr - hl, upper = muhatpr + hl)
}
if (interval == "confidence") {
hl = mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
}
if (interval == "prediction") {
hl = mult*sqrt(sighat^2+diag(xmatpr%*%acov%*%t(xmatpr)))
}
ans = list(fit = muhatpr, lower = muhatpr - hl, upper = muhatpr + hl, object = object, acov = acov, mult = mult, newz = newz)
}
class(ans) = "trisplp"
return (ans)
}
###
#trispl makedelta
###
makedelta_tri = function(x1, x2, m1 = 0, m2 = 0, k1 = NULL, k2 = NULL, trimat = NULL, capk = NULL, space = c("E",
"E"), cvs = c(TRUE, TRUE), interp = TRUE) {
n = length(x1)
xmat = cbind(x1, x2)
delta = NULL
#### now determine which triangle contains each point
xtri = 1:n*0;still = 1:n>0
ntri = (m2 - 1) * (2 * m1 - 1)
knots = cbind(k1, k2)
for (j in 1:ntri) {
#print (j)
for (i in 1:n) {
if (still[i]) {
if (intri(xmat[i,],knots[trimat[j,1],],knots[trimat[j,2],],knots[trimat[j,3],])) {
still[i] = FALSE
xtri[i] = j
}
}
}
}
### make the design matrix
dmat = matrix(0, nrow = n, ncol = capk)
bmat = matrix(1, nrow = 3, ncol = 3)
a = 1:3
for (i in 1:n) {
for (j in 1:3) {
#print (c(i,j))
a[j] = trimat[xtri[i],j]
bmat[j,2] = knots[a[j],1]
bmat[j,3] = knots[a[j],2]
}
binv = solve(bmat)
for (j in 1:3) {
dmat[i,a[j]] = binv[1,j] + binv[2,j]*x1[i] + binv[3,j]*x2[i]
}
}
delta = cbind(delta, dmat)
return (delta)
}
###########################################
#create a 3D plot for a cgam or wps object#
###########################################
plotpersp <- function(object,...) {
UseMethod("plotpersp", object)
}
# plotpersp <- function(object, x1 = NULL, x2 = NULL,...) {
# x1nm <- deparse(substitute(x1))
# x2nm <- deparse(substitute(x2))
# if (inherits(object, "cgamp")) {
# xnms_add <- object$object$xnms_add
# } else {
# xnms_add <- object$xnms_add
# }
# if (inherits(object, "wpsp")) {
# xnms_wp <- object$object$xnms_wp
# } else {
# xnms_wp <- object$xnms_wp
# }
# if (inherits(object, "trisplp")) {
# xnms_tri <- object$object$xnms_tri
# } else {
# xnms_tri <- object$xnms_tri
# }
# is_add <- all(c(any(grepl(x1nm, xnms_add, fixed = TRUE)), any(grepl(x2nm, xnms_add, fixed = TRUE))))
# #print (is_add)
# is_wps <- all(c(any(grepl(x1nm, xnms_wp, fixed = TRUE)), any(grepl(x2nm, xnms_wp, fixed = TRUE))))
# #print (is_wps)
# is_tri <- all(c(any(grepl(x1nm, xnms_tri, fixed = TRUE)), any(grepl(x2nm, xnms_tri, fixed = TRUE))))
# #print (is_tri)
# if (missing(x1) | missing(x2)) {
# UseMethod("plotpersp")
# } else {
# cs = class(object)
# if (length(cs) == 1 & is.null(x1nm) & is.null(x2nm)) {
# UseMethod("plotpersp")
# } else {
# if (is_wps) {
# #print (x1)
# #print (x2nm)
# if (inherits(object, "wpsp")) {
# #print (x1nm)
# #print (x2nm)
# #print (head(x1))
# plotpersp.wpsp(object, x1, x2, x1nm, x2nm,...)
# } else {
# plotpersp.wps(object, x1, x2, x1nm, x2nm,...)
# }
# } else if (is_add) {
# if (inherits(object, "cgamp")){
# plotpersp.cgamp(object, x1, x2, x1nm, x2nm,...)
# } else {
# plotpersp.cgam(object, x1, x2, x1nm, x2nm,...)
# }
# } else if (is_tri) {
# if (inherits(object, "trisplp")) {
# plotpersp.trisplp(object, x1, x2, x1nm, x2nm,...)
# } else {
# plotpersp.trispl(object, x1, x2, x1nm, x2nm,...)
# }
# } else {
# stop ("Nonparametric components must be from the same class!")
# }
# }
# }
# }
################
#plotpersp.cgam#
################
#new: control function for aesthetics
plotpersp_control <- function(surface = "mu", x1nm = NULL, x2nm = NULL, categ = NULL,
col = NULL, random = FALSE, ngrid = 12,
xlim = NULL, ylim = NULL, zlim = NULL,
xlab = NULL, ylab = NULL, zlab = NULL,
th = NULL, ltheta = NULL, main = NULL,
sub = NULL, ticktype = "simple") {
list(x1nm = x1nm, x2nm = x2nm, surface = surface, categ = categ,
col = col, random = random, ngrid = ngrid,
xlim = xlim, ylim = ylim, zlim = zlim,
xlab = xlab, ylab = ylab, zlab = zlab,
th = th, ltheta = ltheta, main = main,
sub = sub,
ticktype = ticktype)
}
plotpersp.cgam <- function(object, x1 = NULL, x2 = NULL, control = plotpersp_control(),...) {
if (!inherits(object, "cgam")) {
warning("calling plotpersp(<fake-cgam-object>) ...")
}
#new: unpack aesthetics
defaults <- plotpersp_control()
control <- modifyList(defaults, control)
x1nm <- control$x1nm
x2nm <- control$x2nm
surface <- control$surface
categ <- control$categ
col <- control$col
random <- control$random
ngrid <- control$ngrid
xlim <- control$xlim
ylim <- control$ylim
zlim <- control$zlim
xlab <- control$xlab
ylab <- control$ylab
zlab <- control$zlab
th <- control$th
ltheta <- control$ltheta
main <- control$main
ticktype <- control$ticktype
sub <- control$sub
# c(x1nm, x2nm, surface, categ, col, random, ngrid, xlim, ylim, zlim,
# xlab, ylab, zlab, th, ltheta, main, ticktype, sub) %<-% control
#
#new: capture x1nm and x2nm cleanly
x1nm <- x1nm %||% if (!is.null(x1)) {
if (is.character(x1)) x1 else deparse(substitute(x1))
}
x2nm <- x2nm %||% if (!is.null(x2)) {
if (is.character(x2)) x2 else deparse(substitute(x2))
}
xnms <- object$xnms_add
xmat <- object$xmat_add
#if (x1nm == "NULL" | x2nm == "NULL") {
if (is.null(x1nm) || is.null(x2nm)) {
if (length(xnms) >= 2) {
x1nm <- xnms[1]
x2nm <- xnms[2]
x1id <- 1
x2id <- 2
x1 <- xmat[, 1]
x2 <- xmat[, 2]
} else {stop ("Number of non-parametric predictors must >= 2!")}
}
ynm <- object$ynm
#xmat <- object$xmat
#print (dim(xmat))
is_fac <- object$is_fac
is_param <- object$is_param
family <- object$family
fml <- family$family
cicfamily <- CicFamily(family)
muhat.fun <- cicfamily$muhat.fun
znms <- object$znms
kznms <- length(znms)
if (!is.null(categ)) {
if (!is.character(categ)) {
warning("categ must be a character argument!")
} else if (!any(znms == categ)) {
#in.or.out case
#if (!is.null(attr(object, "sub"))) {
# if (!is.null(categ)) {
# categ = paste("factor(", categ, ")", sep = "")
# }
#} else {
# warning(paste(categ, "is not an exact character name defined in the cgam fit!"))
# categ = NULL
#}
if (any(grepl(categ, znms))) {
id = which(grepl(categ, znms))
znmi = znms[id]
if (grepl("as.factor", znmi)) {
categ = paste("as.factor(", categ, ")", sep = "")
} else if (grepl("factor", znmi)) {
categ = paste("factor(", categ, ")", sep = "")
} else {print(paste(categ, "is not an exact character name defined in the cgam fit!"))}
} else {print(paste(categ, "is not an exact character name defined in the cgam fit!"))}
} else {
obsz = 1:kznms
zid = obsz[znms == categ]
#linear term:
if (!(is_fac[zid])) {
categ = NULL
}
}
}
shapes <- object$shapes
#new:
#zid1 = object$zid1 - 1 - length(shapes)
#zid2 = object$zid2 - 1 - length(shapes)
zid1 <- object$zid1
zid2 <- object$zid2
kznms <- length(znms)
zmat <- object$zmat
if (any(class(object) == "wps")) {
d0 <- object$d0
np_add <- object$np_add
p <- d0 - np_add
pb <- object$pb
zmat <- zmat[, (pb+1):(pb+p), drop = FALSE]
#remove the one
zmat <- zmat[, -1, drop = FALSE]
#print (head(zmat))
}
#zcoefs = object$zcoefs
#new: exclude the coef for the one vector
#temp:trispl not include one
if (fml != "ordered" & all(class(object) != "trispl")) {
zcoefs <- object$zcoefs[-1]
} else {
zcoefs <- object$zcoefs
}
#print (zcoefs)
#xmatnms <- object$xmatnms
knms <- length(xnms)
obs <- 1:knms
#new: remove data argument; very rare to use it anyway
#new: x1 and x2 are in .Globe, not in formula
if (all(xnms != x1nm)) {
if (length(x1) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x1!")
}
bool <- apply(xmat, 2, function(x) all(x1 == x))
if (any(bool)) {
x1id <- obs[bool]
#change x1nm to be the one in formula
x1nm <- xnms[bool]
} else {
stop (paste(paste("'", x1nm, "'", sep = ''), "is not a predictor defined in the cgam fit!"))
}
} else {
x1id <- obs[xnms == x1nm]
}
if (all(xnms != x2nm)) {
if (length(x2) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x2!")
}
bool <- apply(xmat, 2, function(x) all(x2 == x))
if (any(bool)) {
x2id <- obs[bool]
x2nm <- xnms[bool]
} else {
stop (paste(paste("'", x2nm, "'", sep = ''), "is not a predictor defined in the cgam fit!"))
}
} else {
x2id <- obs[xnms == x2nm]
}
#}
#xmat is not the one in fit
#print (length(x1))
#print (length(x2))
#xm <- cbind(x1, x2)
xm <- xmat[, c(x1id, x2id)]
#print (all(xm == cbind(x1, x2)))
#print (head(cbind(x1, x2)))
#new:
xlim <- range(xm[,1])
ylim <- range(xm[,2])
x_grid <- ngrid
y_grid <- ngrid
x1g <- 0:x_grid / x_grid * .95 * (max(xm[,1]) - min(xm[,1])) + min(xm[,1]) + .025 * (max(xm[,1]) - min(xm[,1]))
n1 <- length(x1g)
x2g <- 0:y_grid / y_grid * .95 * (max(xm[,2]) - min(xm[,2])) + min(xm[,2]) + .025 * (max(xm[,2]) - min(xm[,2]))
n2 <- length(x2g)
xgmat <- matrix(nrow = n1, ncol = n2)
eta0 <- object$coefs[1]
thvecs <- object$etacomps
#print ('thvecs')
for (i2 in 1:n2) {
for (i1 in 1:n1) {
x1a <- max(xm[xm[,1] <= x1g[i1], 1])
x1b <- min(xm[xm[,1] > x1g[i1], 1])
v1a <- min(thvecs[x1id, xm[,1] == x1a])
v1b <- min(thvecs[x1id, xm[,1] == x1b])
alp <- (x1g[i1] - x1a) / (x1b - x1a)
th1add <- (1 - alp) * v1a + alp * v1b
x2a <- max(xm[xm[,2] <= x2g[i2],2])
x2b <- min(xm[xm[,2] > x2g[i2],2])
v2a <- min(thvecs[x2id, xm[,2] == x2a])
v2b <- min(thvecs[x2id, xm[,2] == x2b])
alp <- (x2g[i2] - x2a) / (x2b - x2a)
th2add <- (1 - alp) * v2a + alp * v2b
xgmat[i1,i2] <- eta0 + th1add + th2add
}
}
x3_add <- 0
if (knms >= 3) {
x3id <- obs[-c(x1id, x2id)]
kx3 <- length(x3id)
for (i in 1:kx3) {
x3i <- xmat[, x3id[i]]
x3i_use <- max(x3i[x3i <= median(x3i)])
x3i_add <- min(thvecs[x3id[i], x3i == x3i_use])
x3_add <- x3_add + x3i_add
}
}
if (surface == "eta") {
xgmat <- xgmat + as.numeric(x3_add)
}
if (is.null(categ) & surface == "mu") {
z_add <- 0
if (!is.null(znms)) {
kzids <- length(zid1)
for (i in 1:kzids) {
pos1 <- zid1[i]; pos2 <- zid2[i]
zi <- zmat[, pos1:pos2, drop = FALSE]
zcoefsi <- zcoefs[pos1:pos2]
for (j in 1:ncol(zi)){
uzij <- unique(zi[,j])
kuzij <- length(uzij)
nmodej <- sum(zi[,j] == uzij[1])
zij_mode <- uzij[1]
for (u in 2:kuzij) {
if (sum(zi[,j] == uzij[u]) > nmodej) {
zij_mode <- uzij[u]
nmodej <- sum(zi[,j] == uzij[u])
}
}
obsuzij <- 1:length(uzij)
uzhatij <- uzij * zcoefsi[j]
zij_add <- uzhatij[obsuzij[uzij == zij_mode]]
z_add <- z_add + zij_add
}
}
}
xgmat <- xgmat + as.numeric(x3_add) + as.numeric(z_add)
#xgmat <- muhat.fun(xgmat, fml = fml)
if (fml != "gaussian" & fml != "ordered") {
for (i2 in 1:n2) {
for (i1 in 1:n1) {
xgmat[i1, i2] <- muhat.fun(xgmat[i1, i2], fml = fml)
}
}
}
} else if (!is.null(categ) & surface == "mu"){
xgmats <- list()
mins <- NULL; maxs <- NULL
obsz <- 1:kznms
zid <- obsz[znms == categ]
#print (class(znms[znms == categ]))
pos1 <- zid1[zid]; pos2 <- zid2[zid]
#print (pos1)
#print (pos2)
#zi <- zmat[, pos1:pos2, drop = FALSE]
#z_add <- 1:nrow(zi)*0
#zcoefsi <- zcoefs[pos1:pos2]
#print (zcoefsi)
zcoefsi = zcoefs[pos1:pos2]
#include the base level
zcoefsi = c(0, zcoefsi)
z_add = sort(zcoefsi)
kz_add <- length(z_add)
#new: plot the smallest one first:
#z_add <- z_add[order(z_add)]
#print (z_add)
for (iz in 1:kz_add) {
xgmats[[iz]] <- xgmat + as.numeric(x3_add) + z_add[iz]
#mins <- c(mins, min(xgmats[[iz]]))
#maxs <- c(maxs, max(xgmats[[iz]]))
if (fml != "gaussian" & fml != "ordered") {
for (i2 in 1:n2) {
for (i1 in 1:n1) {
xgmats[[iz]][i1, i2] <- muhat.fun(xgmats[[iz]][i1, i2], fml = fml)
}
}
}
#xgmat[[iz]] <- muhat.fun(xgmat[[iz]], fml = fml)
mins <- c(mins, min(xgmats[[iz]]))
maxs <- c(maxs, max(xgmats[[iz]]))
}
}
if (is.null(xlab)) {
#xlab = deparse(x1nm)
xlab <- x1nm
}
if (is.null(ylab)) {
#ylab = deparse(x2nm)
ylab <- x2nm
}
if (is.null(zlab)) {
if (surface == "mu") {
if (fml == "binomial") {
zlab <- paste("Pr(", ynm, ")")
} else if (fml == "poisson" | fml == "gaussian" | fml == "Gamma") {
zlab <- paste("Est mean of", ynm)
}
}
if (surface == "eta") {
if (fml == "binomial") {
zlab <- paste("Est log odds ratio of", ynm)
} else if (fml == "poisson" | fml == "Gamma") {
zlab <- paste("Est log mean of", ynm)
} else if (fml == "gaussian") {
zlab <- paste("Est mean of", ynm)
}
}
}
#if (is.null(zlim)) {
# zlim <- range(xgmat, na.rm = TRUE)
#}
palette <- c("peachpuff", "lightblue", "limegreen", "grey", "wheat", "yellowgreen", "seagreen1", "palegreen", "azure", "whitesmoke")
if (!is.null(categ) & surface == "mu") {
#palette = c("peachpuff", "lightblue", "grey", "wheat", "yellowgreen", "plum", "limegreen", "paleturqoise", "azure", "whitesmoke")
kxgm <- length(xgmats)
if (is.null(col)) {
#if (kxgm == 2) {
# col = c("peachpuff", "lightblue")
#} else if (kxgm == 3) {
# col = c("peachpuff", "lightblue", "grey")
#} else if (kxgm > 3 & kxgm < 11) {
# col = sample(palette, replace = FALSE)
if (random) {
col <- topo.colors(kxgm)
#col <- sample(palette, size = kxgm, replace = FALSE)
#print (col)
} else {
#print (kxgm)
if (kxgm > 1 & kxgm < 11) {
col <- palette[1:kxgm]
} else {
#new: use rainbow
col <- topo.colors(kxgm)
}
}
} else {
col0 <- col
if (col0 == "heat" | col0 == "topo" | col0 == "terrain" | col0 == "cm") {
#col0 <- col
ncol <- 100
facets <- facetcols <- list()
col <- list()
for (i in 1:kxgm) {
nr <- nrow(xgmats[[i]])
nc <- ncol(xgmats[[i]])
facets[[i]] <- (xgmats[[i]])[-1,-1] + (xgmats[[i]])[-1,-nc] + (xgmats[[i]])[-nr,-1] + (xgmats[[i]])[-nr,-nc]
facetcols[[i]] <- cut(facets[[i]], ncol)
#print (head(facetcols[[i]]))
if (col0 == "heat") {
col[[i]] <- (heat.colors(ncol))[facetcols[[i]]]
#print (head(col[[i]]))
} else if (col0 == "topo") {
col[[i]] <- (topo.colors(ncol))[facetcols[[i]]]
} else if (col0 == "terrain") {
col[[i]] <- (terrain.colors(ncol))[facetcols[[i]]]
} else {
col[[i]] <- (cm.colors(ncol))[facetcols[[i]]]
}
}
} else if (length(col0) < kxgm) {
rem <- kxgm - length(col0)
nrem <- length(rem)
rem_col <- palette[1:nrem]
col <- c(col0, rem_col)
} else if (length(col0) > kxgm) {
col <- col0[1:kxgm]
#print (paste("The first", kxgm, "colors are used!"))
}
if (random) {
print ("User defined colors are used!")
}
}
#print (col[[1]][1:10])
#print (kxgm)
#new: set th for decr or incr
decrs = shapes[c(x1id, x2id)] %in% c(2, 6, 8, 10, 15, 16)
incrs = shapes[c(x1id, x2id)] %in% c(1, 5, 7, 9, 13, 14)
if (is.null(th) | !is.numeric(th)) {
ang = NULL
if (incrs[1] & incrs[2]) {
if (is.null(ang)) {
ang = -40
}
} else if (decrs[1] & incrs[2]) {
if (is.null(ang)) {
ang = 40
}
} else if (incrs[1] & decrs[2]) {
if (is.null(ang)) {
ang = 240
}
} else if (decrs[1] & decrs[2]) {
if (is.null(ang)) {
ang = 140
}
} else {ang = -37}
} else {ang = th}
if (is.null(ltheta) | !is.numeric(ltheta)) {
ltheta <- -135
}
#print (col[[1]][1:10])
for (i in 1:kxgm) {
#print (col[i])
#i = 1
#print (i)
#print (length(col))
xgmat <- xgmats[[i]]
#if (is.null(th) | !is.numeric(th)) {
# th <- -40
#}
#if (is.null(ltheta) | !is.numeric(ltheta)) {
# ltheta <- -135
#}
#persp(x1g, x2g, xgmat, xlim = xlim, ylim = ylim, theta = th)
#new: avoid thick labs
box = TRUE
axes = TRUE
if (i > 1) {
xlab = ylab = zlab = " "
box = FALSE
axes = FALSE
}
#print (length(col))
if (is.list(col)) {
coli = unlist(col[[i]])
#print (head(coli))
} else {coli = col[i]}
if (is.null(zlim)) {
lwr = min(mins)
upp = max(maxs)
zlim0 = c(lwr - (upp-lwr)/3, upp + (upp-lwr)/3)
} else {
zlim0 = zlim
}
persp(x1g, x2g, xgmat, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = xlab, ylab = ylab, zlab = zlab,
col = coli, main = main, theta = ang, ltheta = ltheta, ticktype = ticktype, box = box, axes = axes,...)
par(new = TRUE)
}
par(new = FALSE)
} else {
if (is.null(col)) {
if (random) {
col <- sample(palette, size = 1, replace = FALSE)
} else {
#col <- "white"
#col <- color[facetcol]
nr <- nrow(xgmat)
nc <- ncol(xgmat)
ncol <- 100
facet <- xgmat[-1,-1] + xgmat[-1,-nc] + xgmat[-nr,-1] + xgmat[-nr,-nc]
#print (facet)
facetcol <- cut(facet, ncol)
col <- heat.colors(ncol)[facetcol]
}
} else {
#if (length(col) > 1) {
# col <- col[1]
# print ("The first color is used!")
# col <- heat.colors(x_grid*y_grid)
#}
if (col == "heat" | col == "topo" | col == "terrain" | col == "cm") {
nr <- nrow(xgmat)
nc <- ncol(xgmat)
ncol <- 100
facet <- xgmat[-1,-1] + xgmat[-1,-nc] + xgmat[-nr,-1] + xgmat[-nr,-nc]
facetcol <- cut(facet, ncol)
if (col == "heat") {
col <- heat.colors(ncol)[facetcol]
} else if (col == "topo") {
col <- topo.colors(ncol)[facetcol]
} else if (col == "terrain") {
col <- terrain.colors(ncol)[facetcol]
} else {
col <- cm.colors(ncol)[facetcol]
}
}
if (random) {
print ("User defined color is used!")
}
}
#if (is.null(th) | !is.numeric(th)) {
# th <- -40
#}
#if (is.null(ltheta) | !is.numeric(ltheta)) {
# ltheta <- -135
#}
#new: set th for decr or incr
decrs = shapes[c(x1id, x2id)] %in% c(2, 6, 8, 10, 15, 16)
incrs = shapes[c(x1id, x2id)] %in% c(1, 5, 7, 9, 13, 14)
if (is.null(th) | !is.numeric(th)) {
ang = NULL
if (incrs[1] & incrs[2]) {
if (is.null(ang)) {
ang = -40
}
} else if (decrs[1] & incrs[2]) {
if (is.null(ang)) {
ang = 40
}
} else if (incrs[1] & decrs[2]) {
if (is.null(ang)) {
ang = 240
}
} else if (decrs[1] & decrs[2]) {
if (is.null(ang)) {
ang = 140
}
} else {ang = -37}
} else {ang = th}
if (is.null(ltheta) | !is.numeric(ltheta)) {
ltheta <- -135
}
if (is.null(zlim)) {
lwr = min(xgmat)
upp = max(xgmat)
zlim0 = c(lwr - (upp-lwr)/3, upp + (upp-lwr)/3)
} else {
zlim0 = zlim
}
persp(x1g, x2g, xgmat, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = xlab, ylab = ylab, zlab = zlab, col = col, main = main, theta = ang, ltheta = ltheta, ticktype = ticktype,...)
rslt = list(zlim = zlim0, xlab = xlab, ylab = ylab, zlab = zlab, theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype, z_add = z_add, x3_add = x3_add)
invisible(rslt)
}
#print (col)
}
#############################################################
#apply plotpersp on a predict.cgam or predict.cgamm object
#############################################################
plotpersp.cgamp = function(object, x1=NULL, x2=NULL, x1nm=NULL, x2nm=NULL,
data=NULL, up = TRUE, main=NULL, cex.main=.8,
xlab = NULL, ylab = NULL, zlab = NULL, zlim = NULL,
th = NULL, ltheta = NULL, ticktype = "detailed",...) {
#obj is prediction for cgam or cgamm
if (!inherits(object, "cgamp")) {
warning("calling plotpersp(<fake-cgam-prediction-object>) ...")
}
t_col = function(color, percent = 50, name = NULL) {
rgb.val <- col2rgb(color)
## Make new color using input color as base and alpha set by transparency
t.col <- rgb(rgb.val[1], rgb.val[2], rgb.val[3],
maxColorValue = 255,
alpha = (100-percent)*255/100,
names = name)
## Save the color
invisible(t.col)
}
if (up) {
mycol = t_col("green", perc = 90, name = "lt.green")
} else {
mycol = t_col("pink", perc = 80, name = "lt.pink")
}
acov = object$acov
mult = object$mult
#obj is the cgam or cgamm fit
obj = object$object
#ah = obj$coef_wp
xnms = obj$xnms_add
xmat = obj$xmat_add
bigmat = obj$bigmat
#decrs = obj$decrs
#if (x1nm == "NULL" | x2nm == "NULL") {
if (is.null(x1nm) | is.null(x2nm)) {
if (length(xnms) >= 2) {
x1nm = xnms[1]
x2nm = xnms[2]
x1id = 1
x2id = 2
x1 = xmat[, 1]
x2 = xmat[, 2]
} else {stop ("Number of non-parametric predictors must >= 2!")}
}
#labels = obj$labels
#labels = labels[which(grepl("warp", labels, fixed = TRUE))]
#is_fac = obj$is_fac
ynm = obj$ynm
#varlist = obj$varlist_wps
#varlist = varlist[-1]
kts = obj$knots
np = obj$d0
knms = length(xnms)
obs = 1:knms
if (!is.null(data)) {
if (!is.data.frame(data)) {
stop ("User need to make the data argument a data frame with names for each variable!")
}
datnms <- names(data)
if (!any(datnms == x1nm) | !any(datnms == x2nm)) {
stop ("Check the accuracy of the names of x1 and x2!")
}
x1 <- data[ ,which(datnms == x1nm)]
x2 <- data[ ,which(datnms == x2nm)]
if (length(x1) != nrow(xmat)) {
warning ("Number of observations in the data set is not the same as the number of elements in x1!")
}
x1id <- obs[xnms == x1nm]
if (length(x2) != nrow(xmat)) {
warning ("Number of observations in the data set is not the same as the number of elements in x2!")
}
x2id <- obs[xnms == x2nm]
} else {
if (all(xnms != x1nm)) {
if (length(x1) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x1!")
}
bool <- apply(xmat, 2, function(x) all(x1 == x))
if (any(bool)) {
x1id <- obs[bool]
#change x1nm to be the one in formula
x1nm <- xnms[bool]
} else {
stop (paste(paste("'", x1nm, "'", sep = ''), "is not a predictor defined in the cgam fit!"))
}
} else {
x1id <- obs[xnms == x1nm]
}
if (all(xnms != x2nm)) {
if (length(x2) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x2!")
}
bool <- apply(xmat, 2, function(x) all(x2 == x))
if (any(bool)) {
x2id <- obs[bool]
x2nm <- xnms[bool]
} else {
stop (paste(paste("'", x2nm, "'", sep = ''), "is not a predictor defined in the cgam fit!"))
}
} else {
x2id <- obs[xnms == x2nm]
}
}
#xm = xmat[, c(x1id, x2id)]
xm0 = object$newx0
xm = xm0[,c(x1id,x2id)]
#print (x1id)
#print (x2id)
#print (head(x1))
#print (head(x2))
thvs_upp = object$thvs_upp
thvs_lwr = object$thvs_lwr
mins = min(thvs_lwr)+obj$coefs[1]
maxs = max(thvs_upp)+obj$coefs[1]
#print (mins)
#print (maxs)
#print (obj$coefs[1])
#if (up) {
if (is.null(zlim)) {
zlim = c(mins-(maxs-mins)/2.2, maxs+(maxs-mins)/2.2)
}
#} else {
# zlim = c(mins-(maxs-mins)/3, maxs)
#}
res = plotpersp.cgam(obj, x1=x1, x2=x2, x1nm=x1nm, x2nm=x2nm, zlim=zlim, col='white', xlab=xlab, ylab=ylab, zlab=zlab, th=th, ltheta=ltheta, ticktype=ticktype)
#print ('check')
ngrid = res$ngrid
#print (res$zlim)
x_grid = ngrid
y_grid = ngrid
x1g = 0:x_grid / x_grid * .95 * (max(xm[,1]) - min(xm[,1])) + min(xm[,1]) + .025 * (max(xm[,1]) - min(xm[,1]))
n1 = length(x1g)
x2g = 0:y_grid / y_grid * .95 * (max(xm[,2]) - min(xm[,2])) + min(xm[,2]) + .025 * (max(xm[,2]) - min(xm[,2]))
n2 = length(x2g)
xgmat = matrix(nrow = n1, ncol = n2)
eta0 = obj$coefs[1]
if (up) {
thvecs = thvs_upp
} else {
thvecs = thvs_lwr
}
for (i2 in 1:n2) {
for (i1 in 1:n1) {
x1a = max(xm[xm[,1] <= x1g[i1], 1])
x1b = min(xm[xm[,1] > x1g[i1], 1])
v1a = min(thvecs[x1id, xm[,1] == x1a])
v1b = min(thvecs[x1id, xm[,1] == x1b])
alp = (x1g[i1] - x1a) / (x1b - x1a)
th1add = (1 - alp) * v1a + alp * v1b
x2a = max(xm[xm[,2] <= x2g[i2],2])
x2b =min(xm[xm[,2] > x2g[i2],2])
v2a = min(thvecs[x2id, xm[,2] == x2a])
v2b = min(thvecs[x2id, xm[,2] == x2b])
alp = (x2g[i2] - x2a) / (x2b - x2a)
th2add = (1 - alp) * v2a + alp * v2b
xgmat[i1,i2] = eta0 + th1add + th2add
}
}
z_add = res$z_add
x3_add = res$x3_add
xgmat = xgmat + z_add + x3_add
fml = obj$family$family
#if (fml != "gaussian" & fml != "ordered") {
# for (i2 in 1:n2) {
# for (i1 in 1:n1) {
# xgmat[i1, i2] <- muhat.fun(xgmat[i1, i2], fml = fml)
# }
# }
#}
if (up) {
if (is.null(main)) {
main = "Cgam Surface with Upper 95% Confidence Surface"
}
}
if (!up) {
if (is.null(main)) {
main = "Cgam Surface with Lower 95% Confidence Surface"
}
}
par(new = TRUE)
persp(x1g, x2g, xgmat, zlim = res$zlim, xlab = "", ylab = "", zlab = "", theta = res$theta,
ltheta = res$ltheta, cex.axis = res$cex.axis, main = main, cex.main = cex.main,
ticktype = res$ticktype, col=mycol, box=FALSE, axes=FALSE,...)
par(new=FALSE)
}
#################
#plotpersp.wps#
################
plotpersp.wps = function(object, x1 = NULL, x2 = NULL, x1nm = NULL,
x2nm = NULL, data = NULL, surface = "C",
categ = NULL, col = NULL, random = FALSE,
xlim = range(x1), ylim = range(x2), zlim = NULL,
xlab = NULL, ylab = NULL, zlab = NULL, th = NULL,
ltheta = NULL, main = NULL, ticktype = "simple",...) {
#print ('wps')
if (!inherits(object, "wps")) {
warning("calling plotpersp(<fake-wps-object>) ...")
}
#x1nm = deparse(substitute(x1))
#x2nm = deparse(substitute(x2))
#print (x1nm)
#print (x2nm)
xnms = object$xnms_wp
xmat = object$xmat_wp
#if (x1nm == "NULL" | x2nm == "NULL") {
if (is.null(x1nm) | is.null(x2nm)) {
if (length(xnms) >= 2) {
x1nm = xnms[1]
x2nm = xnms[2]
x1id = 1
x2id = 2
x1 = xmat[, 1]
x2 = xmat[, 2]
} else {stop ("Number of non-parametric predictors must >= 2!")}
}
#xnms = object$xnms
#xmat = object$xmat
labels = object$labels
labels = labels[which(grepl("warp", labels, fixed = TRUE))]
#new:
is_fac = object$is_fac
ynm = object$ynm
#xmat is delta
#delta = object$delta
znms = object$znms
decrs0 = object$decrs
kznms = length(znms)
#zmat include 1 vector if only wps + add
zmat = object$zmat
np = d0 = object$d0
pb = object$pb
np_add = object$np_add
p = d0 - np_add
#print ('call wps')
#zmat = zmat[, (pb+1):(pb+d0), drop = FALSE]
#check!
#zmat = zmat[, (pb+1):(pb+p), drop = FALSE]
#print ('zmat')
#print (head(zmat))
if (any(class(object) == "trispl")) {
zmat0 = zmat
} else {
#test more...
if (!is.null(zmat)) {
zmat = zmat[, (pb+1):(pb+p), drop = FALSE]
#new constant in zmat now
#if (d0 > 1) {
# zmat0 = zmat[, -1, drop = FALSE]
#} else {zmat0 = NULL}
zmat0 = zmat
} else {
zmat0 = zmat
}
}
#print (head(zmat0))
if (all(class(object) != "trispl")) {
#zcoefs = object$zcoefs[-1]
#no more constant vector in zmat
zcoefs = object$zcoefs
} else {zcoefs = object$zcoefs}
#print (zcoefs)
zid1 = object$zid1
zid2 = object$zid2
ah = object$coef_wp
#ahu = object$coefsu
varlist = object$varlist_wps
#varlist = varlist[-1]
kts = object$ks_wps
#k1 = object$k1
#k2 = object$k2
#p = dim(zmat)[2]
#p = d0
family = object$family
fml = family$family
cicfamily = CicFamily(family)
muhat.fun = cicfamily$muhat.fun
#additive
thvecs = object$etacomps
xnms_add = object$xnms_add
xmat_add = object$xmat_add
knms = length(xnms_add)
x3_add = 0
if (knms >= 1) {
#x3id <- obs[-c(x1id, x2id)]
#kx3 <- length(x3id)
for (i in 1:knms) {
x3i = xmat_add[, i]
x3i_use = max(x3i[x3i <= median(x3i)])
x3i_add = min(thvecs[i, x3i == x3i_use])
x3_add = x3_add + x3i_add
}
}
#if (!is.null(categ)) {
# if (!is.character(categ)) {
# warning("categ must be a character argument!")
# } else if (!any(znms == categ)) {
#print ('TRUE')
# warning(paste(categ, "is not an exact character name defined in the cgam fit!"))
# categ = NULL
# } else {
# obsz = 1:kznms
# zid = obsz[znms == categ]
# if (!(is_fac[zid])) {
# categ = NULL
# }
# }
#}
if (!is.null(categ)) {
if (!is.character(categ)) {
warning("categ must be a character argument!")
} else if (!any(znms == categ)) {
if (any(grepl(categ, znms))) {
id = which(grepl(categ, znms))
znmi = znms[id]
if (grepl("as.factor", znmi)) {
categ = paste("as.factor(", categ, ")", sep = "")
} else if (grepl("factor", znmi)) {
categ = paste("factor(", categ, ")", sep = "")
} else {print(paste(categ, "is not an exact character name defined in the cgam fit!"))}
} else {print(paste(categ, "is not an exact character name defined in the cgam fit!"))}
} else {
obsz = 1:kznms
zid = obsz[znms == categ]
#linear term:
#if (!(is_fac[zid])) {
# categ = NULL
#}
}
}
#new: switch xnms
if (!is.null(data)) {
if (!is.data.frame(data)) {
stop ("User need to make the data argument a data frame with names for each variable!")
}
datnms = names(data)
if (!any(datnms == x1nm) | !any(datnms == x2nm)) {
stop ("Check the accuracy of the names of x1 and x2!")
}
x1 = data[ ,which(datnms == x1nm)]
x2 = data[ ,which(datnms == x2nm)]
} else {
if (all(xnms != x1nm)) {
#stop (paste(paste("'", x1nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
#new: in case of wrong data fame
if (length(x1) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x1!")
}
bool = apply(xmat, 2, function(x) all(x1 == x))
if (any(bool)) {
#x1id = obs[bool]
x1nm = xnms[bool]
} else {
stop (paste(paste("'", x1nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
if (all(xnms != x2nm)) {
#stop (paste(paste("'", x2nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
if (length(x2) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x2!")
}
bool = apply(xmat, 2, function(x) all(x2 == x))
if (any(bool)) {
#x2id = obs[bool]
x2nm = xnms[bool]
} else {
stop (paste(paste("'", x2nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
}
xnm12 = c(x1nm, x2nm)
id_lab = which(xnms %in% xnm12)
xnm12_lab = labels[id_lab]
xnm_other = xnms[-id_lab]
id1 = id2 = ipr = NULL
#print ('id_lab')
#print (xnm12_lab)
if (length(unique(xnm12_lab)) > 1 | length(id_lab) != 2) {
stop ("Two non-parametric predictors do not form a warped-plane surface!")
} else {
id1 = sort(id_lab)[1]
id2 = sort(id_lab)[2]
ipr = id2 / 2
}
decrs = decrs0[[ipr]]
ktsi = kts[[ipr]]
k1 = ktsi[[1]]
k2 = ktsi[[2]]
m1 = length(k1)
m2 = length(k2)
#if (x1nm0 != xnms[1] & x2nm0 != xnms[2]) {
# x1nm = x2nm0
# x2nm = x1nm0
# tmp = x1
# x1 = x2
# x2 = tmp
#} else {x1nm = x1nm0; x2nm = x2nm0}
#print (paste('id1: ', id1))
#print (paste('id2: ', id2))
if (x1nm != xnms[id1] & x2nm != xnms[id2]) {
nm = x1nm
x1nm = x2nm
x2nm = nm
tmp = x1
x1 = x2
x2 = tmp
}
# apl = 1:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))
# #aplu = 1:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))
# apl[1] = ah[1]
# #aplu[1] = ahu[1]
# #apl[2:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))] = ah[(p + 1):(m1 + m2 - 1 + (m1 - 1) * (m2 - 1) + p - 1)]
# #aplu[2:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))] = ahu[(p + 1):(m1 + m2 - 1 + (m1 - 1) * (m2 - 1) + p - 1)]
# apl[2:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))] = (ah[-c(1:p)])[which(varlist == ipr)]
# #aplu[2:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))] = (ahu[-1])[which(varlist == ipr)]
# mupl = matrix(apl[1], nrow = m1, ncol = m2)
# #muplu = matrix(aplu[1], nrow = m1, ncol = m2)
# for (i1 in 2:m1) {
# mupl[i1, ] = mupl[i1, ] + apl[i1]
# #muplu[i1, ] = muplu[i1, ] + aplu[i1]
# }
# for (i2 in 2:m2) {
# mupl[, i2] = mupl[, i2] + apl[m1 - 1 + i2]
# #muplu[, i2] = muplu[, i2] + aplu[m1 - 1 + i2]
# }
# for (i1 in 2:m1) {
# for (i2 in 2:m2) {
# mupl[i1, i2] = mupl[i1, i2] + apl[m1 + m2 - 2 + (i1 - 2) * (m2 - 1) + i2]
# #muplu[i1, i2] = muplu[i1, i2] + aplu[m1 + m2 - 2 + (i1 - 2) * (m2 - 1) + i2]
# }
# }
#plot the estimates at knots
newData = expand.grid(k1,k2)
colnames(newData) = xnm12
npr = round(length(xnms) / 2, 0L)
new_other = NULL
if (npr > 1) {
new_other = matrix(0, nrow=nrow(newData), ncol=(2*(npr-1)))
kts_other = kts[-ipr]
for (i in 1:(npr-1)) {
for (j in 1:2) {
newi = mean(kts_other[[i]][[j]])
new_other[,(i-1)*2+j] = newi
}
}
newd = cbind(newData, new_other)
colnames(newd) = c(xnm12, xnm_other)
newData = as.data.frame(newd)
}
if (length(xnms_add) > 0) {
#new_add = matrix(0, nrow=nrow(newData), ncol=ncol(xmat_add))
means = apply(xmat_add, 2, mean)
new_add = matrix(rep(means, nrow(newData)), ncol=ncol(xmat_add), byrow=T)
nms = colnames(newData)
newd = cbind(newData, new_add)
colnames(newd) = c(nms, xnms_add)
newData = as.data.frame(newd)
}
#test!
Mode = function(x) {
ux = unique(x)
ux[which.max(tabulate(match(x, ux)))]
}
newz = NULL
if (!is.null(zmat)) {
newz = matrix(0, nrow=nrow(newData), ncol=ncol(zmat))
for(j in 1:(ncol(zmat))) {
newz[,j] = Mode(zmat[,j])
}
}
if (!is.null(newz)) {
znms = object$znms
nz = matrix(0, nrow=nrow(newData), ncol=ncol(newz))
nznm = gsub("[\\(\\)]", "", regmatches(znms, gregexpr("\\(.*?\\)", znms))[[1]])
#new: zmat has > 1 columns -> not work, will make predict.wps give an error
#nznm = paste0(nznm, 1:ncol(newz), sep="")
nms = colnames(newData)
newData = cbind(newData, nz)
#check more:
if (length(nznm) > 0) {
colnames(newData) = c(nms, rep(nznm, ncol(newz)))
}
if (length(nznm) == 0) {
colnames(newData) = c(nms, znms)
}
}
pfit.knots = predict.wps(object, newData, interval='none')
xmatpr = pfit.knots$xmatpr
spls = pfit.knots$spls
#ignore z
spl_use = spls[[ipr]]
#get the fit for each pair
mus = pfit.knots$mus
muhat_use = spl_use%*%ah[which(varlist == ipr)+np]
mupl = matrix(0, m1, m2)
for(i2 in 1:m2) {
for(i1 in 1:m1) {
mupl[i1,i2] = muhat_use[(i2-1)*m1 + i1]
}
}
#new: more families
if (fml != "gaussian") {
for (i1 in 1:m1) {
for (i2 in 1:m2) {
mupl[i1, i2] = muhat.fun(mupl[i1, i2], fml = fml)
#muplu[i1, i2] = muhat.fun(muplu[i1, i2], fml = fml)
}
}
#mupl = muhat.fun(mupl, fml = fml)
#muplu = muhat.fun(muplu, fml = fml)
}
## reverse transform for decreasing
if (is.null(th) | !is.numeric(th)) {
ang = NULL
if (!decrs[1] & !decrs[2]) {
if (is.null(ang)) {
ang = -40
}
} else if (decrs[1] & !decrs[2]) {
#k1 = -k1[m1:1];
#mupl = mupl[m1:1, 1:m2];
#muplu = muplu[m1:1, 1:m2]
if (is.null(ang)) {
ang = 40
}
} else if (!decrs[1] & decrs[2]) {
#k2 = -k2[m2:1];
#mupl = mupl[1:m1, m2:1];
#muplu = muplu[1:m1, m2:1]
if (is.null(ang)) {
ang = 240
}
} else if (decrs[1] & decrs[2]) {
#k1 = -k1[m1:1]; k2 = -k2[m2:1];
#mupl = mupl[m1:1, m2:1];
#muplu = muplu[m1:1, m2:1]
if (is.null(ang)) {
ang = 140
}
}
} else {ang = th}
if (is.null(ltheta) | !is.numeric(ltheta)) {
ltheta <- -135
}
if (is.null(categ)) {
z_add = 0
if (!is.null(znms)) {
kzids = length(zid1)
for (i in 1:kzids) {
pos1 = zid1[i]; pos2 = zid2[i]
#zi is a factor
zi = zmat0[, pos1:pos2, drop = FALSE]
zcoefsi = zcoefs[pos1:pos2]
for (j in 1:ncol(zi)){
#find the 'mode' of the jth column of zi; add the coef corresponding to the 'mode'
uzij = unique(zi[,j])
kuzij = length(uzij)
nmodej = sum(zi[,j] == uzij[1])
zij_mode = uzij[1]
for (u in 2:kuzij) {
if (sum(zi[,j] == uzij[u]) > nmodej) {
zij_mode = uzij[u]
nmodej = sum(zi[,j] == uzij[u])
}
}
obsuzij = 1:length(uzij)
uzhatij = uzij * zcoefsi[j]
zij_add = uzhatij[obsuzij[uzij == zij_mode]]
z_add = z_add + zij_add
}
}
}
mupl = mupl + as.numeric(z_add) + as.numeric(x3_add)
#muplu = muplu + as.numeric(z_add)
#new:
if (fml != "gaussian") {
for (i1 in 1:m1) {
for (i2 in 1:m2) {
mupl[i1, i2] = muhat.fun(mupl[i1, i2], fml = fml)
#muplu[i1, i2] = muhat.fun(muplu[i1, i2], fml = fml)
}
}
#mupl = muhat.fun(mupl, fml = fml)
#muplu = muhat.fun(muplu, fml = fml)
}
mins = min(mupl); maxs = max(mupl)
#minsu = min(muplu); maxsu = max(muplu)
} else {
mupls = muplus = list()
mins = maxs = NULL
minsu = maxsu = NULL
obsz = 1:kznms
zid = obsz[znms == categ]
pos1 = zid1[zid]; pos2 = zid2[zid]
zcoefsi = zcoefs[pos1:pos2]
#?include the base level
zcoefsi = c(0, zcoefsi)
z_add = sort(zcoefsi)
kz_add = length(z_add)
#print (kz_add)
for (iz in 1:kz_add) {
mupls[[iz]] = mupl + z_add[iz] + as.numeric(x3_add)
mins = c(mins, min(mupls[[iz]]))
maxs = c(maxs, max(mupls[[iz]]))
#muplus[[iz]] = muplu + z_add[iz]
#minsu = c(minsu, min(muplus[[iz]]))
#maxsu = c(maxsu, max(muplus[[iz]]))
}
if (fml != "gaussian") {
for (iz in 1:kz_add) {
mupli = mupls[[iz]]
#muplui = muplus[[iz]]
for (i1 in 1:m1) {
for (i2 in 1:m2) {
mupli[i1, i2] = muhat.fun(mupli[i1, i2], fml = fml)
#muplui[i1, i2] = muhat.fun(muplui[i1, i2], fml = fml)
}
}
#mupli = muhat.fun(mupli, fml = fml)
#muplui = muhat.fun(muplui, fml = fml)
mupls[[iz]] = mupli
#muplus[[iz]] = muplui
}
}
}
palette = c("peachpuff", "lightblue", "limegreen", "grey", "wheat", "yellowgreen", "seagreen1", "palegreen", "azure", "whitesmoke")
if (is.null(xlab)) {
xlab = x1nm
}
if (is.null(ylab)) {
ylab = x2nm
}
if (is.null(zlab)) {
if (fml == "binomial") {
zlab = paste("Pr(", ynm, ")")
} else if (fml == "poisson" | fml == "gaussian" | fml == "Gamma") {
zlab = paste("Est mean of", ynm)
}
}
if (is.null(categ)) {
if (is.null(col)) {
if (random) {
col = sample(palette, size = 1, replace = FALSE)
} else {
#col = "white"
if (surface == 'C') {
musurf = mupl
#} else if (surface == 'U') {
# musurf = muplu
}
nr = nrow(musurf)
nc = ncol(musurf)
ncol = 100
facet = musurf[-1,-1] + musurf[-1,-nc] + musurf[-nr,-1] + musurf[-nr,-nc]
facetcol = cut(facet, ncol)
col = heat.colors(ncol)[facetcol]
}
} else if (col == "heat" | col == "topo" | col == "terrain" | col == "cm") {
if (surface == 'C') {
musurf = mupl
#} else if (surface == 'U') {
# musurf = muplu
}
nr = nrow(musurf)
nc = ncol(musurf)
ncol = 100
facet = musurf[-1,-1] + musurf[-1,-nc] + musurf[-nr,-1] + musurf[-nr,-nc]
facetcol = cut(facet, ncol)
if (col == "heat") {
col = heat.colors(ncol)[facetcol]
} else if (col == "topo") {
col = topo.colors(ncol)[facetcol]
} else if (col == "terrain") {
col = terrain.colors(ncol)[facetcol]
} else {
col = cm.colors(ncol)[facetcol]
}
}
if (surface == 'C') {
musurf = mupl
#if (is.null(main)) {
# main = 'Constrained Warped-Plane Spline Surface'
#}
if (is.null(zlim)) {
lwr = min(mins)
upp = max(maxs)
#print (lwr)
#print (upp)
zlim0 = c(lwr - (upp-lwr)/5, upp + (upp-lwr)/5)
} else {
zlim0 = zlim
}
#} else if (surface == 'U') {
# musurf = muplu
#if (is.null(main)) {
# main = 'Unconstrained Warped-Plane Spline Surface'
#}
#zlim0 = c(min(minsu), max(maxsu))
}
#print (head(musurf))
xlim = range(x1)
ylim = range(x2)
#persp(k1, k2, musurf, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype,...)
persp(k1, k2, musurf, zlim = zlim0, xlab = xlab, ylab = ylab, zlab = zlab,
theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype,...)
rslt = list(zlim = zlim0, xlab = xlab, ylab = ylab, zlab = zlab, theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype, z_add = z_add, x3_add = x3_add)
invisible(rslt)
} else {
kxgm = length(mupls)
if (is.null(col)) {
if (random) {
#new:
col = topo.colors(kxgm)
#col = sample(palette, size = kxgm, replace = FALSE)
} else {
if (kxgm > 1 & kxgm < 11) {
col = palette[1:kxgm]
} else {
#integ = floor(kxgm / 10)
#rem = kxgm %% 10
#kint = length(integ)
#col = NULL
#for (i in 1:kint) {
# col = c(col, palette)
#}
#col = c(col, palette[1:rem])
#new:
col = topo.colors(kxgm)
}
}
} else {
col0 = col
if (col0 == "heat" | col0 == "topo" | col0 == "terrain" | col0 == "cm") {
ncol = 100
facets = facetcols = list()
if (surface == "C") {
xgmats = mupls
}
#if (surface == "U") {
# xgmats = muplus
#}
col = list()
for (i in 1:kxgm) {
nr = nrow(xgmats[[i]])
nc = ncol(xgmats[[i]])
facets[[i]] = (xgmats[[i]])[-1,-1] + (xgmats[[i]])[-1,-nc] + (xgmats[[i]])[-nr,-1] + (xgmats[[i]])[-nr,-nc]
facetcols[[i]] = cut(facets[[i]], ncol)
if (col0 == "heat") {
col[[i]] = (heat.colors(ncol))[facetcols[[i]]]
} else if (col0 == "topo") {
col[[i]] = (topo.colors(ncol))[facetcols[[i]]]
} else if (col0 == "terrain") {
col[[i]] = (terrain.colors(ncol))[facetcols[[i]]]
} else {
col[[i]] = (cm.colors(ncol))[facetcols[[i]]]
}
}
} else if (length(col0) < kxgm) {
#rem = kxgm - length(col)
#nrem = length(rem)
#rem_col = palette[1:nrem]
#col = c(col, rem_col)
#new:
col = topo.colors(kxgm)
} else if (length(col0) > kxgm) {
col = col[1:kxgm]
#print (paste("The first", kxgm, "colors are used!"))
}
#if (random) {
#print ("User defined colors are used!")
#}
}
for (i in 1:kxgm) {
mupli = mupls[[i]]
#muplui = muplus[[i]]
if (surface == 'C') {
musurf = mupli
#if (is.null(main)) {
# main = 'Constrained Warped-Plane Spline Surface'
#}
if (is.null(zlim)) {
lwr = min(mins)
upp = max(maxs)
zlim0 = c(lwr - (upp-lwr)/5, upp + (upp-lwr)/5)
} else {
zlim0 = zlim
}
#} else if (surface == 'U') {
# musurf = muplui
#if (is.null(main)) {
# main = 'Unconstrained Warped-Plane Spline Surface'
#}
#zlim0 = c(min(minsu), max(maxsu))
}
#par(mar = c(4, 2, 2, 2))
#print (sub)
#persp(k1, k2, musurf, sub = sub)
if (is.list(col)) {
coli = unlist(col[[i]])
} else {coli = col[i]}
#xlim = range(x1)
#ylim = range(x2)
#persp(k1, k2, musurf, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = coli, cex.axis = .75, main = main, ticktype = ticktype,...)
persp(k1, k2, musurf, zlim = zlim0, xlab = xlab, ylab = ylab, zlab = zlab, theta = ang,
ltheta = ltheta, col = coli, cex.axis = .75, main = main, ticktype = ticktype,...)
par(new = TRUE)
}
par(new = FALSE)
}
}
##########################################
#apply plotpersp on a wps.predict object
#>=1 wps pair + z + additive #done
##########################################
###############################################################
#plotpersp for a predict.wps object
#check the zlim when there's a smooth additive component more
###############################################################
plotpersp.wpsp = function(object, x1=NULL, x2=NULL, x1nm=NULL, x2nm=NULL,
data=NULL, up = TRUE, main=NULL, cex.main=.8, xlab = NULL,
ylab = NULL, zlab = NULL, th = NULL, ltheta = NULL,
ticktype = "simple",...) {
#obj is prediction for wps
if (!inherits(object, "wpsp")) {
warning("calling plotpersp(<fake-wpsp-object>) ...")
}
t_col = function(color, percent = 50, name = NULL) {
rgb.val <- col2rgb(color)
## Make new color using input color as base and alpha set by transparency
t.col <- rgb(rgb.val[1], rgb.val[2], rgb.val[3],
maxColorValue = 255,
alpha = (100-percent)*255/100,
names = name)
## Save the color
invisible(t.col)
}
if (up) {
mycol = t_col("green", perc = 90, name = "lt.green")
} else {
mycol = t_col("pink", perc = 80, name = "lt.pink")
}
acov = object$acov
mult = object$mult
#obj is the wps fit
obj = object$object
ah = obj$coef_wp
xnms = obj$xnms_wp
xmat = obj$xmat_wp
delta = obj$delta
decrs = obj$decrs
xnms_add = obj$xnms_add
xmat_add = obj$xmat_add
#if (x1nm == "NULL" | x2nm == "NULL") {
if (is.null(x1nm) | is.null(x2nm)) {
if (length(xnms) >= 2) {
x1nm = xnms[1]
x2nm = xnms[2]
x1id = 1
x2id = 2
x1 = xmat[, 1]
x2 = xmat[, 2]
} else {stop ("Number of non-parametric predictors must >= 2!")}
}
labels = obj$labels
labels = labels[which(grepl("warp", labels, fixed = TRUE))]
is_fac = obj$is_fac
ynm = obj$ynm
varlist = obj$varlist_wps
#varlist = varlist[-1]
kts = obj$ks_wps
np = obj$d0
#switch xnms
if (!is.null(data)) {
if (!is.data.frame(data)) {
stop ("User need to make the data argument a data frame with names for each variable!")
}
datnms = names(data)
if (!any(datnms == x1nm) | !any(datnms == x2nm)) {
stop ("Check the accuracy of the names of x1 and x2!")
}
x1 = data[ ,which(datnms == x1nm)]
x2 = data[ ,which(datnms == x2nm)]
} else {
if (all(xnms != x1nm)) {
#stop (paste(paste("'", x1nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
#new: in case of wrong data fame
if (length(x1) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x1!")
}
bool = apply(xmat, 2, function(x) all(x1 == x))
if (any(bool)) {
#x1id = obs[bool]
x1nm = xnms[bool]
} else {
stop (paste(paste("'", x1nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
if (all(xnms != x2nm)) {
#stop (paste(paste("'", x2nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
if (length(x2) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x2!")
}
bool = apply(xmat, 2, function(x) all(x2 == x))
if (any(bool)) {
#x2id = obs[bool]
x2nm = xnms[bool]
} else {
stop (paste(paste("'", x2nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
}
xnm12 = c(x1nm, x2nm)
id_lab = which(xnms %in% xnm12)
xnm12_lab = labels[id_lab]
#new:
xnm_other = xnms[-id_lab]
id1 = id2 = ipr = NULL
if (length(unique(xnm12_lab)) > 1 | length(id_lab) != 2) {
stop ("Two non-parametric predictors do not form a warped-plane surface!")
} else {
id1 = sort(id_lab)[1]
id2 = sort(id_lab)[2]
ipr = id2 / 2
}
#find the pairs to be plotted
decrs_use = decrs[[ipr]]
kts_use = kts[[ipr]]
x1p = kts_use[[1]]
x2p = kts_use[[2]]
k1 = length(x1p)
k2 = length(x2p)
if (x1nm != xnms[id1] & x2nm != xnms[id2]) {
nm = x1nm
x1nm = x2nm
x2nm = nm
tmp = x1
x1 = x2
x2 = tmp
#new:
xnm12 = c(x1nm, x2nm)
}
newData = expand.grid(x1p,x2p)
#find the names of the pair
colnames(newData) = xnm12
#ignore z if there's any
#temp:
newz = object$newz
npr = round(length(xnms) / 2, 0L)
new_other = NULL
if (npr > 1) {
new_other = matrix(0, nrow=nrow(newData), ncol=(2*(npr-1)))
kts_other = kts[-ipr]
for (i in 1:(npr-1)) {
for (j in 1:2) {
newi = mean(kts_other[[i]][[j]])
new_other[,(i-1)*2+j] = newi
}
}
newd = cbind(newData, new_other)
colnames(newd) = c(xnm12, xnm_other)
newData = as.data.frame(newd)
}
if (length(xnms_add) > 0) {
#new_add = matrix(0, nrow=nrow(newData), ncol=ncol(xmat_add))
means = apply(xmat_add, 2, mean)
new_add = matrix(rep(means, nrow(newData)), ncol=ncol(xmat_add), byrow=T)
nms = colnames(newData)
newd = cbind(newData, new_add)
colnames(newd) = c(nms, xnms_add)
newData = as.data.frame(newd)
}
if (!is.null(newz)) {
znms = obj$znms
nz = matrix(0, nrow=nrow(newData), ncol=ncol(newz))
nznm = gsub("[\\(\\)]", "", regmatches(znms, gregexpr("\\(.*?\\)", znms))[[1]])
#new: zmat has > 1 columns -> not work, will make predict.wps give an error
#nznm = paste0(nznm, 1:ncol(newz), sep="")
nms = colnames(newData)
newData = cbind(newData, nz)
colnames(newData) = c(nms, nznm)
}
#print (head(x1))
#print (x1nm)
#print (x2nm)
#print (colnames(newData))
#determine zlim beforehand
pfit.knots = predict.wps(obj, newData, interval='none')
#get the spline for each pair
xmatpr = pfit.knots$xmatpr
spls = pfit.knots$spls
#ignore z
#spl_use = cbind(1, spls[[ipr]])
spl_use = spls[[ipr]]
#get the fit for each pair
mus = pfit.knots$mus
#muhat_use = mus[[ipr]]
#test more:
#muhat_use = spl_use%*%ah[c(1, which(varlist == ipr)+np)]
muhat_use = spl_use%*%ah[which(varlist == ipr)+np]
#get the acov for each pair
if (length(xnms_add) > 0) {
k_add = length(obj$coef_add)
k_conv = sum(obj$shapes == 11 || obj$shapes == 12)
#acov_use = acov[c(1, which(varlist == ipr)+np+k_conv+k_add), c(1, which(varlist == ipr)+np+k_conv+k_add)]
keep_id = which(varlist == ipr)+np+k_conv+k_add
acov_use = acov[keep_id, keep_id]
} else {
#acov_use = acov[c(1, which(varlist == ipr)+np), c(1, which(varlist == ipr)+np)]
keep_id = which(varlist == ipr)+np
acov_use = acov[keep_id, keep_id]
}
lower = muhat_use - mult*sqrt(diag(spl_use%*%acov_use%*%t(spl_use)))
upper = muhat_use + mult*sqrt(diag(spl_use%*%acov_use%*%t(spl_use)))
#lower = pfit.knots$lower
#upper = pfit.knots$upper
#zlwr = min(object$lower) - (max(object$fit) - min(object$fit)) / 2 + x3_add
#zupp = max(object$upper) + (max(object$fit) - min(object$fit)) / 2 + x3_add
#check the limits more
zlwr = min(lower) - (max(object$fit) - min(object$fit)) / 10
zupp = max(upper) + (max(object$fit) - min(object$fit)) / 10
res = plotpersp.wps(obj, x1=x1, x2=x2, x1nm, x2nm, col='white', zlim=c(zlwr, zupp), xlab=xlab, ylab=ylab, zlab=zlab, th=th, ltheta=ltheta, ticktype=ticktype)
#res = plotpersp.wps(obj, x1=x1, x2=x2, x1nm, x2nm, col='white', xlab=xlab, ylab=ylab, zlab=zlab, th=th, ltheta=ltheta, ticktype=ticktype)
surf = matrix(0, k1, k2)
for(i2 in 1:k2) {
for(i1 in 1:k1) {
if (up) {
#surf[i1,i2] = muhat_use[(i2-1)*k1 + i1]
surf[i1,i2] = upper[(i2-1)*k1 + i1]
} else {
surf[i1,i2] = lower[(i2-1)*k1 + i1]
}
}
}
z_add = res$z_add
x3_add = res$x3_add
surf = surf + z_add + x3_add
if (up) {
if (is.null(main)) {
main = "Warped-Plane Surface with Upper 95% Confidence Surface"
}
}
if (!up) {
if (is.null(main)) {
main = "Warped-Plane Surface with Lower 95% Confidence Surface"
}
}
par(new = TRUE)
#persp(x1p, x2p, surf, zlim = res$zlim, xlab = res$xlab, ylab = res$ylab, zlab = res$zlab, theta = res$theta, ltheta = res$ltheta, cex.axis = res$cex.axis, main = main, cex.main = cex.main, ticktype = res$ticktype, col=mycol)
persp(x1p, x2p, surf, zlim = res$zlim, xlab = "", ylab = "", zlab = "",
theta = res$theta, ltheta = res$ltheta, cex.axis = res$cex.axis,
main = main, cex.main = cex.main, ticktype = res$ticktype, col=mycol, box=FALSE, axes=FALSE,...)
par(new=FALSE)
}
#####
#wps#
#####
wps_getedf = function(ahati, sm, amat, amat0, xw0, xmat0, qmat0, p) {
nz = 1:dim(amat)[1] < sm
nz[amat %*% ahati > sm] = TRUE
if (sum(nz) < dim(amat0)[1]) {
gamj = -t(amat0[!nz, ])
if (length(gamj) == dim(xw0)[2]) {
gamj = matrix(gamj, ncol = 1)
}
aq = qr(gamj)
if (aq$rank >= 1) {
if (aq$rank == 1) {
gamj = matrix(qr.Q(aq)[, 1:aq$rank, drop = FALSE], ncol = 1)
} else {
gamj = qr.Q(aq)[, 1:aq$rank, drop = FALSE]
}
pa = gamj %*% solve(t(gamj) %*% gamj) %*% t(gamj)
dj1 = dim(gamj)[1]; dj2 = dim(gamj)[2]
#imat = matrix(0, nrow = dj1, ncol = dj1)
#for (i in 1:dj1) {imat[i, i] = 1}
imat = diag(dj1)
uvecs = matrix(rnorm(dj1 * (dj1 - dj2)), nrow = dj1)
wmatt = (imat - pa) %*% uvecs
aqt = qr(wmatt); wmat = qr.Q(aqt)
b0mat = xw0 %*% wmat
}
} else {
b0mat = xw0
inmat = diag(dim(xmat0)[2])
wmat = inmat
}
p0mat = xmat0 %*% wmat %*% solve(t(wmat) %*% qmat0 %*% wmat) %*% t(wmat) %*% t(xmat0)
edfi = sum(diag(p0mat)) + p - 1
return (edfi)
}
########################################
#new wps.fit, with new amat and dmat
########################################
wps.fit = function(x1t, x2t, y, zmat = NULL, xmat_add = NULL, delta_add = NULL, delta_ut = NULL, varlist_add = NULL,
shapes_add = NULL, np_add = 0, shapes = NULL, w = NULL, pen = 0, pnt = TRUE, cpar = 1.5, decrs = c(FALSE, FALSE), delta = NULL, kts = NULL, wt.iter = FALSE, family = gaussian(), cic = FALSE, nsim = 100, nprs = 1, idx_s = NULL, idx = NULL, gcv = FALSE, pvf = FALSE) {
cicfamily = CicFamily(family)
linkfun = cicfamily$linkfun
llh.fun = cicfamily$llh.fun
etahat.fun = cicfamily$etahat.fun
gr.fun = cicfamily$gr.fun
wt.fun = cicfamily$wt.fun
zvec.fun = cicfamily$zvec.fun
muhat.fun = cicfamily$muhat.fun
ysim.fun = cicfamily$ysim.fun
deriv.fun = cicfamily$deriv.fun
dev.fun = cicfamily$dev.fun
n = length(y)
#new: scale penalty term later
#scy = var(y)
one = 1:n*0 + 1
# if (is.null(zmat)) {
# zmat = matrix(one, ncol = 1)
# } else {
# if (dim(zmat)[1] != n) {
# stop ("Error: # rows of zmat must equal length of y")
# }
# zproj = zmat %*% solve(crossprod(zmat), t(zmat))
# onep = one - zproj %*% one
# # if the one vector is not in the space of zmat, then include the one vector in zmat
# if (sum(onep^2) > 1e-12) {
# zmat = cbind(one, zmat)
# }
# }
#p doesn't include the additive x
p = 0
if (!is.null(zmat)){
p = dim(zmat)[2]
dimnames(zmat)[[2]] = NULL
}
#new: we have additive x's
#we already get warp.delta (delta); the 1st col of xmat is one
#bmat include conv, conc, shape = 17 and additive
#include bmat in zmat because we don't have penalty for bmat
imat = diag(n)
#delta0 = delta
#dproj = delta%*%solve(crossprod(delta))%*%t(delta)
#zproj = zmat %*% solve(crossprod(zmat), t(zmat))
#zmat = (imat - dproj) %*% zmat
#delta = (imat - zproj) %*% delta
#save(delta,file='delta.Rda')
xmat0 = delta
bmat = NULL
pb = 0
if (!is.null(delta_add)) {
bmat = t(delta_add)
pb = ncol(bmat)
zmat = cbind(bmat, zmat)
xmat0 = cbind(xmat0, bmat)
}
#stop (print (xmat0[1,]))
#print (all(xmat0[, 1] == 1))
#xmat is additive, z, surface
if (p >= 1) {
#xmat = cbind(zmat, delta[, -1])
#imat = diag(n)
#zproj = zmat %*% solve(crossprod(zmat), t(zmat))
#delta = (imat - zproj) %*% delta
#zproj = zmat %*% solve(crossprod(zmat), t(zmat))
#onep = one - zproj %*% one
#onep = one %*% solve(crossprod(one), t(one))
#delta = (imat - onep) %*% delta
#zmat = (imat - onep)%*%zmat
xmat = cbind(zmat, delta)
#xmat = cbind(delta,zmat)
} else {
#xmat = xmat0
xmat = delta
}
# constraint matrix
if (nprs >= 1) {
amat_lst = list()
dmat_lst = list()
varlist = NULL
for (ipr in 1:nprs) {
ktsi = kts[[ipr]]
k1 = ktsi[[1]]
k2 = ktsi[[2]]
m1 = length(k1)
m2 = length(k2)
amat = matrix(0, nrow = 2*m1*m2 - m1 - m2, ncol = m1*m2)
irow = 0
for(j in 1:(m2-1)){
for(i in 1:m1){
irow = irow+1
amat[irow,m2*(i-1)+j]=-1
amat[irow,m2*(i-1)+j+1]=1
}
}
for(j in 1:m2){
for(i in 1:(m1-1)){
irow = irow+1
amat[irow,m2*(i)+j]=1
amat[irow,m2*(i-1)+j]=-1
}
}
amat_lst[[ipr]] = amat
# penalty matrix
dmat = matrix(0, nrow = 2*(m1 * m2 - m1 - m2), ncol = m1*m2)
irow = 0
for(j in 1:m2){
for(i in 1:(m1-2)){
irow=irow+1
dmat[irow,m2*(i+1)+j]=1/(k1[i+2]-k1[i+1])
dmat[irow,m2*i+j]=-1/(k1[i+2]-k1[i+1])-1/(k1[i+1]-k1[i])
dmat[irow,m2*(i-1)+j]=1/(k1[i+1]-k1[i])
}
}
for(j in 1:(m2-2)){
for(i in 1:m1){
irow=irow+1
dmat[irow,m2*(i-1)+j+2]=1/(k2[j+2]-k2[j+1])
dmat[irow,m2*(i-1)+j+1]=-1/(k2[j+2]-k2[j+1])-1/(k2[j+1]-k2[j])
dmat[irow,m2*(i-1)+j]=1/(k2[j+1]-k2[j])
}
}
dmat_lst[[ipr]] = dmat
#if (ipr > 1) {
#no constant for the 2nd pair
# vari = 1:(m1*m2-1)*0 + ipr
# } else {
# vari = 1:m1*m2*0 + ipr
# }
vari = 1:m1*m2*0 + ipr
#this varlist is for surface
varlist = c(varlist, vari)
}
amat = as.matrix(bdiag(amat_lst))
dmat = as.matrix(bdiag(dmat_lst))
}
#amat0 is for the wps surface now
amat0 = amat
#print (amat0[,1])
nr0 = nrow(amat0); nc0 = ncol(amat0)
#amat include the original zmat
if (p >= 1) {
#amatz = matrix(0, nrow = 2 * m1 * m2 - m1 - m2, ncol = p)
#amat = cbind(amatz, amat[, 2:(m1 * m2)])
#p doesn't include additive components but include the one vector
amatz = matrix(0, nrow = nrow(amat), ncol = p)
#amat = cbind(amatz, amat[, -1])
amat = cbind(amatz, amat)
#amat = cbind(amat, amatz)
}
#now make amat and amat0 to include additive components
nr = nrow(amat); nc = ncol(amat)
if (pb >= 1) {
tmp = matrix(0, nrow = (nr+pb), ncol = (nc+pb))
tmp0 = matrix(0, nrow = (nr0+pb), ncol = (nc0+pb))
amatb = diag(pb)
#np_add is shape == 17 and conc (4,12); conv (3,11)
if (np_add > 0) {
amatb[1:np_add,1:np_add] = 0
}
tmp[1:pb,1:pb] = amatb
tmp0[1:pb,1:pb] = amatb
tmp[(pb+1):(nr+pb), (pb+1):(nc+pb)] = amat
tmp0[(pb+1):(nr0+pb), (pb+1):(nc0+pb)] = amat0
amat = tmp
amat0 = tmp0
}
dmat0 = dmat
#print (paste('dmat', dim(dmat)))
#not penalize the addtive part and z, zmat include both
if (p >= 1) {
dmatz = matrix(0, nrow = dim(dmat)[1], ncol = p)
#dmat = cbind(dmatz, dmat[, -1])
dmat = cbind(dmatz, dmat)
#dmat = cbind(dmat, dmatz)
}
if (pb >= 1) {
dmatb = matrix(0, nrow = dim(dmat)[1], ncol = pb)
dmat = cbind(dmatb, dmat)
dmat0 = cbind(dmatb, dmat0)
}
#}
# weight
# xmat0 not include zmat;only used in edf
#print (dim(xmat))
#print (dim(amat))
#print (dim(dmat))
if (is.null(w)) {
xw0 = xmat0
yw = y
xw = xmat
zw = zmat
} else {
if (min(w) > 1e-8) {
yw = y * sqrt(w)
xw = xmat
zw = zmat
xw0 = xmat0
for (i in 1:n) {
xw[i, ] = xmat[i, ] * sqrt(w[i])
xw0[i, ] = xmat0[i, ] * sqrt(w[i])
zw[i, ] = zmat[i, ] * sqrt(w[i])
}
} else {
xw0 = xmat0; xw = xmat; yw = y; zw = zmat
}
}
# transform to cone projection
sc = 1
#print (pen)
sm = 0
if (round(pen, 6) > sm) {
ps = pen
if (pen > 1) {
warning('Large penalty term will make the inference wrong!')
}
} else if (pnt & (round(pen, 6) == 0)) {
#new: penalty interplolation
if (!gcv) {
ps = make_pen(n)
#print (ps)
} else {
#ps = make_pen(n, xw=xmat, xmat=xmat, dmat=dmat, y=y, amat=amat, gcv=gcv)
ng = 9
lams = 2^(0:8)
#lams = lams/2^8/n^(1/3)
#lams = 10*lams/2^8/n^(3/4)
lams = lams/2^8/n^(3/4)
#print (lams)
gcvs = 1:ng*0
for(i in 1:ng) {
# pen = lams[ipen]
# qv = t(xmat)%*%xmat+pen*t(dmat)%*%dmat
# umat = chol(qv)
# uinv = solve(umat)
# atil = amat%*%uinv
# zvec = t(uinv)%*%t(xmat)%*%y
# ans = coneA(zvec,atil)
# ahatc = uinv%*%ans$thetahat
# dimp = nrow(qv)
# if (length(ans$face)==0) {
# pmat = diag(dimp)
# } else if (length(ans$face)==1){
# aj = matrix(atil[ans$face,],nrow=1)
# pmat = -t(aj)%*%solve(aj%*%t(aj))%*%aj
# for(i in 1:dimp){pmat[i,i] = 1+pmat[i,i]}
# } else {
# aj = atil[ans$face,]
# pmat = -t(aj)%*%solve(aj%*%t(aj))%*%aj
# for(i in 1:dimp){pmat[i,i] = 1+pmat[i,i]}
# }
# ## get df
# bigp = xmat%*%uinv%*%pmat%*%t(uinv)%*%t(xmat)
# degf = sum(diag(bigp))
# muhat = xmat%*%ahatc
# sse = sum((y-muhat)^2)
# gcvs[ipen] = sse/(1-degf/n)^2
pen = lams[i]
qv0 = crossprod(xw)
dv0 = crossprod(dmat)
qv = qv0 + pen * dv0
cv = crossprod(xw, y)
umat = chol(qv)
uinv = solve(umat)
atil = amat %*% uinv
cvec = t(uinv) %*% t(xw) %*% y
ansi = coneA(cvec, atil, msg = FALSE)
face = ansi$face
phihat = ansi$thetahat
ahat = uinv %*% phihat
muhat = xmat %*% ahat
sse = sum((y-muhat)^2)
dp = -atil
dp = t(dp)
imat = diag(nrow(qv))
if (length(face) == 0) {
pm = imat
} else {
smat = dp[,face,drop=FALSE]
pmat_polar = smat %*% solve(crossprod(smat), t(smat))
pm = (imat-pmat_polar)
}
bigp = xmat%*%uinv%*%pm%*%t(uinv)%*%t(xmat)
edfi = sum(diag(bigp))
gcvi = sse/(1-edfi/n)^2
gcvs[i] = gcvi
}
ps = min(lams[gcvs == min(gcvs)])
}
} else if (!pnt) {
ps = 1e-6
}
if (!wt.iter) {
qmat = t(xw) %*% xw + ps * t(dmat) %*% dmat
qmat0 = t(xw0) %*% xw0 + ps * t(dmat0) %*% dmat0
umat = chol(qmat)
uinv = solve(umat)
atil = amat %*% uinv
cvec = t(uinv) %*% t(xw) %*% yw
ans = coneA(cvec, atil, msg = FALSE)
face = ans$face
phihat = ans$thetahat
ahat = uinv %*% phihat
#muhat = xw %*% ahat
muhat = xmat %*% ahat
muhatkeep = muhat
etahatkeep = muhat
coefkeep = ahat
llh = llh.fun(y, muhatkeep, etahatkeep, phihat=NULL, n, w, fml = family$family)
} else {
etahat = etahat.fun(n, y, fml = family$family)
gr = gr.fun(y, etahat, weights = w, fml = family$family)
wt = wt.fun(y, etahat, n, weights = w, fml = family$family)
#cvec = crossprod(xw, (wt * etahat - gr))
#qmat = t(xw) %*% diag(wt) %*% xw + ps * t(dmat) %*% dmat
#qmat0 = t(xw0) %*% diag(wt) %*% xw0 + ps * t(dmat0) %*% dmat0
cvec = crossprod(xmat, (wt * etahat - gr))
qmat = t(xmat) %*% diag(wt) %*% xmat + ps * t(dmat) %*% dmat
qmat0 = t(xmat0) %*% diag(wt) %*% xmat0 + ps * t(dmat0) %*% dmat0
ans = qprog(qmat, cvec, amat, 1:nrow(amat)*0, msg = FALSE)
face = ans$face
ahat = ans$thetahat
#etahat = xw %*% ahat
etahat = xmat %*% ahat
muhat = muhat.fun(etahat, fml = family$family)
diff = 1
nrep = 0
sm = 1e-8
while (diff > sm & nrep < 100) {
oldmu = muhat
nrep = nrep + 1
gr = gr.fun(y, etahat, weights = w, fml = family$family)
wt = wt.fun(y, etahat, n, weights = w, fml = family$family)
#cvec = crossprod(xw, (wt * etahat - gr))
#qmat = t(xw) %*% diag(wt) %*% xw + ps * t(dmat) %*% dmat
#qmat0 = t(xw0) %*% diag(wt) %*% xw0 + ps * t(dmat0) %*% dmat0
cvec = crossprod(xmat, (wt * etahat - gr))
qmat = t(xmat) %*% diag(wt) %*% xmat + ps * t(dmat) %*% dmat
qmat0 = t(xmat0) %*% diag(wt) %*% xmat0 + ps * t(dmat0) %*% dmat0
ans = qprog(qmat, cvec, amat, 1:nrow(amat)*0, msg = FALSE)
ahat = ans$thetahat
#etahat = xw %*% ahat
etahat = xmat %*% ahat
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
}
muhatkeep = muhat
etahatkeep = etahat
coefkeep = ahat
llh = llh.fun(y, muhatkeep, etahatkeep, phihat=NULL, n, w, fml = family$family)
}
# get trace of "proj" matrix
# include the additive part
sm = 1e-8
nz = 1:dim(amat)[1] < sm
#only additive and wps will give nz = TRUE
nz[amat %*% ahat > sm] = TRUE
if (sum(nz) < dim(amat0)[1]) {
gamj = -t(amat0[!nz, ])
if (length(gamj) == dim(xw0)[2]) {
gamj = matrix(gamj, ncol = 1)
}
aq = qr(gamj)
if (aq$rank >= 1) {
if (aq$rank == 1) {
gamj = matrix(qr.Q(aq)[, 1:aq$rank, drop = FALSE], ncol = 1)
} else {
gamj = qr.Q(aq)[, 1:aq$rank, drop = FALSE]
}
#pa = gamj %*% solve(crossprod(gamj), t(gamj))
pa = gamj %*% solve(t(gamj) %*% gamj) %*% t(gamj)
dj1 = dim(gamj)[1]; dj2 = dim(gamj)[2]
#imat = matrix(0, nrow = dj1, ncol = dj1)
#for (i in 1:dj1) {imat[i, i] = 1}
imat = diag(dj1)
uvecs = matrix(rnorm(dj1 * (dj1 - dj2)), nrow = dj1)
wmatt = (imat - pa) %*% uvecs
aqt = qr(wmatt); wmat = qr.Q(aqt)
b0mat = xw0 %*% wmat
}
} else {
b0mat = xw0
inmat = diag(dim(xmat0)[2])
wmat = inmat
}
p0mat = xmat0 %*% wmat %*% solve(t(wmat) %*% qmat0 %*% wmat) %*% t(wmat) %*% t(xmat0)
#edf = sum(diag(p0mat)) + p - 1
#new: to find edf differently
#print (ps)
dp = -atil
#for (i in 1:nrow(dp)) {
# dpi = dp[i,,drop=F]
# dpi = dpi/sqrt(tcrossprod(dpi)[1])
# dp[i,]=dpi
#}
dp = t(dp)
imat = diag(nrow(qmat))
#print (dim(imat))
#print (dim(dp))
if (length(face) == 0) {
pmat = imat
} else {
smat = dp[,face,drop=FALSE]
pmat_polar = smat %*% solve(crossprod(smat), t(smat))
pmat = (imat-pmat_polar)
}
#print (dim(smat))
bigp = xmat%*%uinv%*%pmat%*%t(uinv)%*%t(xmat)
#print (pmat)
edf = sum(diag(bigp))
#inmat = matrix(0, nrow = n, ncol = n)
#diag(inmat) = 1
#sse1 = sum((yw - xw %*% ahat)^2)
#zcoefs = ahat[1:p]
#sse0 = sum((yw - zw %*% zcoefs)^2)
#new: more than gaussian
#zcoefs don't include shape = 17
thvecs = NULL
thvecs_ut = NULL
coef_add = 0
coef_ut = 0
coef_wp = ahat
if (pb > 0) {
#print (pb)
coef_add = ahat[1:pb]
coef_wp = ahat[-(1:pb)]
capl = ncol(xmat_add)
if (!is.null(xmat_add)){
#print (paste('capl: ', capl))
thvecs = matrix(0, nrow = capl, ncol = n)
ncon = 0
vcoef_add = coef_add[1:np_add]
#print (vcoef_add)
lconv = sum(shapes_add > 2 & shapes_add < 5 | shapes_add > 10 & shapes_add < 13)
if (lconv > 0) {
dcoefs = coef_add[-c(1:lconv)]
delta_add2 = delta_add[-c(1:lconv), ,drop = FALSE]
} else {
dcoefs = coef_add
delta_add2 = delta_add
}
for (i in 1:capl) {
#thvecs[i,] = t(delta_add[varlist_add == i,]) %*% coef_add[varlist_add == i]
thvecs[i,] = t(delta_add2[varlist_add == i,]) %*% dcoefs[varlist_add == i]
if (shapes_add[i] > 2 & shapes_add[i] < 5 | shapes_add[i] > 10 & shapes_add[i] < 13) {
ncon = ncon + 1
thvecs[i,] = thvecs[i,] + vcoef_add[ncon] * xmat_add[,i]
#print (vcoef_add[ncon])
}
}
#if (!is.null(idx_s)) {
if (length(idx_s) > 0) {
thvecs0 = thvecs
thvecs0[idx_s,] = thvecs[1:length(idx_s), ]
#if (!is.null(idx)) {
if (length(idx) > 0) {
thvecs0[idx,] = thvecs[(1+length(idx_s)):capl, ]
}
thvecs = thvecs0
}
}
if (!is.null(delta_ut)) {
#print (length(coef_add))
#print (nrow(delta_ut))
#print ((length(coef_add) - nrow(delta_ut) + 1):length(coef_add))
coef_ut = coef_add[(length(coef_add) - nrow(delta_ut) + 1):length(coef_add)]
thvecs_ut = t(delta_ut) %*% coef_ut
}
if (!is.null(thvecs_ut)) {
thvecs = rbind(thvecs, t(thvecs_ut))
}
}# else {coef_add = 0; coef_wp = ahat; thvecs = NULL}
zcoefs = NULL
if (!is.null(zmat)) {
zcoefs = ahat[(pb+1):(pb+p)]
}
#vcoefs include zcoefs and shape = 17, conv and conc
# if (np_add > 0) {
# vcoefs = ahat[c(1:np_add, (pb+1):(pb+p))]
# vmat = zw[,c(1:np_add, (pb+1):(pb+p)), drop=F]
# } else {
# vcoefs = zcoefs
# vmat = zw[,(pb+1):(pb+p), drop=F]
# }
#muvhat includes the weight part
# muvhat = muhat.fun(vmat %*% vcoefs, fml = family$family)
#sse1 = sum((yw - muhat)^2)
sse1 = sum((yw - xw %*% ahat)^2)
# sse0 = sum((yw - muvhat)^2)
#new use edf instead if (n - cpar * edf) < 0
# np = ncol(vmat)
np = 0
if (!is.null(zmat)) {
np = ncol(zmat)
}
#if ((n - np - cpar * edf) <= 0) {
if ((n - cpar * edf) <= 0) {
sig2hat = sse1 / edf
} else {
sig2hat = sse1 / (n - cpar * edf)
#print (sse1)
}
#print (paste('sig2hat', sig2hat))
if (p >= 1) {
#w2 = as.vector(w / deriv.fun(muhatkeep, fml = family$family))
inmat = diag(n)
#pm = one %*% solve(crossprod(one)) %*% t(one)
#covmat = solve(t(zmat[,(pb+1):(pb+p), drop=F]) %*% (inmat - p0mat + pm) %*% zmat[,(pb+1):(pb+p), drop=F])
#new:
# qmat0 = t(xw0) %*% xw0 + ps * t(dmat0) %*% dmat0
# umat0 = chol(qmat0)
# uinv0 = solve(umat0)
# atil0 = amat0 %*% uinv0
#
# dp0 = -t(atil0)
# imat0 = diag(nrow(qmat0))
# if (length(face) == 0) {
# pmat0 = imat0
# } else {
# smat0 = dp0[,face,drop=FALSE]
# pmat_polar0 = smat0 %*% solve(crossprod(smat0), t(smat0))
# pmat0 = (imat0-pmat_polar0)
# }
# bigp0 = xmat0%*%uinv0%*%pmat0%*%t(uinv0)%*%t(xmat0)
# zm = zmat[,(pb+1):(pb+p), drop=F]
# covmat = solve(t(zm) %*% (inmat - bigp0) %*% zm)
#test:
#one = 1:nrow(pmat)*0 + 1
#pm = one %*% solve(crossprod(one)) %*% t(one)
#print (dim(pmat))
#print (dim(pm))
mat1 = uinv %*% pmat %*% t(uinv) %*% t(xmat)
covmat0 = sig2hat * mat1 %*% t(mat1)
covmat = covmat0[(pb+1):(pb+p), (pb+1):(pb+p), drop=FALSE]
#print (covmat)
#if (wt.iter) {
# sez = sqrt(diag(covmat))
#} else {
#sez = sqrt(diag(covmat) * sig2hat)
sez = sqrt(diag(covmat))
#print (paste('sig:',sig2hat))
#print (sez)
#}
tz = zcoefs / sez
#print (zcoefs)
#print (tz)
#new use edf instead if (n - cpar * edf) < 0
if ((n - cpar * edf) <= 0) {
pz = 2 * (1 - pt(abs(tz), edf))
if (np > 1) {
warning ('Effective degrees of freedom is close to the number of observations! Inference about parametric covariates is not reliable!')
}
#print ('Check pz!')
} else {
pz = 2 * (1 - pt(abs(tz), n - cpar * edf))
#print (edf)
#print (cpar)
#print (pz)
}
}
# get unconstrained penalized estimator
#if (!wt.iter) {
# prmatu = xw %*% solve(qmat) %*% t(xw)
#new:
# etahatu = prmatu %*% yw
# muhatu = muhat.fun(etahatu, fml = family$family)
# sseu = sum((yw - muhatu)^2)
# edfu = sum(diag(prmatu))
#} else {
# if (is.null(w)) {
# w = 1:n*0 + 1
# }
# prior.w = w
# prmatu = xw %*% solve(qmat) %*% t(xw)
# nrep = 0
# muhatu = mean(y) + 1:n*0
# etahatu = linkfun(muhatu)
# diff = 1
# if (family$family == "binomial") {
# mdiff = abs(max(muhatu) - 1) > sm
# } else {mdiff = TRUE}
# while (diff > sm & mdiff & nrep < n^2) {
# nrep = nrep + 1
# oldmu = muhatu
# zhat = etahatu + (y - muhatu) * deriv.fun(muhatu, fml = family$family)
# w = as.vector(prior.w * (deriv.fun(muhatu, fml = family$family))^(-1))
# #b = solve(tvmat %*% vmat) %*% tvmat %*% zhat
# #etahat = xmat %*% b
# etahatu = prmatu %*% zhat
# muhatu = muhat.fun(etahatu, fml = family$family)
# diff = mean((muhatu - oldmu)^2)
# mdiff = abs(max(muhatu) - 1)
# if (family$family == "binomial") {
# mdiff = abs(max(muhatu) - 1) > sm
# } else {mdiff = TRUE}
# }
# sseu = sum((y - muhatu)^2)
# edfu = sum(diag(prmatu))
#}
#new: get cic
cic_val = NULL
if (is.null(w)) {
w = rep(1, n)
}
if (cic & nsim > 0) {
edfs = 1:nsim*0
if (!wt.iter) {
for (isim in 1:nsim) {
ysim = rnorm(n)
ysimw = ysim * sqrt(w)
cveci = t(uinv) %*% t(xw) %*% ysimw
ansi = coneA(cveci, atil, msg = FALSE)
phihati = ansi$thetahat
ahati = uinv %*% phihati
edfi = wps_getedf(ahati, sm, amat, amat0, xw0, xmat0, qmat0, np)
edfs[isim] = edfi
}
#cic = llh + log(2 * (mean(edfs) + np) / (n - np - 1.5 * mean(edfs)) + 1)
#cic = log(sse1) + log(2 * (mean(edfs) + np) / (n - np - 1.5 * mean(edfs)) + 1)
cic_val = llh + log(2 * (mean(edfs)) / (n - np - 1.5 * (mean(edfs) - np)) + 1)
} else {
if (family$family == "poisson") {
mu0 = mean(y)
} else {mu0 = NULL}
for (isim in 1:nsim) {
ysim = ysim.fun(n, mu0, fml = family$family)
etahat = etahat.fun(n, ysim, fml = family$family)
gr = gr.fun(ysim, etahat, weights = w, fml = family$family)
wt = wt.fun(ysim, etahat, n, weights = w, fml = family$family)
cvec = crossprod(xmat, (wt * etahat - gr))
qmat = t(xmat) %*% diag(wt) %*% xmat + ps * t(dmat) %*% dmat
qmat0 = t(xmat0) %*% diag(wt) %*% xmat0 + ps * t(dmat0) %*% dmat0
ans = qprog(qmat, cvec, amat, 1:nrow(amat)*0, msg = FALSE)
ahat = ans$thetahat
etahat = xmat %*% ahat
muhat = muhat.fun(etahat, fml = family$family)
diff = 1
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > 1e-8
} else {mdiff = TRUE}
nrep = 0
while (diff > sm & nrep < 100 & mdiff) {
oldmu = muhat
nrep = nrep + 1
gr = gr.fun(ysim, etahat, weights = w, fml = family$family)
wt = wt.fun(ysim, etahat, n, weights = w, fml = family$family)
cvec = crossprod(xmat, (wt * etahat - gr))
qmat = t(xmat) %*% diag(wt) %*% xmat + ps * t(dmat) %*% dmat
qmat0 = t(xmat0) %*% diag(wt) %*% xmat0 + ps * t(dmat0) %*% dmat0
ansi = qprog(qmat, cvec, amat, 1:nrow(amat)*0, msg = FALSE)
ahati = ansi$thetahat
etahat = xmat %*% ahati
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > 1e-8
} else {mdiff = TRUE}
}
edfi = wps_getedf(ahati, sm, amat, amat0, xw0, xmat0, qmat0, np)
edfs[isim] = edfi
}
#cic = llh + log(2 * (mean(edfs) + np) / (n - np - 1.5 * mean(edfs)) + 1)
cic_val = llh + log(2 * (mean(edfs)) / (n - np - 1.5 * (mean(edfs) - np)) + 1)
}
}
#print (edf)
#new: test for constant vs wps
#vmat = qr.Q(qr(t(atil)), complete = TRUE)[, -(1:(qr(t(atil))$rank)), drop = FALSE]
vmat = cbind(1:n*0+1)
if (!is.null(zmat)) {
vmat = cbind(vmat, zmat)
}
np = ncol(vmat)
if (!is.null(w)) {
pvmat = vmat %*% solve(crossprod(vmat), t(vmat))
} else {
vw = vmat
for (i in 1:nrow(vmat)) {
vw[i, ] = vmat[i, ] * sqrt(w[i])
}
pvmat = vmat %*% solve(crossprod(vw), t(vw))
}
#phihat0 = pvmat %*% cvec
#ahat0 = uinv %*% phihat0
#muhat0 = xmat %*% ahat0
muhat0 = pvmat %*% y
if (!is.null(w)) {
sse0 = sum(w * (y - muhat0)^2)
sse1 = sum(w * (y - muhat)^2)
} else {
sse0 = sum((y - muhat0)^2)
sse1 = sum((y - muhat)^2)
}
bval = (sse0 - sse1) / sse0
#print (bval)
#g = qr(amat)
#m = ncol(amat)
#dim0 = m - g$rank
#test = TRUE
pval = NULL
if (pvf) {
nloop = 200
sm = 1e-5
if (bval > sm) {
#bdist = 0:nloop*0
bdist = NULL
for (iloop in 1:nloop) {
#ysim = muhat0 + rnorm(n)
#new: add (sig2hat)^(1/2) when there's z
ysim = muhat0 + rnorm(n)*(sig2hat)^(1/2)
ysimw = ysim
if (!is.null(w)) {
ysimw = ysim * sqrt(w)
}
cveci = t(uinv) %*% t(xw) %*% ysimw
ansi = try(coneA(cveci, atil))
if (any(class(ansi) %in% 'try-error')) {
next
}
phi = ansi$thetahat
ah = uinv %*% phi
muh = xmat %*% ah
#phi0 = pvmat %*% cveci
#ah0 = uinv %*% phi0
#muh0 = xmat %*% ah0
#muh0 = pvmat %*% ysimw
muh0 = pvmat %*% ysim
if (!is.null(w)) {
sse0 = sum(w * (ysim - muh0)^2)
sse1 = sum(w * (ysim - muh)^2)
} else {
sse0 = sum((ysim - muh0)^2)
sse1 = sum((ysim - muh)^2)
}
bstat = (sse0 - sse1) / sse0
bdist = c(bdist, bstat)
#bdist[iloop] = bstat
}
pval = sum(bdist > bval)/nloop
} else {pval = 1}
}
ans = new.env()
ans$pval = pval
ans$bval = bval
#ans$k1 = k1
#ans$k2 = k2
for (ipr in 1:nprs) {
decri = decrs[[ipr]]
ktsi = kts[[ipr]]
k1 = ktsi[[1]]
k2 = ktsi[[2]]
if (decri[1]) {
k1 = -rev(k1)
}
if (decri[2]) {
k2 = -rev(k2)
}
ktsi[[1]] = k1
ktsi[[2]] = k2
kts[[ipr]] = ktsi
}
ans$kts = kts
ans$muhat = muhatkeep
ans$etahat = etahatkeep
#ans$muplot = mupl
#ans$muhatu = muhatu
#ans$muplotu = muplu
ans$gcv = sse1 / (1 - edf / n)^2
#ans$gcvu = sseu / (1 - edfu/n)^2
#ans$ssr = sse1
ans$sse1 = sse1
#ans$sse0 = sse0
ans$edf = edf
if (cic & nsim > 0) {
ans$edf0 = mean(edfs) #+ np
} else {ans$edf0 = np}
#ans$nz = amat %*% ahat
#ans$edfu = edfu
ans$coef_add = coef_add
ans$coef_ut = coef_ut
ans$coef_wp = coef_wp
ans$coefs = coefkeep
#ans$coefsu = solve(qmat) %*% t(xw) %*% yw
#include coef for one vector
#ans$zcoefs = ahat[1:p]
ans$zcoefs = zcoefs
ans$zmat = zmat
#ans$zmat_0 = zmat_0
ans$sig2hat = sig2hat
ans$delta = xmat
ans$pen = ps
ans$d0 = p + np_add
#print (paste('p: ', p))
ans$cpar = cpar
#ans$gcvus = gcvus
#ans$lambdas_pen = lambdas_pen
#if (p >= 2) {
if (p >= 1) {
ans$sez = sez
ans$pz = pz
ans$covmat = covmat
ans$tz = tz
} else {ans$sez = NULL; ans$pz = NULL; ans$covmat = NULL; ans$tz = NULL}
#print (sig2hat)
ans$cic = cic_val
ans$varlist = varlist
ans$etacomps = thvecs
#new:
ans$amat = amat
ans$dmat = dmat
#ans$vmat = vmat
return (ans)
}
####################################################################
#four monotonicity functions for warped-plane fit
#new: attr(xm, 'shape') are all changed into pairs of numbers because of testpar
#test more
####################################################################
s.incr.incr <- function(x1, x2, numknots = c(0, 0), knots = list(k1 = 0, k2 = 0), space = c("E", "E"))
{
cl <- match.call()
pars1 <- match.call()[2]
pars2 <- match.call()[3]
xm <- cbind(x1, x2)
attr(xm, "name") <- c(deparse(pars1$x1), deparse(pars2$x2))
attr(xm, "nm") <- c(deparse(pars1$x1), deparse(pars2$x2))
#attr(xm, "shape") <- "wps_ii"
attr(xm, "shape") <- c(1, 1)
attr(xm, "numknots") <- numknots
attr(xm, "knots") <- knots
attr(xm, "space") <- space
attr(xm, "decreasing") <- c(FALSE, FALSE)
attr(xm, "categ") <- "warp"
#class(xm) <- "warp"
#warp <<- TRUE
return (xm)
}
s.incr.decr <- function(x1, x2, numknots = c(0, 0), knots = list(k1 = 0, k2 = 0), space = c("E", "E"))
{
cl <- match.call()
pars1 <- match.call()[2]
pars2 <- match.call()[3]
xm <- cbind(x1, x2)
attr(xm, "name") <- c(deparse(pars1$x1), deparse(pars2$x2))
attr(xm, "nm") <- c(deparse(pars1$x1), deparse(pars2$x2))
#attr(xm, "shape") <- "wps_id"
attr(xm, "shape") <- c(1, 2)
attr(xm, "numknots") <- numknots
attr(xm, "knots") <- knots
attr(xm, "space") <- space
attr(xm, "decreasing") <- c(FALSE, TRUE)
attr(xm, "categ") <- "warp"
#warp <<- TRUE
#class(xm) <- "warp"
return (xm)
}
s.decr.incr <- function(x1, x2, numknots = c(0, 0), knots = list(k1 = 0, k2 = 0), space = c("E", "E"))
{
cl <- match.call()
pars1 <- match.call()[2]
pars2 <- match.call()[3]
xm <- cbind(x1, x2)
attr(xm, "name") <- c(deparse(pars1$x1), deparse(pars2$x2))
attr(xm, "nm") <- c(deparse(pars1$x1), deparse(pars2$x2))
#attr(xm, "shape") <- "wps_di"
attr(xm, "shape") <- c(2, 1)
attr(xm, "numknots") <- numknots
attr(xm, "knots") <- knots
attr(xm, "space") <- space
attr(xm, "decreasing") <- c(TRUE, FALSE)
attr(xm, "categ") <- "warp"
#warp <<- TRUE
#class(xm) <- "warp"
return (xm)
}
s.decr.decr <- function(x1, x2, numknots = c(0, 0), knots = list(k1 = 0, k2 = 0), space = c("E", "E"))
{
cl <- match.call()
pars1 <- match.call()[2]
pars2 <- match.call()[3]
xm <- cbind(x1, x2)
attr(xm, "name") <- c(deparse(pars1$x1), deparse(pars2$x2))
attr(xm, "nm") <- c(deparse(pars1$x1), deparse(pars2$x2))
#attr(xm, "shape") <- "wps_dd"
attr(xm, "shape") <- c(2, 2)
attr(xm, "numknots") <- numknots
attr(xm, "knots") <- knots
attr(xm, "space") <- space
attr(xm, "decreasing") <- c(TRUE, TRUE)
attr(xm, "categ") <- "warp"
#warp <<- TRUE
#class(xm) <- "warp"
return (xm)
}
###############################################################
#makedelta_wps: make delta to a pair of warped-plane variables#
###############################################################
makedelta_wps <- function(x1t, x2t, m1_0 = 0, m2_0 = 0, k1 = 0, k2 = 0, space = c("E", "E"), decreasing = c(FALSE, FALSE), interp = FALSE)
{
# x1 and x2 no need to sort
# if decreasing (all calculations done for doubly-increasing case)
n = length(x1t)
if (decreasing[1]) {
#print (k1 != 0)
x1 = -x1t
#if (!is.null(k1)) {
if (!all(k1 == 0)) {
m1 = length(k1); k1 = -k1[m1:1]
}
} else {x1 = x1t}
if (decreasing[2]) {
x2 = -x2t
#if (!is.null(k2)) {
if (!all(k2 == 0)) {
m2 = length(k2); k2 = -k2[m2:1]
}
} else {x2 = x2t}
# determine whether to use default knots or user-defined knots
# check if k1 and k2 > 1 elems
make1 = FALSE
#if (is.null(k1)) {
#if (k1 == 0) {
if (all(k1 == 0)) {
make1 = TRUE
} else if (min(k1) > min(x1) | max(k1) < max(x1)) {
warning ('Predictor should be within the range of the knots! User-defined knots not used!')
make1 = TRUE
# new: at least 4 kts?
}# else if (length(k1) < 4) {
# make1 = TRUE
#} else if (m1_0 >= 4) {
# make1 = TRUE
#}
make2 = FALSE
#if (is.null(k2)) {
#if (k2 == 0) {
if (all(k2 == 0)) {
make2 = TRUE
} else if (min(k2) > min(x2) | max(k2) < max(x2)) {
warning ('Predictor should be within the range of the knots! User-defined knots not used!')
make2 = TRUE
}# else if (length(k2) < 4) {
# make2 = TRUE
#} else if (m2_0 >= 4) {
# make2 = TRUE
#}
# add quantile part in it
if (make1) {
# new:
#print (m1_0 == 12L)? !is.integer(m1_0) not work
#print (m1_0)
if (m1_0 < 4 | round(m1_0, 0) != m1_0) {
#if (m1_0 < 4) {
if (m1_0 != 0) {
warning ('At least four knots should be used! Number of knots is re-defined!')
}
#m1 = 2 * round(n^(1/6)) + 4
#new:
#m1 = round(6*n^(1/6))
#m1 = round(4*n^(1/6))
m1 = round(5*n^(1/6))
#print (m1)
} else {m1 = m1_0}
if (space[1] == "Q") {
k1 = quantile(unique(x1), probs = seq(0, 1, length = m1), names = FALSE)
}
if (space[1] == "E") {
k1 = 0:(m1 - 1) / (m1 - 1) * (max(x1) - min(x1)) + min(x1)
#print (0:(m1 - 1) / (m1 - 1) * (max(x1) - min(x1)) + min(x1) )
#k1 = 0:(m1 - 1) / (m1 - 1)
}
#k1 = 0:(m1 - 1) / (m1 - 1) * (max(x1) - min(x1)) + min(x1)
} else { m1 = length(k1) }
if (make2) {
#new:
if (m2_0 < 4 | round(m2_0, 0) != m2_0) {
if (m2_0 != 0) {
warning ('At least four knots should be used! Number of knots is re-defined!')
}
#m2 = 2 * round(n^(1/6)) + 4
#m2 = round(6*n^(1/6))
#m2 = round(4*n^(1/6))
m2 = round(5*n^(1/6))
} else {m2 = m2_0}
if (space[2] == "Q") {
k2 = quantile(unique(x2), probs = seq(0, 1, length = m2), names = FALSE)
}
if (space[2] == "E") {
k2 = 0:(m2 - 1) / (m2 - 1) * (max(x2) - min(x2)) + min(x2)
#k2 = 0:(m2 - 1) / (m2 - 1)
}
#k2 = 0:(m2 - 1) / (m2 - 1) * (max(x2) - min(x2)) + min(x2)
} else { m2 = length(k2) }
## check to see if empty knot intervals
#new: if it's for prediction, then skip
if (!interp) {
rm1 = k1[m1]; rm2 = k2[m2]
keep = 1:m1 > 0
for (i in 2:m1) {
if (sum(x1 >= k1[i-1] & x1 < k1[i]) == 0) {
keep[i] = FALSE
}
}
k1 = k1[keep]; m1 = length(k1); k1[m1] = rm1
keep = 1:m2 > 0
for (i in 2:m2) {
if (sum(x2 >= k2[i-1] & x2 < k2[i]) == 0) {
keep[i] = FALSE
}
}
k2 = k2[keep]; m2 = length(k2); k2[m2] = rm2
}
# make the basis functions
#b1 = matrix(0, nrow = n, ncol = m1)
#b2 = matrix(0, nrow = n, ncol = m2)
#for (i in 2:(m1 - 1)) {
# i1 = x1 >= k1[i-1] & x1 <= k1[i]
# b1[i1, i] = (x1[i1] - k1[i-1]) / (k1[i] - k1[i-1])
# i2 = x1 > k1[i] & x1 <= k1[i+1]
# b1[i2, i] = (k1[i+1] - x1[i2]) / (k1[i+1] - k1[i])
#}
# i1 = x1 >= k1[1] & x1 <= k1[2]
# b1[i1, 1] = (k1[2] - x1[i1]) / (k1[2] - k1[1])
# i2 = x1 > k1[m1-1] & x1 <= k1[m1]
# b1[i2, m1] = (x1[i2] - k1[m1-1]) / (k1[m1] - k1[m1-1])
#
# for (i in 2:(m2 - 1)) {
# i1 = x2 >= k2[i-1] & x2 <= k2[i]
# b2[i1, i] = (x2[i1] - k2[i-1]) / (k2[i] - k2[i-1])
# i2 = x2 > k2[i] & x2 <= k2[i+1]
# b2[i2, i] = (k2[i+1] - x2[i2]) / (k2[i+1] - k2[i])
# }
# i1 = x2 >= k2[1] & x2 <= k2[2]
# b2[i1, 1] = (k2[2] - x2[i1]) / (k2[2] - k2[1])
# i2 = x2 > k2[m2-1] & x2 <= k2[m2]
# b2[i2, m2] = (x2[i2] - k2[m2-1]) / (k2[m2] - k2[m2-1])
# ## design matrix
# xmat0 = matrix(nrow = n, ncol = m1 + m2 - 1 + (m1 - 1) * (m2 - 1))
# xmat0[ ,1] = 1:n*0 + 1
# xmat0[ ,2:m1] = b1[ ,2:m1]
# xmat0[ ,(m1 + 1):(m1 + m2 - 1)] = b2[ ,2:m2]
# for (i in 1:(m1 - 1)) {
# xmat0[ ,(m1 + m2 + (i - 1) * (m2 - 1)):(m1 + m2 - 1 + i * (m2 - 1))] = b1[ ,i + 1] * b2[ ,2:m2]
# }
#if (dim(zmat)[2] > 1) {
# xmat = cbind(zmat, xmat0[ ,2:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))])
#} else {xmat = xmat0}
#bmat = xmat0[ ,2:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))]
# ignore the zmat for now
# xmat = xmat0
# columns of delta are edges, different from other make_delta in cgam
bmat = matrix(0, nrow=n, ncol=m1*m2)
for(i in 1:(m1-1)){
for(j in 1:(m2-1)){
ii=x1>=k1[i]&x1<=k1[i+1]&x2>=k2[j]&x2<=k2[j+1]
#rg_ij = (k1[i+1]-k1[i])*(k2[j+1]-k2[j])
bmat[ii,m2*(i-1)+j]=(k1[i+1]-x1[ii])*(k2[j+1]-x2[ii])/((k1[i+1]-k1[i])*(k2[j+1]-k2[j]))
bmat[ii,m2*(i-1)+j+1]=(k1[i+1]-x1[ii])*(x2[ii]-k2[j])/((k1[i+1]-k1[i])*(k2[j+1]-k2[j]))
bmat[ii,m2*i+j]=(x1[ii]-k1[i])*(k2[j+1]-x2[ii])/((k1[i+1]-k1[i])*(k2[j+1]-k2[j]))
bmat[ii,m2*i+j+1]=(x1[ii]-k1[i])*(x2[ii]-k2[j])/((k1[i+1]-k1[i])*(k2[j+1]-k2[j]))
}
}
ans = new.env()
ans$delta = bmat
ans$k1 = k1
ans$k2 = k2
return (ans)
#attr(delta, "shape") = "warp"
#delta
}
##############################
#penalty interpolation
##############################
make_pen = function(n, xw=NULL, xmat=NULL, dmat=NULL, y=NULL, amat=NULL, gcv=FALSE) {
if (!gcv) {
if (n <= 100) {
lambda = 0.06
}
if (n >= 5000) {
lambda = 0.026
}
if (n > 100 & n < 5000) {
ns = c(1, 2, 4, 8, 10, 20, 50)*100
lams = c(6, 5, 4, 3.4, 3.2, 2.8, 2.6)/100
diff_vec = sign(n - ns)
st = rev(which(diff_vec == 1L))[1]
ed = which(diff_vec == -1L)[1]
my_line = function(xp = NULL, y, x, end=2, start=1) {
slope = NULL
intercept = NULL
yp = NULL
slope = (y[end] - y[start]) / (x[end] - x[start])
intercept = y[end] - slope * x[end]
yp = intercept + slope * xp
return (yp)
}
yvec = c(lams[st], lams[ed])
xvec = c(ns[st], ns[ed])
lambda = my_line(xp = n, y = yvec, x = xvec)
}
} else {
#use gcv to find lambda
#ng = 20
#lams = seq(1e-4, 1, length=20)
#lams = 2^(1:ng)
#lams = 2*lams/max(lams)
#gcvs = 1:ng*0
ng = 9
lams = 2^(0:8)
lams = lams/2^8/n^(1/3)
#print (lams)
gcvs = 1:ng*0
for(i in 1:ng) {
pen = lams[i]
qv0 = crossprod(xw)
dv0 = crossprod(dmat)
qv = qv0 + pen * dv0
cv = crossprod(xw, y)
umat = chol(qv)
uinv = solve(umat)
atil = amat %*% uinv
cvec = t(uinv) %*% t(xw) %*% y
ansi = coneA(cvec, atil, msg = FALSE)
face = ansi$face
phihat = ansi$thetahat
ahat = uinv %*% phihat
muhat = xmat %*% ahat
sse = sum((y-muhat)^2)
dp = -atil
dp = t(dp)
imat = diag(nrow(qv))
if (length(face) == 0) {
pm = imat
} else {
smat = dp[,face,drop=FALSE]
pmat_polar = smat %*% solve(crossprod(smat), t(smat))
pm = (imat-pmat_polar)
}
bigp = xmat%*%uinv%*%pm%*%t(uinv)%*%t(xmat)
#tst = bigp%*%y
#print (all.equal(tst, muhat))
edfi = sum(diag(bigp))
#edfi = sum(diag(xw %*% solve(qv) %*% t(xw)))
gcvi = sse/(1-edfi/n)^2
gcvs[i] = gcvi
#print (sse)
}
#plot(lams, gcvs, type='o')
#lambda = (lams[which.min(gcvs)])[1]
lambda = min(lams[gcvs == min(gcvs)])
}
return (lambda)
}
#######################
#amat and penalty bmat#
#######################
makeamat_wps <- function(kts, nprs) {
#if (nprs >= 1) {
amat_lst = list()
dmat_lst = list()
varlist = NULL
for (ipr in 1:nprs) {
ktsi = kts[[ipr]]
k1 = ktsi[[1]]
k2 = ktsi[[2]]
m1 = length(k1)
m2 = length(k2)
amat = matrix(0, nrow = 2*m1*m2 - m1 - m2, ncol = m1*m2)
amat[1, 2] = 1
amat[2, m1 + 1] = 1
irow = 2
for (i2 in 2:m2) {
irow = irow+1
amat[irow, 2] = 1; amat[irow, m1 + m2 + i2 - 2] = 1
}
for (i1 in 2:m1) {
irow = irow + 1
amat[irow, m1 + 1] = 1; amat[irow, m1 + m2 + (i1 - 2) * (m2 - 1)] = 1
}
for (i1 in 2:(m1 - 1)) {
irow = irow + 1
amat[irow, i1] = -1; amat[irow, i1 + 1] = 1
}
for (i2 in 2:(m2 - 1)) {
irow = irow + 1
amat[irow, m1 + i2 - 1] = -1
amat[irow, m1 + i2] = 1
}
for (i1 in 2:(m1 - 1)) {
for (i2 in 2:m2) {
irow = irow + 1
amat[irow, i1] = -1
amat[irow, i1 + 1] = 1
amat[irow, m1 + m2 - 2 + (i1 - 2) * (m2 - 1) + i2] = -1
amat[irow, m1 + m2 - 2 + (i1 - 1) * (m2 - 1) + i2] = 1
}
}
for (i2 in 2:(m2 - 1)) {
for (i1 in 2:m1) {
irow = irow + 1
amat[irow, m1 + i2 - 1] = -1
amat[irow, m1 + i2] = 1
amat[irow, m1 + m2 - 2 + (i1 - 2) * (m2 - 1) + i2] = -1
amat[irow, m1 + m2 - 1 + (i1 - 2) * (m2 - 1) + i2] = 1
}
}
if (ipr > 1) {
amat = amat[,-1]
}
amat_lst[[ipr]] = amat
# penalty matrix
dmat = matrix(0, nrow = 2 * (m1 * m2 - m1 - m2), ncol = m1 * m2)
# by row
irow = 1
dmat[irow, 2] = -2; dmat[irow, 3] = 1
for (i in 2:(m1 - 2)) {
irow = irow + 1
dmat[irow, i] = 1; dmat[irow, i + 1] = -2; dmat[irow, i + 2] = 1
}
for (ik2 in 2:m2) {
irow = irow + 1
dmat[irow, 2] = -2; dmat[irow, 3] = 1
dmat[irow, m1 + m2 - 1 + ik2 - 1] = -2
dmat[irow, m1 + 2 * m2 + ik2 - 3] = 1
for (ik1 in 2:(m1 - 2)) {
irow = irow + 1
dmat[irow, ik1] = 1; dmat[irow, ik1 + 1] = -2; dmat[irow, ik1 + 2] = 1
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 2) + ik2 - 1] = 1
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 1) + ik2 - 1] = -2
dmat[irow, m1 + m2 - 1 + (m2 - 1) * ik1 + ik2 - 1] = 1
}
}
# by col
irow = irow + 1
dmat[irow, m1 + 1] = -2; dmat[irow, m1 + 2] = 1
for (i in 2:(m2 - 2)) {
irow = irow + 1
dmat[irow, m1 + i - 1] = 1; dmat[irow, m1 + i] = -2; dmat[irow, m1 + i + 1] = 1
}
for (ik1 in 2:m1) {
irow = irow + 1
dmat[irow, m1 + 1] = -2; dmat[irow, m1 + 2] = 1
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 2) + 1] = -2
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 2) + 2] = 1
for (ik2 in 2:(m2 - 2)) {
irow = irow + 1
dmat[irow, m1 + ik2 - 1] = 1; dmat[irow, m1 + ik2] = -2; dmat[irow, m1 + ik2 + 1] = 1
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 2) + ik2 - 1] = 1
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 2) + ik2] = -2
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 2) + ik2 + 1] = 1
}
}
if (ipr > 1) {
dmat = dmat[,-1]
}
#Dmat = cbind(Dmat, dmat)
dmat_lst[[ipr]] = dmat
if (ipr > 1) {
#no constant for the 2nd pair
vari = 1:(m1*m2-1)*0 + ipr
} else {
vari = 1:m1*m2*0 + ipr
}
varlist = c(varlist, vari)
}
amat = as.matrix(bdiag(amat_lst))
#dmat = Dmat
dmat = as.matrix(bdiag(dmat_lst))
ans = list(amat = amat, dmat = dmat, varlist = varlist)
return (ans)
#}
}
#################
#new coef method#
#################
coef.cgam <- function(object,...) {
ans <- object$coefs
ans
}
coef.wps <- function(object,...) {
ans <- object$coefs
ans
}
coef.trispl <- function(object,...) {
ans <- object$coefs
ans
}
coef.cgam.polr <- function(object,...) {
ans <- object$coefs
ans
}
###################
#new fitted method#
###################
fitted.cgam <- function(object,...) {
ans <- object$muhat
ans
}
fitted.wps <- function(object,...) {
ans <- object$muhat
ans
}
fitted.trispl <- function(object,...) {
ans <- object$muhat
ans
}
#fitted.cgam.polr <- function(object,...) {
# ans <- object$muhat
# ans
#}
fitted.cgam.polr <- function(object,...) {
a <- object$zeta
eta <- object$muhat
lev <- object$lev
nc <- length(a) + 1
n <- length(eta)
ps <- matrix(0, nrow = nc, ncol = n)
for (i in 1:nc) {
if (i == 1) {
ps[i,] <- pfun(a[1] - eta)
} else if (i == nc) {
ps[i,] <- 1 - pfun(a[nc-1] - eta)
} else {
ps[i,] <- pfun(a[i] - eta) - pfun(a[i-1] - eta)
}
}
ps <- t(ps)
dimnames(ps) <- list(1:n, lev)
return (ps)
}
#############################
#shape selection part
#############################
#get(x = "s", pos = "package:cgam")
#new: add npop; per.mutate
ShapeSelect <- function(formula, family = gaussian, cpar = 2, data = NULL, weights = NULL, npop = 200, per.mutate = 0.05, genetic = FALSE) {
#if (exists("s", parent.frame()) & class(get("s", envir = parent.frame())) == "function") {
if (exists("s", parent.frame()) & inherits(get("s", envir = parent.frame()), "function")) {
if (!identical(get("s", envir = parent.frame()), cgam::s)) {
assign("s", cgam::s, envir = parent.frame())
}
}
cl <- match.call()
if (is.character(family))
family <- get(family, mode = "function", envir = parent.frame())
if (is.function(family))
family <- family()
if (is.null(family$family))
stop("'family' not recognized!")
mf <- match.call(expand.dots = FALSE)
m <- match(c("formula", "data"), names(mf), 0L)
mf <- mf[c(1L, m)]
mf[[1L]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
ynm <- names(mf)[1]
mt <- attr(mf, "terms")
y <- model.response(mf, "any")
if (family$family == "binomial") {
#if (class(y) == "factor") {
if(inherits(y, "factor")){
y <- ifelse(y == levels(y)[1], 0, 1)
}
#new: test
#if (class(y) == "character") {
if(inherits(y, "character")){
y <- ifelse(factor(y) == levels(factor(y))[1], 0, 1)
}
}
#print (head(y))
shpsx <- list(); shpsz <- list(); shpst <- list(); shpsvx <- NULL
ix <- 1; iz <- 1; itr <- 1; sel <- FALSE
xmat <- NULL; xnms <- NULL
vxmat <- NULL; vxnms <- NULL
zmat <- NULL; znms <- NULL; zfacs <- NULL
vzmat <- NULL; vznms <- NULL; vzfacs <- NULL
trmat <- NULL; trnms <- NULL; vtrmat <- NULL; vtrnms <- NULL
for (i in 2:ncol(mf)) {
if (!is.null(attributes(mf[, i])$type)) {
if (attributes(mf[, i])$type == "fac" | attributes(mf[, i])$type == "lin") {
if (attributes(mf[, i])$type == "fac") {
zfacs <- c(zfacs, TRUE)
} else {
#if (is.character(mf[,i])) {
#mf[,i] = ifelse(factor(mf[,i]) == levels(factor(mf[,i]))[1], 0, 1)
# nm <- attributes(mf[,i])$nm
# mf[,i] <- ifelse(factor(mf[,i]) == levels(factor(mf[,i]))[1], 0, 1)
# attr(mf[,i], "type") <- "lin"
# attr(mf[,i], "shape") <- c(0, 1)
# attr(mf[,i], "nm") <- nm
# zfacs <- c(zfacs, TRUE)
#} else {
zfacs <- c(zfacs, FALSE)
#}
}
zmat <- cbind(zmat, mf[, i])
znms <- c(znms, attributes(mf[, i])$nm)
shpsz[[iz]] <- attributes(mf[, i])$shape
iz <- iz + 1
sel <- TRUE
}
#if (attributes(mf[, i])$type == "lin") {
# zfacs <- c(zfacs, FALSE)
# zmat <- cbind(zmat, mf[, i])
#temp
#znms <- c(znms, names(mf)[i])
# znms <- c(znms, attributes(mf[, i])$nm)
# shpsz[[iz]] <- c(0, 1)
# iz <- iz + 1
#}
if (attributes(mf[, i])$type == "nparam") {
xmat <- cbind(xmat, mf[, i])
xnms <- c(xnms, attributes(mf[, i])$nm)
shpsx[[ix]] <- attributes(mf[, i])$shape
ix <- ix + 1
sel <- TRUE
}
#if (attributes(mf[, i])$type == "ord.tree") {
if (attributes(mf[, i])$type == "tree") {
trmat <- cbind(trmat, mf[, i])
trnms <- c(trnms, attributes(mf[, i])$nm)
shpst[[itr]] <- attributes(mf[, i])$shape
itr <- itr + 1
sel <- TRUE
}
} else {
if (is.numeric(attributes(mf[, i])$shape)) {
shpsvx <- c(shpsvx, attributes(mf[, i])$shape)
vxmat <- cbind(vxmat, mf[, i])
vxnms <- c(vxnms, attributes(mf[, i])$nm)
} else if (is.character(attributes(mf[, i])$shape)) {
if (attributes(mf[, i])$shape == "tree") {
vtrmat <- cbind(vtrmat, mf[, i])
vtrnms <- c(vtrnms, attributes(mf[, i])$nm)
}
} else {
if (is.factor(mf[, i])) {
vzfacs <- c(vzfacs, TRUE)
} else {
vzfacs <- c(vzfacs, FALSE)
}
vzmat <- cbind(vzmat, mf[, i])
#temp
vznms <- c(vznms, names(mf)[i])
}
}
}
if (!sel) {
stop ("No variable to be selected! Use cgam instead!")
}
if (!is.null(xmat)) {
capl <- ncol(xmat)
bx <- sapply(shpsx, function(x) length(x))
xnum <- rev(cumprod(bx))[1]
} else {capl <- 0; xnum <- 1}
if (!is.null(zmat)) {
capk <- ncol(zmat)
znum <- 2^capk
} else {capk <- 0; znum <- 1}
if (!is.null(trmat)) {
capt <- ncol(trmat)
trnum <- 3^capt
} else {capt <- 0; trnum <- 1}
nmod <- xnum * znum * trnum
tm <- 0
if (genetic) {
# call GA
print ("Go genetic algorithm!")
ptm <- proc.time()
ans <- ConstrGA(y, xmat, zmat, trmat, family = family, shpsx = shpsx, shpsvx = shpsvx, shpsz = shpsz, shpst = shpst, cpar = cpar, nmod = nmod, zfacs = zfacs, weights = weights, vzmat = vzmat, vzfacs = vzfacs, vxmat = vxmat, vtrmat = vtrmat, npop = npop, per.mutate = per.mutate)
tm <- proc.time() - ptm
} else {
if (nmod <= 5e+2) {
print ("Go through models one by one!")
Sys.sleep(1)
ptm <- proc.time()
ans <- ConstrALL(y, xmat, zmat, trmat, family = family, shpsx = shpsx, shpsvx = shpsvx, shpsz = shpsz, shpst = shpst, cpar = cpar, zfacs = zfacs, weights = weights, vzmat = vzmat, vzfacs = vzfacs, vxmat = vxmat, vtrmat = vtrmat)
tm <- tm + proc.time() - ptm
#could go one-by-one, but will suggest genetic
} else if (nmod > 5e+2 & nmod <= 1e+6) {
print ("Estimating the time of one fit!")
ptm <- proc.time()
invisible(ConstrGA(y, xmat, zmat, trmat, family = family, shpsx = shpsx, shpsvx = shpsvx, shpsz = shpsz, shpst = shpst, cpar = cpar, nmod = nmod, zfacs = zfacs, time.est = TRUE, weights = weights, vzmat = vzmat, vzfacs = vzfacs, vxmat = vxmat, vtrmat = vtrmat, npop = npop, per.mutate = per.mutate))
tm <- proc.time() - ptm
print (paste("Total time of one fit is roughly", round(tm[3], 1), "seconds"))
if (round(tm[3] * nmod/60^2) > 1) {
tm2 <- paste(round(tm[3] * nmod/60^2), "hours")
} else {tm2 <- paste(round(tm[3] * nmod/60), "minutes")}
msg <- paste("Number of all models is", nmod, "and the time for all fits is roughly", tm2, ". Go one by one?")
res <- dlgMessage(msg, "yesno")$res
if (res == "yes") {
print ("Go one by one!")
ptm <- proc.time()
ans <- ConstrALL(y, xmat, zmat, trmat, family = family, shpsx = shpsx, shpsvx = shpsvx, shpsz = shpsz, shpst = shpst, cpar = cpar, zfacs = zfacs, weights = weights, vzmat = vzmat, vzfacs = vzfacs, vxmat = vxmat, vtrmat = vtrmat)
tm <- proc.time() - ptm
} else {
print ("Go genetic!")
ptm <- proc.time()
ans <- ConstrGA(y, xmat, zmat, trmat, family = family, shpsx = shpsx, shpsvx = shpsvx, shpsz = shpsz, shpst = shpst, cpar = cpar, nmod = nmod, zfacs = zfacs, weights = weights, vzmat = vzmat, vzfacs = vzfacs, vxmat = vxmat, vtrmat = vtrmat, npop = npop, per.mutate = per.mutate)
tm <- proc.time() - ptm
}
#too many models or memory problem
} else {
print ("Go genetic! Too many models!")
ptm <- proc.time()
ans <- ConstrGA(y, xmat, zmat, trmat, family = family, shpsx = shpsx, shpsvx = shpsvx, shpsz = shpsz, shpst = shpst, cpar = cpar, nmod = nmod, zfacs = zfacs, weights = weights, vzmat = vzmat, vzfacs = vzfacs, vxmat = vxmat, vtrmat = vtrmat, npop = npop, per.mutate = per.mutate)
tm <- tm + proc.time() - ptm
}
}
#print (vznms)
colnames(ans$pop2)[1:(capl+capk+capt)] = c(xnms, znms, trnms)
rslt <- list(pop = ans$pop2, top = ans$pop2[1,], fitness = ans$fitness, tm = tm, xnms = xnms, znms = znms, trnms = trnms, zfacs = zfacs, mxf = ans$mxf, mnf = ans$mnf, GA = ans$GA, vzcat = ans$vzcat, vzmat = vzmat, shpsx = shpsx, vxnms = vxnms, vznms = vznms, vtrnms = vtrnms)
form <- make_form(pvec = ans$pop2[1, 1:(capl+capk+capt)], pnms = colnames(ans$pop2)[1:(capl+capk+capt)], ynm = ynm, zfacs = zfacs, vznms = vznms, vxnms = vxnms, shpsvx = shpsvx, vtrnms = vtrnms)
fm <- form$fm
#print (fm)
zps <- form$zps
if (is.null(fm)) {
print ('No predictor is chosen')
best.fit <- NULL
} else {
best.fit <- cgam(formula = fm, nsim = 0, family = family, cpar = cpar, data = data, weights = weights)
rslt$best.fit <- best.fit
rslt$fm <- fm
id_noflat <- which(ans$pop[1, 1:capl, drop = FALSE] != 0)
if (length(id_noflat) > 1) {
msg <- paste("A perspective plot of the best fit?")
res <- dlgMessage(msg, "yesno")$res
if (res == "yes") {
if (is.null(zps)) {
plotpersp(best.fit)
} else {plotpersp(best.fit, categ = zps[1])}
}
}
}
rslt$best.fit <- best.fit
rslt$call <- cl
class(rslt) <- "shapeselect"
return (rslt)
}
######################
#extract the best fit#
######################
#' Extract the Best Fit Returned by the ShapeSelect Routine
#'
#' This is a subroutine that only works for the `ShapeSelect` routine.
#' It returns an object of the `cgam` class given the variables and their shapes
#' chosen by the `ShapeSelect` routine.
#'
#' @param x An object of the `ShapeSelect` class.
#'
#' @return The best fit returned by the `ShapeSelect` routine, which is an object of class `cgam`.
#'
#' @author Xiyue Liao
#'
#' @examples
#' \dontrun{
#' library(MASS)
#' data(Rubber)
#'
#' # Perform variable and shape selection with four possible shapes:
#' # increasing, decreasing, convex, and concave
#' ans <- ShapeSelect(loss ~ shapes(hard, set = c("incr", "decr", "conv", "conc")) +
#' shapes(tens, set = c("incr", "decr", "conv", "conc")),
#' data = Rubber, genetic = TRUE)
#'
#' # Extract the best fit (a cgam object)
#' bf <- best.fit(ans)
#' class(bf)
#' plotpersp(bf)
#' }
#'
#' @seealso \code{\link{cgam}}, \code{\link{ShapeSelect}}
#' @keywords best fit of the ShapeSelect routine
#' @export
best.fit <- function(x) {
if (!inherits(x, "shapeselect")) {
stop("best.fit only works for an object of the ShapeSelect routine!")
}
object <- x$best.fit
return (object)
}
##########################################
#new symbolic routine #
#s(): shape-restricted for genetic only #
#keep all 17 one shape routines for cgam#
#########################################
shapes <- function(x, set = "s.9")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- deparse(pars$x)
if (is.numeric(set)) {
if (min(set) >= 0 & max(set) <= 16) {
#shps <- c(0, set)
shps <- set
shps <- unique(sort(shps))
#attr(x, "char") <- NULL
} else {stop ("Shape values for shape-restricted variables can only be between 0 and 16!")}
attr(x, "type") <- "nparam"
} else {
attr(x, "type") <- "nparam"
if (identical(set, "s.5")) {
shps <- c(0, 9:12)
} else if (identical(set, "s.9")) {
shps <- c(0, 9:16)
} else if (identical(set, "ord.5")) {
shps <- c(0, 1:4)
} else if (identical(set, "ord.9")) {
shps <- c(0, 1:8)
#print (shps)
} else if (identical(set, "tree")) {
#shps <- c(0, "tree", "unordered")
shps <- c(0, 1, 2)
attr(x, "type") <- "tree"
} else {
lshps <- length(set)
shps <- unique(sort(unname(sapply(set, CharToShape))))
}
}
attr(x, "nm") <- deparse(pars$x)
attr(x, "shape") <- shps
x
}
######################
#choose z as factors
######################
in.or.out <- function(z)
{
cl <- match.call()
pars <- match.call()[-1]
attr(z, "nm") <- deparse(pars$z)
if (is.factor(z)) {
attr(z, "type") <- "fac"
} else {attr(z, "type") <- "lin"}
#shps <- c(0, 1)
attr(z, "shape") <- c(0, 1)
z
}
#####################
#make a cgam formula#
#####################
make_form <- function(pvec = NULL, pnms = NULL, ynm = NULL, zfacs = NULL, vznms = NULL, vxnms = NULL, shpsvx = NULL, vtrnms = NULL) {
fm <- NULL
zps <- NULL
zi <- 1
vs <- NULL
rm <- c("flat", "out")
pvec <- apply(as.matrix(pvec, nrow = 1), 2, as.character)
if (all(pvec %in% rm)) {
rslt <- list(fm = fm, zps = zps)
#return (rslt)
} else {
if (any(pvec %in% rm)) {
id_rm <- which(pvec %in% rm)
pvec <- pvec[-id_rm]
pnms <- pnms[-id_rm]
}
if (as.character(pvec[1]) == "in") {
fm0 <- pnms[1]
zps <- c(zps, fm0)
zi <- zi + 1
#vs <- c(vs, pnms[1])
} else if (as.character(pvec[1]) == "unordered") {
fm0 <- paste("factor(", pnms[1], ")", sep = "")
zps <- c(zps, fm0)
#vs <- c(vs, pnms[1])
} else {
fm0 <- paste(as.character(pvec[1]), "(" , pnms[1], ")" , sep = "")
}
vs <- c(vs, pnms[1])
if (length(pvec) > 1) {
#zi only works for zfacs, not tree unordered case
#zi <- 1
for (i in 2:length(pvec)) {
#if (as.character(pvec[i]) == "flat") {
#not include the x
# next
#} else
if (as.character(pvec[i]) == "in") {
#if (zfacs[zi]) {
# fi <- paste("factor(", pnms[i], ")", sep = "")
#} else {fi <- pnms[i]}
fi <- pnms[i]
zps <- c(zps, fi)
zi <- zi + 1
} else if (as.character(pvec[i]) == "unordered") {
fi <- paste("factor(", pnms[i], ")", sep = "")
#fi <- pnms[i]
zps <- c(zps, fi)
} else {
#should work with tree?
fi <- paste(as.character(pvec[i]), "(" , pnms[i], ")" , sep = "")
}
fm0 <- paste(fm0, fi, sep = "+")
}
}
if (!is.null(vxnms)) {
lvx <- length(vxnms)
for (i in 1:lvx) {
#fi <- vxnms[i]
pvi <- ShapeToChar(shpsvx[i], tag = "x")
fi <- paste(pvi, "(" , vxnms[i], ")" , sep = "")
fm0 <- paste(fm0, fi, sep = "+")
}
}
if (!is.null(vznms)) {
lvz <- length(vznms)
for (i in 1:lvz) {
fi <- vznms[i]
zps <- c(zps, fi)
fm0 <- paste(fm0, fi, sep = "+")
}
}
if (!is.null(vtrnms)) {
lvt <- length(vtrnms)
for (i in 1:lvt) {
fi <- paste("tree", "(" , vtrnms[i], ")" , sep = "")
fm0 <- paste(fm0, fi, sep = "+")
}
}
fm <- as.formula(paste(ynm, "~", fm0, sep = ""))
rslt <- list(fm = fm, zps = zps)
}
return (rslt)
}
###################
#genetic algorithm#
###################
ConstrGA = function(y, xmat, zmat, trmat, family = gaussian, shpsx = NULL, shpsvx = NULL, shpsz = NULL, shpst = NULL, cpar = 1.2, nmod = 2e+4, zfacs = NULL, time.est = FALSE, weights = NULL, vzmat = NULL, vzfacs = NULL, vxmat = NULL, vtrmat = NULL, npop = NULL, per.mutate = NULL) {
#linkfun = family$linkfun
cicfamily = CicFamily(family)
linkfun = cicfamily$linkfun
llh.fun = cicfamily$llh.fun
etahat.fun = cicfamily$etahat.fun
gr.fun = cicfamily$gr.fun
wt.fun = cicfamily$wt.fun
zvec.fun = cicfamily$zvec.fun
muhat.fun = cicfamily$muhat.fun
ysim.fun = cicfamily$ysim.fun
deriv.fun = cicfamily$deriv.fun
dev.fun = cicfamily$dev.fun
#print (head(xmat))
#print (head(zmat))
#print (head(y))
n = length(y)
#sm = 1e-7
capl = length(xmat) / n
if (capl < 1) {capl = 0}
if (round(capl, 8) != round(capl, 1)) {
stop ("Incompatible dimensions for xmat!")
}
#check!
if (capl > 0) {
for(i in 1:capl) {
xmat[,i] = (xmat[,i] - min(xmat[,i])) / (max(xmat[,i]) - min(xmat[,i]))
#xmat[,i] = (xmat[,i] - mean(xmat[,i])) / sd(xmat[,i])
#xmat[,i] = xmat[,i] / sd(xmat[,i])
}
}
caplv = length(vxmat) / n
if (caplv < 1) {caplv = 0}
if (round(caplv, 8) != round(caplv, 1)) {
stop ("Incompatible dimensions for xmat!")
}
#new:
if (caplv > 0) {
for(i in 1:caplv) {
vxmat[,i] = (vxmat[,i] - min(vxmat[,i])) / (max(vxmat[,i]) - min(vxmat[,i]))
#vxmat[,i] = (vxmat[,i] - mean(vxmat[,i])) / sd(vxmat[,i])
#vxmat[,i] = vxmat[,i] / sd(vxmat[,i])
}
}
capk = length(zmat) / n
if (capk < 1) {capk = 0}
if (round(capk, 8) != round(capk, 1)) {
stop ("Incompatible dimensions for zmat!")
}
capkv = length(vzmat) / n
if (capkv < 1) {capkv = 0}
if (round(capkv, 8) != round(capkv, 1)) {
stop ("Incompatible dimensions for vzmat!")
}
capt = length(trmat) / n
if (capt < 1) {capt = 0}
if (round(capt, 8) != round(capt, 1)) {
stop ("Incompatible dimensions for trmat!")
}
captv = length(vtrmat) / n
if (captv < 1) {captv = 0}
if (round(captv, 8) != round(captv, 1)) {
stop ("Incompatible dimensions for trmat!")
}
#nrep=0
################################################################
##get basis functions for all allowed shapes for each component#
#not consider allowed shapes for now
################################################################
# get basis functions for the constrained components -- ordinal monotone
if (capl > 0) {
delta = varlst = NULL
if (1 %in% shpsx[[1]] | 2 %in% shpsx[[1]]) {
#print ('1')
del1 = makedelta(xmat[, 1], 1)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (1 %in% shpsx[[i]] | 2 %in% shpsx[[i]]) {
#print ('1')
del2 = makedelta(xmat[, i], 1)$amat
m2 = length(del2) / n
} else {del2 = NULL; m2 = 0}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
#var1: keep track of x's in delta: 11112222...
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_om = delta
#varlist_om = varlist
} #else {delta_om = del1; varlist_om = var1}
delta_om = delta
varlist_om = varlist
}
#print (shpsx[[1]])
# get basis functions for the constrained components -- smooth monotone
if (capl > 0) {
delta = varlst = NULL
if (9 %in% shpsx[[1]] | 10 %in% shpsx[[1]]) {
#print ('9')
del1 = makedelta(xmat[, 1], 9)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (9 %in% shpsx[[i]] | 10 %in% shpsx[[i]]) {
#print ('9')
del2 = makedelta(xmat[, i], 9)$amat
m2 = length(del2) / n
} else {del2 = NULL; m2 = 0}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_sm = delta
#varlist_sm = varlist
} #else {delta_sm = del1; varlist_sm = var1}
delta_sm = delta
varlist_sm = varlist
}
#print (delta_sm)
#print (varlist_sm)
# get basis functions for the constrained components -- ordinal convex
if (capl > 0) {
delta = varlst = NULL
if (3 %in% shpsx[[1]] | 4 %in% shpsx[[1]]) {
#print ('3')
del1 = makedelta(xmat[, 1], 3)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (3 %in% shpsx[[i]] | 4 %in% shpsx[[i]]) {
#print ('3')
del2 = makedelta(xmat[, i], 3)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_ocv = delta
#varlist_ocv = varlist
} #else {delta_ocv = del1; varlist_ocv = var1}
delta_ocv = delta
varlist_ocv = varlist
}
if (capl > 0) {
delta = varlst = NULL
# get basis functions for the constrained components -- smooth convex
if (11 %in% shpsx[[1]] | 12 %in% shpsx[[1]]) {
#print ('11')
del1 = makedelta(xmat[, 1], 11)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (11 %in% shpsx[[i]] | 12 %in% shpsx[[i]]) {
#print ('11')
del2 = makedelta(xmat[, i], 11)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_scv = delta
#varlist_scv = varlist
} #else {delta_scv = del1; varlist_scv = var1}
delta_scv = delta
varlist_scv = varlist
}
# get basis functions for the constrained components -- ordinal increasing convex
if (capl > 0) {
delta = varlst = NULL
if (5 %in% shpsx[[1]] | 8 %in% shpsx[[1]]) {
#print ('5')
del1 = makedelta(xmat[, 1], 5)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (5 %in% shpsx[[i]] | 8 %in% shpsx[[i]]) {
#print ('5')
del2 = makedelta(xmat[, i], 5)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_oincv = delta
#varlist_oincv = varlist
} #else {delta_oincv = del1; varlist_oincv = var1}
delta_oincv = delta
varlist_oincv = varlist
}
# get basis functions for the constrained components -- smooth increasing convex
if (capl > 0) {
delta = varlst = NULL
if (13 %in% shpsx[[1]] | 16 %in% shpsx[[1]]) {
#print ('13')
del1 = makedelta(xmat[, 1], 13)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (13 %in% shpsx[[i]] | 16 %in% shpsx[[i]]) {
#print ('13')
del2 = makedelta(xmat[, i], 13)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_sincv = delta
#varlist_sincv = varlist
} #else {delta_sincv = del1; varlist_sincv = var1}
delta_sincv = delta
varlist_sincv = varlist
}
# get basis functions for the constrained components -- ordinal decreasing convex
if (capl > 0) {
delta = varlst = NULL
if (6 %in% shpsx[[1]] | 7 %in% shpsx[[1]]) {
#print ('6')
del1 = makedelta(xmat[, 1], 6)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (6 %in% shpsx[[i]] | 7 %in% shpsx[[i]]) {
#print ('6')
del2 = makedelta(xmat[, i], 6)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_odecv = delta
#varlist_odecv = varlist
} #else {delta_odecv = del1; varlist_odecv = var1}
delta_odecv = delta
varlist_odecv = varlist
}
# get basis functions for the constrained components -- smooth increasing concave
if (capl > 0) {
delta = varlst = NULL
if (14 %in% shpsx[[1]] | 15 %in% shpsx[[1]]) {
#print ('14')
del1 = makedelta(xmat[, 1], 14)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (14 %in% shpsx[[i]] | 15 %in% shpsx[[i]]) {
#print ('14')
del2 = makedelta(xmat[, i], 14)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_sincc = delta
#varlist_sincc = varlist
} #else {delta_sincc = del1; varlist_sincc = var1}
delta_sincc = delta
varlist_sincc = varlist
}
#zmat: similar idea, zvars: columns for z1, z2,...,z's are not factorized for now
#print (zmat)
if (capk > 0) {
#zcat: similar to the final delta of x's
zcat = NULL
zvars = NULL
#st = 0
for (k in 1:capk){
zk = zmat[, k]
is_fac = zfacs[k]
if (is_fac) {
zkmat = model.matrix(~ factor(zk))[, -1, drop = FALSE]
zvars = c(zvars, rep(k, ncol(zkmat)))
} else {
zkmat = zk
zvars = c(zvars, k)
}
zcat = cbind(zcat, zkmat)
#if (is_fac) {
# zvars = c(zvars, rep(k, ncol(zkmat)))
#} else {zvars = c(zvars, k)}
}
}
#print (paste('capk:', capk))
vzcat = NULL
if (capkv > 0) {
for (k in 1:capkv){
vzk = vzmat[, k]
is_fac = vzfacs[k]
if (is_fac) {
vzkmat = model.matrix(~ factor(vzk))[, -1, drop = FALSE]
} else {
vzkmat = vzk
}
vzcat = cbind(vzcat, vzkmat)
}
}
vxcat = NULL
if (caplv > 0) {
for (l in 1:caplv) {
xl = vxmat[, l]
shpl = shpsvx[l]
vxdd = t(makedelta(xl, shpl)$amat)
if (shpl != 17) {
#caplv = caplv - 1
vxcat = cbind(vxcat, vxdd)
} else if (shpl == 17) {
capkv = capkv + 1
vzcat = cbind(vzcat, vxdd)
}
#print (dim(vxdd))
}
}
if (capt > 0) {
#trcat: work the same way as zcat, include in bigmat as the final part
trcat = NULL
trvars = NULL
for (k in 1:capt){
trk = trmat[, k]
#trkmat = model.matrix(~ factor(trk))[, -1, drop = FALSE]
trkmat = t(tree.fun(trk))
trcat = cbind(trcat, trkmat)
trvars = c(trvars, rep(k, ncol(trkmat)))
}
}
if (captv > 0) {
vtrcat = NULL
#vtrvars = NULL
for (k in 1:captv){
vtrk = vtrmat[, k]
#trkmat = model.matrix(~ factor(trk))[, -1, drop = FALSE]
vtrkmat = t(tree.fun(vtrk))
vtrcat = cbind(vtrcat, vtrkmat)
#trvars = c(trvars, rep(k, ncol(trkmat)))
}
}
# make the initial random population: capl: shapes for x's, capk: in or out for z's
if (time.est) {
npop = 1
} else {
#npop = 200 #* nmod / 2e+4
#if (nmod < 2e+6) {
# npop = 200
#} else {
# npop = 200 + round((nmod - 2e+6) / nmod * 20)
#}
#new: now we allow user to speficy npop
if (npop <= 0 | round(npop) != npop) {
warning('npop must be a positive integer! npop=200 will be used!')
if (nmod < 2e+6) {npop = 200} else {npop = 200 + round((nmod - 2e+6) / nmod * 20)}
}
#if (npop > nmod) {
# warning('npop must be smaller than the total number of possible models! npop=200 will be used!')
# if (nmod < 2e+6) {npop = 200} else {npop = 200 + round((nmod - 2e+6) / nmod * 20)}
#}
#print (npop)
}
popmat = matrix(0, nrow = npop, ncol = capl + capk + capt)
#print (capl)
for (ipop in 1:npop) {
# trunc(runif(capl)*9) gives 0 ~ 8
# trunc(runif(capk)*2) gives 0 ~ 1
#popmat[ipop, 1:capl] = trunc(runif(capl)*9)
#if(capk>0){popmat[ipop,(capl+1):(capl+capk)]=trunc(runif(capk)*2)}
if (capl > 0) {
for (l in 1:capl) {
# include flat for each x
popmat[ipop, l] = sample(shpsx[[l]], 1)
}
}
if (capk > 0) {
popmat[ipop, (capl + 1):(capl + capk)] = trunc(runif(capk)*2)
}
if (capt > 0) {
popmat[ipop, (capl + capk + 1):(capl + capk + capt)] = trunc(runif(capt)*3)
}
}
#print (popmat)
#print (class(popmat))
fitness = 1:npop*(-1)
## keep track of fitnesses already calculated
cicvals = matrix(0, ncol = 2, nrow = npop*100)
kpop = matrix(0, nrow = 5000, ncol = capl + capk + capt)
kfit = 1:5000
robs = 1:(npop*100)
#check!
#fits = vector("list", npop)
ivals = 0
## loop through the population
#base number's for x's
if (capl > 0) {
bx = sapply(shpsx, function(x) length(x))
#number of x's for each base
numx = unname(table(bx))
ubx = unique(bx)
lbx = length(ubx)
}
if (!time.est) {
cat(paste("Evaluating the fitness of the initial population....", "\n"))
}
for (ipop in 1:npop) {
#if (ipop%%5 == 0) print (ipop)
#print (popmat[ipop,])
#print (capl)
# i1, i2: row numbers by base 10 instead of base 9 and 2
#imod is not right....
#i1 = 0
#for (l in 1:capl) {i1 = i1 + 5^(capl - l) * popmat[ipop, l]}
i1 = 0
if (capl > 0) {
for (i in 1:lbx) {
capli = numx[i]
bxi = ubx[i]
popi = (popmat[ipop, 1:capl, drop = FALSE])[which(bx == bxi)]
for (il in 1:capli) {i1 = i1 + bxi^(capli - il) * popi[il]}
}
}
i2 = 0
if (capk > 0) {
for (k in 1:capk) {i2 = i2 + 2^(capk - k) * popmat[ipop, capl + k]}
}
i3 = 0
if (capt > 0) {
for (tr in 1:capt) {i3 = i3 + 3^(capt - tr) * popmat[ipop, capl + capk + tr]}
}
#imod = i2 * 9^capl + i1 + 1
mult = 1
if (capl > 0) {
for (i in 1:lbx) {
mult = mult * (ubx[i])^numx[i]
}
}
mult2 = 1
if (capk > 0) {
mult2 = 2^capk
}
#imod = i3 * 2^capk * mult + i2 * mult + i1 + 1
imod = i3 * mult2 * mult + i2 * mult + i1 + 1
## if we've done this model before, read old CIC for fitness
if (!all(cicvals[, 1] != imod)) {
rownum = robs[cicvals[, 1] == imod]
fitness[ipop] = -cicvals[rownum, 2]
} else {
#use 0 to represent all 'flat'
if (sum(popmat[ipop, ]) == 0) {
#llh=-2*(nsuc*log(mu0)+(n-nsuc)*log(1-mu0))/n
#print ('test llh')
llh = llh.fun(y = y, muhat = rep(mean(y), n), etahat = rep(mean(y), n), phihat=NULL, n = n, weights = weights, fml = family$family)
cic = llh + log(1 + 2 / (n - 1))
fitness[ipop] = -cic
} else {
delta = matrix(1:n*0+1, nrow = 1)
if (capkv > 0) {
delta = rbind(delta, t(vzcat))
}
#print (head(t(delta)))
if (capk > 0) {
if (sum(popmat[ipop, (capl+1):(capl+capk)]) > 0) {
#zuse = 1:st < 0
zuse = 1:ncol(zcat) < 0
for (i in 1:capk) {
if (popmat[ipop, capl+i] == 1) {
zuse[zvars == i] = TRUE
}
}
delta = rbind(delta, t(zcat[, zuse]))
#delta = rbind(1:n*0+1, t(zcat[, zuse]))
} #else {delta = matrix(1:n*0+1, nrow = 1)}
}
#new: unordered part for tree = 2, equivalent to 'z'
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 2) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (sum(popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13) > 0) {
usex = popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13
delta = rbind(delta, t(xmat[, usex]))
}
#new:
if (caplv > 0) {
ch = shpsvx %in% c(3, 4, 11, 12)
if (any(ch)) {
vxin = vxmat[, which(ch)]
delta = rbind(delta, t(vxin))
}
}
np = dim(delta)[1]
#print (popmat[ipop, ])
#new:
if (capl > 0) {
for (l in 1:capl) {
if (popmat[ipop, l] > 0) {
if (popmat[ipop, l] == 1) {#incr
#print ('1')
deladd = delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 2) {#decr
#print ('2')
deladd = -delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 3) {#conv
#print ('3')
deladd = delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 4) {#conc
#print ('4')
deladd = -delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 5) {#incr.conv
#print ('5')
deladd = delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 8) {#decr.conc
#print ('8')
deladd = -delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 6) {#decr.conv
#print ('6')
deladd = delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 7) {#incr.conc
#print ('7')
deladd = -delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 9) {
#print ('9')
deladd = delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 10) {
#print ('10')
deladd = -delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 11) {
#print ('11')
deladd = delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 12) {
#print ('12')
deladd = -delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 13) {
#print ('13')
deladd = delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 16) {
#print ('16')
deladd = -delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 14) {
#print ('14')
deladd = delta_sincc[varlist_sincc == l, ]
} else if (popmat[ipop, l] == 15) {
#print ('15')
deladd = -delta_sincc[varlist_sincc == l, ]
}
delta = rbind(delta, deladd)
#print (paste('dim: ', dim(delta)))
}
}
}
if (caplv > 0) {
if (!is.null(vxcat)) {
delta = rbind(delta, t(vxcat))
}
}
#tree part for tree var
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 1) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (captv > 0) {
delta = rbind(delta, t(vtrcat))
}
#print (paste('dim: ', dim(t(trcat))))
#print (delta)
#print (cpar)
ans = irls(y, delta, np, nsim = 100, family = family, weights = weights, cpar = cpar)
ivals = ivals + 1
cicvals[ivals, 2] = ans$cic
cicvals[ivals, 1] = imod
fitness[ipop] = -cicvals[ivals, 2]
kpop[ivals, ] = popmat[ipop, ]
kfit[ivals] = -cicvals[ivals, 2]
#fits[[ivals]] = ans$fhat
}
}
#print (ipop - fitness[ipop])
}
#iter = 0
mxf = NULL
mnf = NULL
#mdf = NULL
#mq3f = NULL
if (!time.est) {
## Now loop through generations
nrep = 0
obs = 1:npop
q1 = trunc(npop/4)
q2 = 2 * q1
q3 = round(.98 * npop)
nbig = 100
nm = 10
check = TRUE
maxfit = -1000
while (nrep < nbig & check) {
#while (nrep < nbig) {
ord = order(-fitness)
popmat = popmat[ord, ,drop = FALSE]
fitness = fitness[ord]
nrep = nrep + 1
cat(paste("Iter =", nrep, " | Mean =", format(mean(fitness), digits = 6), " | Best =", format(max(fitness), digits = 6), "\n"))
# mutate! randomly throughout population ## don't mutate the most fit
# imut is the row # of popmat
# igene is the column # of x, z, and tree
#imut = trunc(runif(nm) * (npop - 1) + 2)
#new for imut
if (per.mutate <= 0 | per.mutate >= 0.5) {
warning('per.mutate should be a percentage > 0 and < 0.5! per.mute = 0.05 will be used!')
per.mutate = 0.05
}
nm = round(npop * per.mutate)
imut = sample(1:npop, size = nm, replace = FALSE)
#print (nm)
#print (paste('imute:',imut))
#igene = trunc(runif(nm) * (capk + capl) + 1)
#check!
igene = trunc(runif(nm) * (capk + capl + capt) + 1)
for (im in 1:nm) {
ipop = imut[im]
if (igene[im] <= capl) {
#popmat[imut[im], igene[im]] = trunc(runif(1)*9)
#pos = imut[im]
popmat[imut[im], igene[im]] = sample(shpsx[[igene[im]]], 1)
} else if (igene[im] > capl & igene[im] <= (capl + capk)) {
popmat[imut[im], igene[im]] = trunc(runif(1)*2)
} else if (igene[im] > (capl + capk)) {
popmat[imut[im], igene[im]] = trunc(runif(1)*3)
}
#ipop = imut[im]
# find fitness of mutated phenotype
#i1=0;for(l in 1:capl){i1=i1+9^(capl-l)*popmat[ipop,l]}
#i2=0
#if(capk>0){
# for(k in 1:capk){i2=i2+2^(capk-k)*popmat[ipop,capl+k]}
#}
#imod=i2*9^capl+i1+1
i1 = 0
if (capl > 0) {
for (i in 1:lbx) {
capli = numx[i]
bxi = ubx[i]
popi = (popmat[ipop, 1:capl, drop = FALSE])[which(bx == bxi)]
for (il in 1:capli) {i1 = i1 + bxi^(capli - il) * popi[il]}
}
}
i2 = 0
if (capk > 0) {
for (k in 1:capk) {i2 = i2 + 2^(capk - k) * popmat[ipop, capl + k]}
}
i3 = 0
if (capt > 0) {
for (tr in 1:capt) {i3 = i3 + 3^(capt - tr) * popmat[ipop, capl + capk + tr]}
}
mult = 1
if (capl > 0) {
for (i in 1:lbx) {
mult = mult * (ubx[i])^numx[i]
}
}
mult2 = 1
if (capk > 0) {
mult2 = 2^capk
}
imod = i3 * mult2 * mult + i2 * mult + i1 + 1
## if we've done this model before, read old CIC for fitness
if (!all(cicvals[, 1] != imod)) {
rownum = robs[cicvals[,1] == imod]
fitness[ipop] = -cicvals[rownum, 2]
#print("done")
## calculate fitness
} else {
if (sum(popmat[ipop, ]) == 0) {
#llh=-2*(nsuc*log(mu0)+(n-nsuc)*log(1-mu0))/n
#cic=llh+log(1+2/(n-1))
#fitness[ipop]=-cic
llh = llh.fun(y = y, muhat = rep(mean(y), n), etahat = rep(mean(y), n), phihat=NULL, n = n, weights = weights, fml = family$family)
cic = llh + log(1 + 2 / (n - 1))
fitness[ipop] = -cic
} else {
delta = matrix(1:n*0+1, nrow = 1)
if (capkv > 0) {
delta = rbind(delta, t(vzcat))
}
if (capk > 0) {
if (sum(popmat[ipop, (capl+1):(capl+capk)]) > 0) {
zuse = 1:ncol(zcat) < 0
for (i in 1:capk) {
if (popmat[ipop, capl+i] == 1) {
zuse[zvars == i] = TRUE
}
}
delta = rbind(delta, t(zcat[, zuse]))
#delta = rbind(1:n*0+1, t(zcat[, zuse]))
} #else {
# delta = matrix(1:n*0+1, nrow = 1)
#}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 2) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (sum(popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13) > 0) {
usex = popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13
delta = rbind(delta, t(xmat[, usex]))
}
#new:
if (caplv > 0) {
ch = shpsvx %in% c(3, 4, 11, 12)
if (any(ch)) {
vxin = vxmat[, which(ch)]
delta = rbind(delta, t(vxin))
}
}
np = dim(delta)[1]
if (capl > 0) {
for (l in 1:capl) {
if (popmat[ipop, l] > 0) {
if (popmat[ipop, l] == 1) {#incr
deladd = delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 2) {#decr
deladd = -delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 3) {#conv
deladd = delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 4) {#conc
deladd = -delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 5) {#incr.conv
deladd = delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 8) {#decr.conc
deladd = -delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 6) {#decr.conv
deladd = delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 7) {#incr.conc
deladd = -delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 9) {
deladd = delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 10) {
deladd = -delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 11) {
deladd = delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 12) {
deladd = -delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 13) {
deladd = delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 16) {
deladd = -delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 14) {
deladd = delta_sincc[varlist_sincc == l, ]
} else if (popmat[ipop, l] == 15) {
deladd = -delta_sincc[varlist_sincc == l, ]
}
delta = rbind(delta, deladd)
}
}
}
if (caplv > 0) {
if (!is.null(vxcat)) {
delta = rbind(delta, t(vxcat))
}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 1) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (captv > 0) {
delta = rbind(delta, t(vtrcat))
}
ans = irls(y, delta, np, nsim = 100, family = family, weights = weights, cpar = cpar)
ivals = ivals + 1
cicvals[ivals, 2] = ans$cic
cicvals[ivals, 1] = imod
fitness[ipop] = -cicvals[ivals, 2]
kpop[ivals, ] = popmat[ipop, ]
kfit[ivals] = -cicvals[ivals, 2]
#fits[[ivals]] = ans$fhat
}
}
}
# reproduction: replace middle half with offspring: offspring combine elite with other
for (ipop in q1:q3) {
mom = trunc(runif(1) * npop + 1)
dad = trunc(runif(1) * q1 + 1)
digits = runif(capl + capk + capt) > .5
popmat[ipop, digits] = popmat[mom, digits]
popmat[ipop, !digits] = popmat[dad, !digits]
# find fitness of baby
#i1=0;for(l in 1:capl){i1=i1+9^(capl-l)*popmat[ipop,l]}
#i2=0
#if(capk>0){
# for(k in 1:capk){i2=i2+2^(capk-k)*popmat[ipop,capl+k]}
#}
#imod=i2*9^capl+i1+1
i1 = 0
if (capl > 0) {
for (i in 1:lbx) {
capli = numx[i]
bxi = ubx[i]
popi = (popmat[ipop, 1:capl, drop = FALSE])[which(bx == bxi)]
for (il in 1:capli) {i1 = i1 + bxi^(capli - il) * popi[il]}
}
}
i2 = 0
if (capk > 0) {
for (k in 1:capk) {i2 = i2 + 2^(capk - k) * popmat[ipop, capl + k]}
}
i3 = 0
if (capt > 0) {
for (tr in 1:capt) {i3 = i3 + 3^(capt - tr) * popmat[ipop, capl + capk + tr]}
}
mult = 1
if (capl > 0) {
for (i in 1:lbx) {
mult = mult * (ubx[i])^numx[i]
}
}
mult2 = 1
if (capk > 0) {
mult2 = 2^capk
}
imod = i3 * mult2 * mult + i2 * mult + i1 + 1
## if we've done this model before, read old CIC for fitness
if (!all(cicvals[, 1] != imod)) {
rownum = robs[cicvals[, 1] == imod]
fitness[ipop] = -cicvals[rownum, 2]
#print("done")
## calculate fitness
} else {
if (sum(popmat[ipop, ]) == 0) {
#llh=-2*(nsuc*log(mu0)+(n-nsuc)*log(1-mu0))/n
#cic=llh+log(1+2/(n-1))
#fitness[ipop]=-cic
llh = llh.fun(y = y, muhat = rep(mean(y), n), etahat = rep(mean(y), n), phihat=NULL, n = n, weights = weights, fml = family$family)
cic = llh + log(1 + 2 / (n - 1))
fitness[ipop] = -cic
} else {
delta = matrix(1:n*0+1, nrow = 1)
if (capkv > 0) {
delta = rbind(delta, t(vzcat))
}
if (capk > 0) {
if (sum(popmat[ipop, (capl+1):(capl+capk)]) > 0) {
zuse = 1:ncol(zcat) < 0
for (i in 1:capk) {
if (popmat[ipop, capl+i] == 1) {
zuse[zvars == i] = TRUE
}
}
delta = rbind(delta, t(zcat[, zuse]))
#delta = rbind(1:n*0+1, t(zcat[, zuse]))
}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 2) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (sum(popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13) > 0) {
usex = popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13
delta = rbind(delta, t(xmat[, usex]))
}
#new:
if (caplv > 0) {
ch = shpsvx %in% c(3, 4, 11, 12)
if (any(ch)) {
vxin = vxmat[, which(ch)]
delta = rbind(delta, t(vxin))
}
}
np = dim(delta)[1]
if (capl > 0) {
for (l in 1:capl) {
if (popmat[ipop, l] > 0) {
if (popmat[ipop, l] == 1) {#incr
deladd = delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 2) {#decr
deladd = -delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 3) {#conv
deladd = delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 4) {#conc
deladd = -delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 5) {#incr.conv
deladd = delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 8) {#decr.conc
deladd = -delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 6) {#decr.conv
deladd = delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 7) {#incr.conc
deladd = -delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 9) {
deladd = delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 10) {
deladd = -delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 11) {
deladd = delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 12) {
deladd = -delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 13) {
deladd = delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 16) {
deladd = -delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 14) {
deladd = delta_sincc[varlist_sincc == l, ]
} else if (popmat[ipop, l] == 15) {
deladd = -delta_sincc[varlist_sincc == l, ]
}
delta = rbind(delta, deladd)
}
}
}
if (caplv > 0) {
if (!is.null(vxcat)) {
delta = rbind(delta, t(vxcat))
}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 1) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (captv > 0) {
delta = rbind(delta, t(vtrcat))
}
ans = irls(y, delta, np, nsim = 100, family = family, weights = weights, cpar = cpar)
ivals = ivals + 1
cicvals[ivals, 2] = ans$cic
cicvals[ivals, 1] = imod
fitness[ipop] = -cicvals[ivals, 2]
kpop[ivals, ] = popmat[ipop, ]
kfit[ivals] = -cicvals[ivals, 2]
#fits[[ivals]] = ans$fhat
}
}
}
## immigration
for (ipop in (q3 + 1):npop) {
if (capl > 0) {
for (l in 1:capl) {
popmat[ipop, l] = sample(shpsx[[l]], 1)
}
}
if (capk > 0) {
popmat[ipop, (capl + 1):(capl + capk)] = trunc(runif(capk)*2)
}
if (capt > 0) {
popmat[ipop, (capl + capk + 1):(capl + capk + capt)] = trunc(runif(capt)*3)
}
# find fitness of new immigrant
i1 = 0
if (capl > 0) {
for (i in 1:lbx) {
capli = numx[i]
bxi = ubx[i]
popi = (popmat[ipop, 1:capl, drop = FALSE])[which(bx == bxi)]
for (il in 1:capli) {i1 = i1 + bxi^(capli - il) * popi[il]}
}
}
i2 = 0
if (capk > 0) {
for (k in 1:capk) {i2 = i2 + 2^(capk - k) * popmat[ipop, capl + k]}
}
i3 = 0
if (capt > 0) {
for (tr in 1:capt) {i3 = i3 + 3^(capt - tr) * popmat[ipop, capl + capk + tr]}
}
mult = 1
if (capl > 0) {
for (i in 1:lbx) {
mult = mult * (ubx[i])^numx[i]
}
}
mult2 = 1
if (capk > 0) {
mult2 = 2^capk
}
imod = i3 * mult2 * mult + i2 * mult + i1 + 1
## if we've done this model before, read old CIC for fitness
if (!all(cicvals[, 1] != imod)) {
rownum = robs[cicvals[, 1] == imod]
fitness[ipop] = -cicvals[rownum, 2]
} else {
if (sum(popmat[ipop, ]) == 0) {
llh = llh.fun(y = y, muhat = rep(mean(y), n), etahat = rep(mean(y), n), phihat=NULL, n = n, weights = weights, fml = family$family)
cic = llh + log(1 + 2 / (n - 1))
fitness[ipop] = -cic
} else {
delta = matrix(1:n*0+1, nrow = 1)
if (capkv > 0) {
delta = rbind(delta, t(vzcat))
}
if (capk > 0) {
if (sum(popmat[ipop, (capl+1):(capl+capk)]) > 0) {
zuse = 1:ncol(zcat) < 0
for (i in 1:capk) {
if (popmat[ipop, capl+i] == 1) {
zuse[zvars == i] = TRUE
}
}
delta = rbind(delta, t(zcat[, zuse]))
#delta = rbind(1:n*0+1, t(zcat[, zuse]))
} #else {delta = matrix(1:n*0+1, nrow = 1)}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 2) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (sum(popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13) > 0) {
usex = popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13
delta = rbind(delta, t(xmat[, usex]))
}
#new:
if (caplv > 0) {
ch = shpsvx %in% c(3, 4, 11, 12)
if (any(ch)) {
vxin = vxmat[, which(ch)]
delta = rbind(delta, t(vxin))
}
}
np = dim(delta)[1]
if (capl > 0) {
for (l in 1:capl) {
if (popmat[ipop, l] > 0) {
if (popmat[ipop, l] == 1) {#incr
deladd = delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 2) {#decr
deladd = -delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 3) {#conv
deladd = delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 4) {#conc
deladd = -delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 5) {#incr.conv
deladd = delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 8) {#decr.conc
deladd = -delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 6) {#decr.conv
deladd = delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 7) {#incr.conc
deladd = -delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 9) {
deladd = delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 10) {
deladd = -delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 11) {
deladd = delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 12) {
deladd = -delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 13) {
deladd = delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 16) {
deladd = -delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 14) {
deladd = delta_sincc[varlist_sincc == l, ]
} else if (popmat[ipop, l] == 15) {
deladd = -delta_sincc[varlist_sincc == l, ]
}
delta = rbind(delta, deladd)
}
}
}
if (caplv > 0) {
if (!is.null(vxcat)) {
delta = rbind(delta, t(vxcat))
}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 1) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (captv > 0) {
delta = rbind(delta, t(vtrcat))
}
ans = irls(y, delta, np, nsim = 100, family = family, weights = weights, cpar = cpar)
ivals = ivals + 1
cicvals[ivals, 2] = ans$cic
cicvals[ivals, 1] = imod
fitness[ipop] = -cicvals[ivals, 2]
kpop[ivals, ] = popmat[ipop, ]
kfit[ivals] = -cicvals[ivals, 2]
#fits[[ivals]] = ans$fhat
}
}
}
## targeted mutation, add if capl > 0
if (capl > 0) {
#if (max(fitness) > maxfit + 1e-8) {
ord = order(-fitness)
popmat = popmat[ord, ,drop = FALSE]
fitness = fitness[ord]
repl = 0
for (ic in 1:capl) {
#for (ic in 1:(capl - 1)) {
tpop = popmat[1, ]
#??
#for (j in 1:9) {
for (j in 1:length(shpsx[[ic]])) {
#tpop[ic] = tpop[ic] + 1
#if (tpop[ic] >= 9) {
#if (tpop[ic] >= max(shpsx[[ic]])) {
#tpop[ic] = 1
# tpop[ic] = min(shpsx[[ic]])
#}
tpop[ic] = sample(shpsx[[ic]], 1)
#print(tpop)
# find fitness of mutated phenotype
# i1=0;for(l in 1:capl){i1=i1+9^(capl-l)*tpop[l]}
# i2=0
# if(capk>0){
# for(k in 1:capk){i2=i2+2^(capk-k)*tpop[capl+k]}
# }
# imod=i2*9^capl+i1+1
i1 = 0
if (capl > 0) {
for (i in 1:lbx) {
capli = numx[i]
bxi = ubx[i]
popi = (popmat[ipop, 1:capl, drop = FALSE])[which(bx == bxi)]
for (il in 1:capli) {i1 = i1 + bxi^(capli - il) * popi[il]}
}
}
i2 = 0
if (capk > 0) {
for (k in 1:capk) {i2 = i2 + 2^(capk - k) * popmat[ipop, capl + k]}
}
i3 = 0
if (capt > 0) {
for (tr in 1:capt) {i3 = i3 + 3^(capt - tr) * popmat[ipop, capl + capk + tr]}
}
mult = 1
for (i in 1:lbx) {
mult = mult * (ubx[i])^numx[i]
}
mult2 = 1
if (capk > 0) {
mult2 = 2^capk
}
imod = i3 * mult2 * mult + i2 * mult + i1 + 1
## if we've done this model before, read old CIC for fitness
if (!all(cicvals[, 1] != imod)) {
rownum = robs[cicvals[, 1] == imod]
tfit = -cicvals[rownum, 2]
} else {
if (sum(tpop) == 0) {
#llh=-2*(nsuc*log(mu0)+(n-nsuc)*log(1-mu0))/n
llh = llh.fun(y = y, muhat = rep(mean(y), n), etahat = rep(mean(y), n), phihat=NULL, n = n, weights = weights, fml = family$family)
cic = llh + log(1 + 2 / (n - 1))
tfit = -cic
} else {
delta = matrix(1:n*0+1, nrow = 1)
if (capkv > 0) {
delta = rbind(delta, t(vzcat))
}
if (capk > 0) {
if (sum(tpop[(capl+1):(capl+capk)]) > 0) {
zuse = 1:ncol(zcat) < 0
for (i in 1:capk) {
if (tpop[capl+i] == 1) {
zuse[zvars == i] = TRUE
}
}
delta = rbind(delta, t(zcat[, zuse]))
#delta = rbind(1:n*0+1, t(zcat[, zuse]))
} #else {delta = matrix(1:n*0+1, nrow = 1)}
}
if (capt > 0) {
if (sum(tpop[(capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (tpop[capl+capk+i] == 2) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (sum(tpop[1:capl] > 2 & tpop[1:capl] < 5 | tpop[1:capl] > 10 & tpop[1:capl] < 13) > 0) {
usex = tpop[1:capl] > 2 & tpop[1:capl] < 5 | tpop[1:capl] > 10 & tpop[1:capl] < 13
delta = rbind(delta, t(xmat[, usex]))
}
#new:
if (caplv > 0) {
ch = shpsvx %in% c(3, 4, 11, 12)
if (any(ch)) {
vxin = vxmat[, which(ch)]
delta = rbind(delta, t(vxin))
}
}
np = dim(delta)[1]
for (l in 1:capl) {
if (tpop[l] > 0) {
if (tpop[l] == 1) {#incr
deladd = delta_om[varlist_om == l, ]
} else if (tpop[l] == 2) {#decr
deladd = -delta_om[varlist_om == l, ]
} else if (tpop[l] == 3) {#conv
deladd = delta_ocv[varlist_ocv == l, ]
} else if (tpop[l] == 4) {#conc
deladd = -delta_ocv[varlist_ocv == l, ]
} else if (tpop[l] == 5) {#incr.conv
deladd = delta_oincv[varlist_oincv == l, ]
} else if (tpop[l] == 8) {#decr.conc
deladd = -delta_oincv[varlist_oincv == l, ]
} else if (tpop[l] == 6) {#decr.conv
deladd = delta_odecv[varlist_odecv == l, ]
} else if (tpop[l] == 7) {#incr.conc
deladd = -delta_odecv[varlist_odecv == l, ]
} else if (tpop[l] == 9) {
deladd = delta_sm[varlist_sm == l, ]
} else if (tpop[l] == 10) {
deladd = -delta_sm[varlist_sm == l, ]
} else if (tpop[l] == 11) {
deladd = delta_scv[varlist_scv == l, ]
} else if (tpop[l] == 12) {
deladd = -delta_scv[varlist_scv == l, ]
} else if (tpop[l] == 13) {
deladd = delta_sincv[varlist_sincv == l, ]
} else if (tpop[l] == 16) {
deladd = -delta_sincv[varlist_sincv == l, ]
} else if (tpop[l] == 14) {
deladd = delta_sincc[varlist_sincc == l, ]
} else if (tpop[l] == 15) {
deladd = -delta_sincc[varlist_sincc == l, ]
}
delta = rbind(delta, deladd)
}
}
if (caplv > 0) {
if (!is.null(vxcat)) {
delta = rbind(delta, t(vxcat))
}
}
#nsim2 = 100 for target part
if (capt > 0) {
if (sum(tpop[(capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (tpop[capl+capk+i] == 1) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (captv > 0) {
delta = rbind(delta, t(vtrcat))
}
ans = irls(y, delta, np, nsim = 100, family = family, weights = weights, cpar = cpar)
ivals = ivals + 1
cicvals[ivals, 2] = ans$cic
cicvals[ivals, 1] = imod
kpop[ivals, ] = tpop
kfit[ivals] = -cicvals[ivals, 2]
tfit = -cicvals[ivals, 2]
#fits[[ivals]] = ans$fhat
#print(tfit)
if (tfit > fitness[1]) {
#points(npop - repl, tfit, pch = 5, col = "darkgreen")
popmat[npop - repl, ] = tpop
fitness[npop - repl] = tfit
repl = repl + 1
}
}
}
}
}
}
maxfit = max(fitness)
if (fitness[q1] > maxfit - 1e-8){check = FALSE}
#if (fitness[q1] > maxfit - 1e-6){check = FALSE}
mxf = c(mxf, max(fitness))
mnf = c(mnf, mean(fitness))
#mdf = c(mdf, quantile(fitness, probs = .5))
#mq3f = c(mdf, quantile(fitness, probs = .75))
}
}
ord = order(-fitness)
# sort the pop by fitness
popmat = popmat[ord, ,drop = FALSE]
fitness = fitness[ord]
rslt = new.env()
rslt$fitness = fitness
#rslt$fhat = fits
pop2 = matrix(0, nrow = npop, ncol = (capl+capk+capt))
if (capl > 0) {
for (i in 1:npop) {
pop2[i, 1:capl] = apply(popmat[i, 1:capl, drop = FALSE], 2, ShapeToChar)
}
#names(pop2)[1:capl] = xnms
}
if (capk > 0) {
for (i in 1:npop) {
pop2[i, (capl+1):(capl+capk)] = apply(popmat[i, (capl+1):(capl+capk), drop = FALSE], 2, function(num) ShapeToChar(num, tag = "z"))
}
#names(pop2)[(capl+1):(capl+capk)] = znms
}
if (capt > 0) {
for (i in 1:npop) {
pop2[i, (capl+capk+1):(capl+capk+capt)] = apply(popmat[i, (capl+capk+1):(capl+capk+capt), drop = FALSE], 2, function(num) ShapeToChar(num, tag = "tree"))
}
#names(pop2)[(capl+capk+1):(capl+capk+capt)] = trnms
}
#colnames(pop2) = c(xnms, znms, trnms)
pop2 = as.data.frame(pop2, stringsAsFactors = FALSE)
rslt$pop = cbind(popmat, fitness)
pop2 = cbind(pop2, fitness)
rslt$pop2 = pop2
#rslt$top = pop2[1, stringsAsFactors = FALSE]
rslt$mxf = mxf
rslt$mnf = mnf
#rslt$mdf = mdf
#rslt$mq3f = mq3f
rslt$GA = TRUE
rslt$vzcat = vzcat
#print (paste('nrep: ', nrep))
#class(rslt) = "cgam"
return (rslt)
}
##############################
#go through models one-by-one#
##############################
ConstrALL = function(y, xmat, zmat, trmat, family = gaussian, shpsx = NULL, shpsvx = NULL, shpsz = NULL, shpst = NULL, cpar = 1.2, zfacs = NULL, weights = NULL, vzmat = NULL, vzfacs = NULL, vxmat = NULL, vtrmat = NULL) {
#linkfun = family$linkfun
cicfamily = CicFamily(family)
llh.fun = cicfamily$llh.fun
etahat.fun = cicfamily$etahat.fun
gr.fun = cicfamily$gr.fun
wt.fun = cicfamily$wt.fun
zvec.fun = cicfamily$zvec.fun
muhat.fun = cicfamily$muhat.fun
ysim.fun = cicfamily$ysim.fun
deriv.fun = cicfamily$deriv.fun
dev.fun = cicfamily$dev.fun
n = length(y)
sm = 1e-7
capl = length(xmat) / n
if (capl < 1) {capl = 0}
if (round(capl, 8) != round(capl, 1)) {
stop ("Incompatible dimensions for xmat!")
}
#check!
if (capl > 0) {
for(i in 1:capl) {
xmat[,i] = (xmat[,i] - min(xmat[,i])) / (max(xmat[,i]) - min(xmat[,i]))
#xmat[,i] = (xmat[,i] - mean(xmat[,i])) / sd(xmat[,i])
#xmat[,i] = xmat[,i] / sd(xmat[,i])
}
}
caplv = length(vxmat) / n
if (caplv < 1) {caplv = 0}
if (round(caplv, 8) != round(caplv, 1)) {
stop ("Incompatible dimensions for zmat!")
}
#new:
if (caplv > 0) {
for(i in 1:caplv) {
vxmat[,i] = (vxmat[,i] - min(vxmat[,i])) / (max(vxmat[,i]) - min(vxmat[,i]))
#vxmat[,i] = (vxmat[,i] - mean(vxmat[,i])) / sd(vxmat[,i])
#vxmat[,i] = vxmat[,i] / sd(vxmat[,i])
}
}
capk = length(zmat) / n
if (capk < 1) {capk = 0}
if (round(capk, 8) != round(capk, 1)) {
stop ("Incompatible dimensions for zmat!")
}
capkv = length(vzmat) / n
if (capkv < 1) {capkv = 0}
if (round(capkv, 8) != round(capkv, 1)) {
stop ("Incompatible dimensions for zmat!")
}
capt = length(trmat) / n
if (capt < 1) {capt = 0}
if (round(capt, 8) != round(capt, 1)) {
stop ("Incompatible dimensions for trmat!")
}
captv = length(vtrmat) / n
if (captv < 1) {captv = 0}
if (round(captv, 8) != round(captv, 1)) {
stop ("Incompatible dimensions for trmat!")
}
################################################################
##get basis functions for all allowed shapes for each component#
#not consider allowed shapes for now
################################################################
# get basis functions for the constrained components -- ordinal monotone
if (capl > 0) {
delta = varlist = NULL
if (1 %in% shpsx[[1]] | 2 %in% shpsx[[1]]) {
#print ('1')
del1 = makedelta(xmat[, 1], 1)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (1 %in% shpsx[[i]] | 2 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 1)$amat
m2 = length(del2) / n
} else {del2 = NULL; m2 = 0}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_om = delta
varlist_om = varlist
}
# get basis functions for the constrained components -- smooth monotone
if (capl > 0) {
delta = varlist = NULL
if (9 %in% shpsx[[1]] | 10 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 9)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (9 %in% shpsx[[i]] | 10 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 9)$amat
m2 = length(del2) / n
} else {del2 = NULL; m2 = 0}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_sm = delta
varlist_sm = varlist
}
# get basis functions for the constrained components -- ordinal convex
if (capl > 0) {
delta = varlist = NULL
if (3 %in% shpsx[[1]] | 4 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 3)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (3 %in% shpsx[[i]] | 4 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 3)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_ocv = delta
varlist_ocv = varlist
}
# get basis functions for the constrained components -- smooth convex
if (capl > 0) {
delta = varlist = NULL
if (11 %in% shpsx[[1]] | 12 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 11)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (11 %in% shpsx[[i]] | 12 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 11)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_scv = delta
varlist_scv = varlist
}
if (capl > 0) {
delta = varlist = NULL
# get basis functions for the constrained components -- ordinal increasing convex
if (5 %in% shpsx[[1]] | 8 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 5)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (5 %in% shpsx[[i]] | 8 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 5)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_oincv = delta
varlist_oincv = varlist
}
if (capl > 0) {
delta = varlist = NULL
# get basis functions for the constrained components -- smooth increasing convex
if (13 %in% shpsx[[1]] | 16 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 13)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (13 %in% shpsx[[i]] | 16 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 13)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_sincv = delta
varlist_sincv = varlist
}
if (capl > 0) {
delta = varlist = NULL
# get basis functions for the constrained components -- ordinal decreasing convex
if (6 %in% shpsx[[1]] | 7 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 6)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (6 %in% shpsx[[i]] | 7 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 6)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_odecv = delta
varlist_odecv = varlist
}
if (capl > 0) {
delta = varlist = NULL
# get basis functions for the constrained components -- smooth increasing concave
if (14 %in% shpsx[[1]] | 15 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 14)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (14 %in% shpsx[[i]] | 15 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 14)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_sincc = delta
varlist_sincc = varlist
}
if (capk > 0) {
zcat = NULL
zvars = NULL
for (k in 1:capk){
zk = zmat[, k]
is_fac = zfacs[k]
if (is_fac) {
zkmat = model.matrix(~ factor(zk))[, -1, drop = FALSE]
zvars = c(zvars, rep(k, ncol(zkmat)))
} else {
zkmat = zk
zvars = c(zvars, k)
}
zcat = cbind(zcat, zkmat)
}
}
vzcat = NULL
if (capkv > 0) {
for (k in 1:capkv){
vzk = vzmat[, k]
is_fac = vzfacs[k]
if (is_fac) {
vzkmat = model.matrix(~ factor(vzk))[, -1, drop = FALSE]
} else {
vzkmat = vzk
}
vzcat = cbind(vzcat, vzkmat)
}
}
vxcat = NULL
if (caplv > 0) {
for (l in 1:caplv) {
xl = vxmat[, l]
shpl = shpsvx[l]
vxdd = t(makedelta(xl, shpl)$amat)
if (shpl != 17) {
#caplv = caplv - 1
vxcat = cbind(vxcat, vxdd)
} else if (shpl == 17) {
capkv = capkv + 1
vzcat = cbind(vzcat, vxdd)
}
#print (dim(vxdd))
}
}
if (capt > 0) {
#trcat: work the same way as zcat, include in bigmat as the final part
trcat = NULL
trvars = NULL
for (k in 1:capt){
trk = trmat[, k]
#trkmat = model.matrix(~ factor(trk))[, -1, drop = FALSE]
trkmat = t(tree.fun(trk))
trcat = cbind(trcat, trkmat)
trvars = c(trvars, rep(k, ncol(trkmat)))
}
}
if (captv > 0) {
vtrcat = NULL
#vtrvars = NULL
for (k in 1:captv){
vtrk = vtrmat[, k]
#trkmat = model.matrix(~ factor(trk))[, -1, drop = FALSE]
vtrkmat = t(tree.fun(vtrk))
vtrcat = cbind(vtrcat, vtrkmat)
#trvars = c(trvars, rep(k, ncol(trkmat)))
}
}
# make the population of all models
listAll = vector("list", capl + capk + capt)
if (capl > 0) {
listAll[1:capl] = shpsx
}
if (capk > 0) {
listAll[(capl+1):(capl+capk)] = shpsz
}
if (capt > 0) {
listAll[(capl+capk+1):(capl+capk+capt)] = shpst
}
popmat = as.matrix(expand.grid(listAll, stringsAsFactors = FALSE))
#ord = ncol(popmat):1
#pop0 = unname(popmat[, ord])
npop = nrow(popmat)
popmat = cbind(popmat, 1:npop*0)
fitness = 1:npop*(-1)
## keep track of fitnesses already calculated
cat(paste("Evaluating the fitness of all models!", "\n"))
for (ipop in 1:npop) {
#print (ipop)
if (sum(popmat[ipop, ]) == 0) {
llh = llh.fun(y = y, muhat = rep(mean(y), n), etahat = rep(mean(y), n), phihat=NULL, n = n, weights = weights, fml = family$family)
cic = llh + log(1 + 2 / (n - 1))
fitness[ipop] = -cic
popmat[ipop, (capl+capk+capt+1)] = -cic
}
delta = matrix(1:n*0+1, nrow = 1)
if (capkv > 0 ) {
delta = rbind(delta, t(vzcat))
}
if (capk > 0) {
if (sum(popmat[ipop, (capl+1):(capl+capk)]) > 0) {
#zuse = 1:st < 0
zuse = 1:ncol(zcat) < 0
for (i in 1:capk) {
if (popmat[ipop, capl+i] == 1) {
zuse[zvars == i] = TRUE
}
}
delta = rbind(delta, t(zcat[, zuse]))
# delta = rbind(1:n*0+1, t(zcat[, zuse]))
}# else {delta = matrix(1:n*0+1, nrow = 1)}
} #else {delta = matrix(1:n*0+1, nrow = 1)}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 2) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (sum(popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13) > 0) {
usex = popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13
delta = rbind(delta, t(xmat[, usex]))
}
#new:
if (caplv > 0) {
ch = shpsvx %in% c(3, 4, 11, 12)
if (any(ch)) {
vxin = vxmat[, which(ch)]
delta = rbind(delta, t(vxin))
}
}
np = dim(delta)[1]
if (capl > 0) {
for (l in 1:capl) {
if (popmat[ipop, l] > 0) {
if (popmat[ipop, l] == 1) {#incr
#print ('1')
deladd = delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 2) {#decr
#print ('2')
deladd = -delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 3) {#conv
#print ('3')
deladd = delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 4) {#conc
#print ('4')
deladd = -delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 5) {#incr.conv
#print ('5')
deladd = delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 8) {#decr.conc
#print ('8')
deladd = -delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 6) {#decr.conv
#print ('6')
deladd = delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 7) {#incr.conc
#print ('7')
deladd = -delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 9) {
#print ('9')
deladd = delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 10) {
#print ('10')
deladd = -delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 11) {
#print ('11')
deladd = delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 12) {
#print ('12')
deladd = -delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 13) {
#print ('13')
deladd = delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 16) {
#print ('16')
deladd = -delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 14) {
#print ('14')
deladd = delta_sincc[varlist_sincc == l, ]
} else if (popmat[ipop, l] == 15) {
#print ('15')
deladd = -delta_sincc[varlist_sincc == l, ]
}
delta = rbind(delta, deladd)
#print (paste('dim: ', dim(delta)))
}
}
}
if (caplv > 0) {
if (!is.null(vxcat)) {
delta = rbind(delta, t(vxcat))
}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 1) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (captv > 0) {
delta = rbind(delta, t(vtrcat))
}
ans = irls(y, delta, np, nsim = 100, family = family, weights = weights, cpar = cpar)
fitness[ipop] = -ans$cic
popmat[ipop, (capl+capk+capt+1)] = -ans$cic
}
ord = order(-fitness)
popmat = popmat[ord, ,drop = FALSE]
fitness = fitness[ord]
rslt = new.env()
rslt$pop = unname(popmat)
rslt$fitness = fitness
pop2 = matrix(0, nrow = npop, ncol = (capl+capk+capt))
for (i in 1:npop) {
pop2[i, 1:capl] = apply(popmat[i, 1:capl, drop = FALSE], 2, ShapeToChar)
}
if (capk > 0) {
for (i in 1:npop) {
pop2[i, (capl+1):(capl+capk)] = apply(popmat[i, (capl+1):(capl+capk), drop = FALSE], 2, function(num) ShapeToChar(num, tag = "z"))
}
}
if (capt > 0) {
for (i in 1:npop) {
pop2[i, (capl+capk+1):(capl+capk+capt)] = apply(popmat[i, (capl+capk+1):(capl+capk+capt), drop = FALSE], 2, function(num) ShapeToChar(num, tag = "tree"))
}
}
#colnames(pop2) = c(xnms, znms, trnms)
#rslt$pop0 = pop0
pop2 = as.data.frame(pop2, stringsAsFactors = FALSE)
pop2 = cbind(pop2, fitness)
rslt$pop2 = pop2
#rslt$top = pop2[1,]
rslt$GA = FALSE
rslt$vzcat = vzcat
#class(rslt) = "cgam"
return (rslt)
}
##############################
#tranform shapes back to char
##############################
ShapeToChar = function(shp, tag = "x") {
#if (max(shp) > 16 | min(shp) < 0) {
# stop ('No such a shape! A shape value must be between 0 and 16.')
#}
if (tag == "x") {
if (shp == 0) {
shp = 18
}
switch(shp,
cs1 = {ch = 'incr'},
cs2 = {ch = 'decr'},
cs3 = {ch = 'conv'},
cs4 = {ch = 'conc'},
cs5 = {ch = 'incr.conv'},
cs6 = {ch = 'decr.conv'},
cs7 = {ch = 'incr.conc'},
cs8 = {ch = 'decr.conc'},
cs9 = {ch = 's.incr'},
cs10 = {ch = 's.decr'},
cs11 = {ch = 's.conv'},
cs12 = {ch = 's.conc'},
cs13 = {ch = 's.incr.conv'},
cs14 = {ch = 's.incr.conc'},
cs15 = {ch = 's.decr.conv'},
cs16 = {ch = 's.decr.conc'},
cs17 = {ch = 's'},
cs18 = {ch = 'flat'}
#{print ('No such a shape')}
)
} else if (tag == "z") {
if (shp == 0) {
shp = 2
}
switch(shp,
cs1 = {ch = 'in'},
cs2 = {ch = 'out'}
)
} else if (tag == "tree") {
if (shp == 0) {
shp = 3
}
switch(shp,
cs1 = {ch = 'tree'},
cs2 = {ch = 'unordered'},
cs3 = {ch = 'out'}
)
}
return (ch)
}
#
CharToShape = function(ch) {
shp = NULL
if (ch == 'flat') {
shp = 0
} else if (ch == 'incr') {
shp = 1
} else if (ch == 'decr') {
shp = 2
} else if (ch == 'conv') {
shp = 3
} else if (ch == 'conc') {
shp = 4
} else if (ch == 'incr.conv') {
shp = 5
} else if (ch == 'decr.conv') {
shp = 6
} else if (ch == 'incr.conc') {
shp = 7
} else if (ch == 'decr.conc') {
shp = 8
} else if (ch == 's.incr') {
shp = 9
} else if (ch == 's.decr') {
shp = 10
} else if (ch == 's.conv') {
shp = 11
} else if (ch == 's.conc') {
shp = 12
} else if (ch == 's.incr.conv') {
shp = 13
} else if (ch == 's.incr.conc') {
shp = 14
} else if (ch == 's.decr.conv') {
shp = 15
} else if (ch == 's.decr.conc') {
shp = 16
} else if (ch == 's') {
shp = 17
} else {
stop ('shape not defined!')
}
return (shp)
}
############################################################
#plot fitness vs iterations #
############################################################
plot.shapeselect = function(x,...)
{
object = x
if (!object$GA) {
stop("plot.shapeselect won't work for objects not fitted by genetic algorithm ...")
}
par(mfrow = c(1, 1))
#iters = 1:100
cex.points = 0.7
col = c("slategrey","mediumorchid4")
pch = c(16, 1)
lty = c(1, 2)
mx = object$mxf
mn = object$mnf
iters = 1:length(mx)
ylim = c(min(mn), max(mx) + (max(mx) - min(mn)) * .01)
plot(iters, mx, type = "n", ylim = ylim, xlab = "Generation", ylab = "Fitness value")
grid()
legend("bottomright", bty = "n", legend = c("Best", "Mean"), col = col, pch = pch, lty = lty, pt.cex = cex.points, inset = 0.01)
points(iters, mx, type = "o", pch = pch[1], lty = lty[1], col = col[1], cex = cex.points)
for (i in 1:length(mx)) {
if (i < length(mx)) {
points(iters[i], mn[i], type = "o", pch = pch[2], lty = lty[2], col = col[2], cex = cex.points)
segments(iters[i], mn[i], iters[i+1], mn[i+1], col = "mediumorchid4", lty = lty[2])
} else {
points(iters[i], mn[i], type = "o", pch = "*", col = col[2], cex = 2.1)
Sys.sleep(.5)
points(iters[i], mn[i], type = "o", pch = "*", col = "white", cex = 2.1)
Sys.sleep(.5)
points(iters[i], mn[i], type = "o", pch = "*", col = col[2], cex = 2.5)
Sys.sleep(.5)
points(iters[i], mn[i], type = "o", pch = "*", col = "white", cex = 2.5)
Sys.sleep(.5)
points(iters[i], mn[i], type = "o", pch = "*", col = col[2], cex = 2.9)
#Sys.sleep(.5)
#points(iters[i], mn[i], type = "o", pch = "*", col = "white", cex = 2.9)
#Sys.sleep(.5)
#points(iters[i], mn[i], type = "o", pch = "*", col = col[2], cex = 3.3)
}
Sys.sleep(.03)
}
}
########################################################################
# iteratively re-weighted least squares -- binary likelihood
########################################################################
irls = function(y, bigmat, np, nsim = 100, family = gaussian, weights = NULL, cpar = 1.2) {
#linkfun = family$linkfun
cicfamily = CicFamily(family)
linkfun = cicfamily$linkfun
llh.fun = cicfamily$llh.fun
etahat.fun = cicfamily$etahat.fun
gr.fun = cicfamily$gr.fun
wt.fun = cicfamily$wt.fun
zvec.fun = cicfamily$zvec.fun
muhat.fun = cicfamily$muhat.fun
ysim.fun = cicfamily$ysim.fun
deriv.fun = cicfamily$deriv.fun
dev.fun = cicfamily$dev.fun
if (family$family == "binomial" | family$family == "poisson" | family$family == "Gamma") {
wt.iter = TRUE
} else {wt.iter = FALSE}
n = length(y)
if (is.null(weights)) {
weights = 1:n*0 + 1
}
sm = 1e-8
m = dim(bigmat)[1] - np
# new: initialize cvec
cvec = NULL
if (wt.iter) {
etahat = etahat.fun(n, y, fml = family$family)
gr = gr.fun(y, etahat, weights, fml = family$family)
wt = wt.fun(y, etahat, n, weights, fml = family$family)
cvec = wt * etahat - gr
} else {wt = wt.fun(y, etahat, n, weights, fml = family$family)}
zvec = zvec.fun(cvec, wt, y, fml = family$family)
gmat = t(bigmat %*% sqrt(diag(wt)))
if (m > 0) {
#np always >= 1
dsend = gmat[, (np + 1):(np + m), drop = FALSE]
zsend = gmat[, 1:np, drop = FALSE]
#ans = coneB(zvec, t(dsend), zsend, msg = FALSE)
ans = coneB(zvec, dsend, zsend, msg = FALSE)
face = ans$face
#ans = hingep(zvec, t(dsend), zsend)
coef = ans$coefs
etahat = t(bigmat) %*% coef
muhat = muhat.fun(etahat, fml = family$family)
if (wt.iter) {
#muhat = muhat.fun(etahat, fml = family$family)
diff = 1
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
nrep = 0
##########
#iterate!#
##########
while (diff > sm & mdiff & nrep < n^2) {
oldmu = muhat
nrep = nrep + 1
gr = gr.fun(y, etahat, weights, fml = family$family)
wt = wt.fun(y, etahat, n, weights, fml = family$family)
cvec = wt * etahat - gr
zvec = zvec.fun(cvec, wt, y, fml = family$family)
gmat = t(bigmat %*% sqrt(diag(wt)))
dsend = gmat[, (np + 1):(np + m), drop = FALSE]
zsend = gmat[, 1:np, drop = FALSE]
#ans = coneB(zvec, t(dsend), zsend, msg = FALSE)
ans = coneB(zvec, dsend, zsend, msg = FALSE, face = face)
coef = ans$coefs
etahat = t(bigmat) %*% coef
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
mdiff = abs(max(muhat) - 1)
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
}
}
} else {
prior.w = weights
vmat = t(bigmat[1:np, , drop = FALSE])
w = diag(prior.w)
coef = solve(t(vmat) %*% w %*% vmat) %*% t(vmat) %*% w %*% y
etahat = vmat %*% coef
muhat = muhat.fun(etahat, fml = family$family)
if (wt.iter) {
nrep = 0
muhat = mean(y) + 1:n*0
etahat = linkfun(muhat)
diff = 1
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
while (diff > sm & mdiff & nrep < n^2) {
nrep = nrep + 1
oldmu = muhat
zhat = etahat + (y - muhat) * deriv.fun(muhat, fml = family$family)
#w <- diag(as.vector(prior.w / deriv.fun(muhat)))
w = diag(as.vector(prior.w * (deriv.fun(muhat, fml = family$family))^(-1)))
coef = solve(t(vmat) %*% w %*% vmat) %*% t(vmat) %*% w %*% zhat
etahat = vmat %*% coef
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
mdiff = abs(max(muhat) - 1)
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
}
}
}
#muhat = muhat.fun(etahat, fml = family$family)
llh = llh.fun(y, muhat, etahat, phihat=NULL, n, weights, fml = family$family)
mukeep = muhat
coefkeep = coef
if (np > 0) {zcoefs = coefkeep[1:np]}
### get edf0
if (m > 0) {
dfs = 1:nsim*0
sm = 1e-5
if (family$family == "poisson") {
mu0 = mean(y)
eta0 = log(mu0)
} else {mu0 = NULL}
for (isim in 1:nsim) {
#print (isim)
ysim = ysim.fun(n, mu0 = mu0, fml = family$family)
if (wt.iter) {
etahat = etahat.fun(n, ysim, fml = family$family)
gr = gr.fun(ysim, etahat, weights, fml = family$family)
wt = wt.fun(ysim, etahat, n, weights, fml = family$family)
cvec = wt * etahat - gr
} else {wt = wt.fun(ysim, etahat, n, weights, fml = family$family)}
zvec = zvec.fun(cvec, wt, ysim, fml = family$family)
gmat = t(bigmat %*% sqrt(diag(wt)))
dsend = gmat[, (np + 1):(np + m), drop = FALSE]
zsend = gmat[, 1:np, drop = FALSE]
#ans = try(coneB(zvec, t(dsend), zsend, msg = FALSE))
ans = try(coneB(zvec, dsend, zsend, msg = FALSE))
face = ans$face
#if (class(ans) == "try-error") next
if(inherits(ans, "try-error")) next
if (wt.iter) {
etahat = t(bigmat) %*% ans$coefs
muhat = muhat.fun(etahat, fml = family$family)
diff = 1
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
##########
#iterate!#
##########
nrep = 0
while (diff > sm & nrep < n^2 & mdiff > sm) {
nrep = nrep + 1
oldmu = muhat
gr = gr.fun(ysim, etahat, weights, fml = family$family)
wt = wt.fun(ysim, etahat, n, weights, fml = family$family)
cvec = wt * etahat - gr
#zvec <- cvec / sqrt(wt)
zvec = zvec.fun(cvec, wt, y, fml = family$family)
gmat = t(bigmat %*% sqrt(diag(wt)))
dsend = gmat[, (np + 1):(np + m), drop = FALSE]
zsend = gmat[, 1:np, drop = FALSE]
#ans = try(coneB(zvec, t(dsend), zsend, msg = FALSE))
ans = try(coneB(zvec, dsend, zsend, msg = FALSE, face = face))
#if (class(ans) == "try-error") next
if(inherits(ans, "try-error")) next
etahat = t(bigmat) %*% ans$coefs
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
}
}
dfs[isim] = sum(abs(ans$coefs) > 0)
}
dfmean = mean(dfs)
} else {dfmean = np}
rslt = new.env()
rslt$edf0 = dfmean
rslt$llh = llh
rslt$fhat = mukeep
rslt$coefs = coefkeep
#cdose$cic = llh+log(1+2*dfmean/(n-np-1.5*(dfmean-np)))
if ((n - np - cpar * (dfmean - np)) <= 0) {
rslt$cic <- llh + log(1 + 2 * dfmean / (dfmean - np))
} else {
rslt$cic <- llh + log(1 + 2 * dfmean / (n - np - cpar * (dfmean - np)))
}
rslt
}
#### TRIANGLE SPLINE ######
## y is response
## x1, x2 are continuous predictors
## zmat is matrix of parametrically modeled covariates
## for fixed covariate values, E(y) is convex in (x1,x2) -- nonadditive!
####
trispl.fit = function(x1t, x2t, y, zmat = NULL, xmat_add = NULL, delta_add = NULL, varlist_add = NULL, shapes_add = NULL, np_add = 0, xmat_wp = NULL, delta_wp = NULL, varlist_wps = NULL, amat_wp = NULL, dmat_wp = NULL, w = NULL, lambda = 0, pnt = TRUE, cpar = 1.2, cvss = c(TRUE, TRUE), delta = NULL, kts = NULL, nkts = NULL, wt.iter = FALSE, family = gaussian(), nsim = 0, nprs = 1) {
#additive + tri surface + z(exclude one) + warp surface
cicfamily = CicFamily(family)
linkfun = cicfamily$linkfun
llh.fun = cicfamily$llh.fun
etahat.fun = cicfamily$etahat.fun
gr.fun = cicfamily$gr.fun
wt.fun = cicfamily$wt.fun
zvec.fun = cicfamily$zvec.fun
muhat.fun = cicfamily$muhat.fun
ysim.fun = cicfamily$ysim.fun
deriv.fun = cicfamily$deriv.fun
dev.fun = cicfamily$dev.fun
n = length(y)
#zmat not includes one
if (!is.null(zmat)){
if (length(zmat) == n) {
zmat = matrix(zmat, ncol = 1)
}
p = dim(zmat)[2]
} else{p = 0}
#print (p)
#one = 1:n*0 + 1
#if (is.null(zmat)) {
# zmat = matrix(one, ncol = 1)
#} else {
# if (dim(zmat)[1] != n) {
# stop ("Error: # rows of zmat must equal length of y")
# }
# zproj = zmat %*% solve(crossprod(zmat), t(zmat))
# onep = one - zproj %*% one
# if the one vector is not in the space of zmat, then include the one vector in zmat
# if (sum(onep^2) > 1e-12) {
# zmat = cbind(one, zmat)
# }
#}
#p = dim(zmat)[2]
dimnames(zmat)[[2]] = NULL
if (nprs >= 1) {
amat_lst = list()
#penalty matrix
#Pmat = NULL
pmat_lst = list()
knots_lst = list()
m12_lst = list()
trimat_lst = list()
bmat_lst = list()
capk_lst = list()
#design matrix
Dmat = NULL
varlist = NULL
#print (nkts)
for (ipr in 1:nprs) {
cvs = cvss[[ipr]]
x1 = x1t[,ipr]
x2 = x2t[,ipr]
nktsi = nkts[[ipr]]
if (length(x1) != n | length(x2) != n) {
stop ("ERROR -- x1, x2, and y must have same lengths")
}
xmat = cbind(x1, x2)
#temp:
#if (nktsi[1] > 0) {
# m1 = nktsi[i]
#} else {
#m1 = 2 + round(n^(1/3))
m1 = round(5*n^(1/6))
#}
s = (max(x1) - min(x1)) / (m1-1)
h = s*sqrt(3) / 2
m2 = trunc((max(x2) - min(x2)) / h) + 2
m0 = trunc(m2/2)
capk = 2*m0*m1+m0
if (m0 < m2/2) {
capk = capk+m1+1
}
knots = matrix(0, nrow = capk, ncol = 2)
l1 = min(x1)-s/2
u1 = max(x1)+s/2
l2 = min(x2)
u2 = l2 + (m2-1)*h
rw = 0
for (i in 1:m0) {
for (j in 1:(m1 + 1)) {
rw = rw + 1
knots[rw,1] = l1 + (j - 1) * s
knots[rw,2] = l2 + (i - 1) * 2 * h
}
for (j in 1:m1) {
rw = rw + 1
knots[rw,1] = l1 + s/2 + (j - 1) * s
knots[rw,2] = l2 + (i - 1) * 2 * h + h
}
}
if (m0 < m2/2) {
i = m0 + 1
for (j in 1:(m1 + 1)) {
rw = rw + 1
knots[rw,1] = l1 + (j - 1) * s
knots[rw,2] = l2 + (i - 1) * 2 * h
}
}
knots[,2] = knots[,2] - (u2 - max(x2))/2
u2 = max(knots[,2])
l2 = min(knots[,2])
# plot(c(l1,u1),c(l2,u2),pch = "")
# points(x1,x2,col = "slategray")
# points(knots[,1],knots[,2],pch = 20)
### now number the triangles and give knots for each
ntri = (m2 - 1) * (2 * m1 - 1)
trimat = matrix(0, nrow = ntri, ncol = 3)
if (m0 == m2/2) {
mlim = m0 - 1
} else {mlim = m0}
rt = 0
for (i in 1:mlim) {
for (j in 1:m1) {
rt = rt + 1
trimat[rt,1] = (2*m1 + 1)*(i - 1) + j
trimat[rt,2] = (2*m1 + 1)*(i - 1) + j + 1
trimat[rt,3] = (2*m1 + 1)*(i - 1) + m1 + 1 + j
}
for (j in 1:(m1 - 1)) {
rt = rt + 1
trimat[rt,1] = (2*m1 + 1)*(i - 1) + j + 1
trimat[rt,2] = (2*m1 + 1)*(i - 1) + m1 + 1 + j
trimat[rt,3] = (2*m1 + 1)*(i - 1) + m1 + 2 + j
}
for (j in 1:(m1 - 1)) {
rt = rt + 1
trimat[rt,1] = (2*m1 + 1)*i + j + 1
trimat[rt,2] = (2*m1 + 1)*(i - 1) + m1 + 1 + j
trimat[rt,3] = (2*m1 + 1)*(i - 1) + m1 + 2 + j
}
for (j in 1:m1) {
rt = rt + 1
trimat[rt,1] = (2*m1 + 1)*(i - 1) + m1 + 1 + j
trimat[rt,2] = (2*m1 + 1)*i + j
trimat[rt,3] = (2*m1 + 1)*i + j + 1
}
}
if (m0 == m2/2) {
i = m0
for (j in 1:m1) {
rt = rt + 1
trimat[rt,1] = (2*m1 + 1)*(i - 1) + j
trimat[rt,2] = (2*m1 + 1)*(i - 1) + j + 1
trimat[rt,3] = (2*m1 + 1)*(i - 1) + m1 + 1 + j
}
for (j in 1:(m1 - 1)) {
rt = rt + 1
trimat[rt,1] = (2*m1 + 1)*(i - 1) + j + 1
trimat[rt,2] = (2*m1 + 1)*(i - 1) + m1 + 1 + j
trimat[rt,3] = (2*m1 + 1)*(i - 1) + m1 + 2 + j
}
}
#### for each triangle, list adjacent knots (up to three)
#print (trimat)
adjk = matrix(0,nrow = ntri,ncol = 3)
kij = 1:6
s1 = 1:3
s2 = 1:3
found = 1:ntri*0
for (i in 1:(ntri - 1)) {
for (j in (i + 1):ntri) {
kij[1:3] = trimat[i,]
kij[4:6] = trimat[j,]
if (length(unique(kij)) == 4) {
found[i] = found[i] + 1
found[j] = found[j] + 1
s1[1] = sum(kij == trimat[i,1])
s1[2] = sum(kij == trimat[i,2])
s1[3] = sum(kij == trimat[i,3])
s2[1] = sum(kij == trimat[j,1])
s2[2] = sum(kij == trimat[j,2])
s2[3] = sum(kij == trimat[j,3])
adjk[i,found[i]] = (kij[4:6])[s2 == 1]
adjk[j,found[j]] = (kij[1:3])[s1 == 1]
}
}
}
#### now determine which triangle contains each point
xtri = 1:n*0;still = 1:n>0
for (j in 1:ntri) {
for (i in 1:n) {
if (still[i]) {
if (intri(xmat[i,],knots[trimat[j,1],],knots[trimat[j,2],],knots[trimat[j,3],])) {
still[i] = FALSE
xtri[i] = j
}
}
}
}
### make the design matrix
dmat = matrix(0, nrow = n, ncol = capk)
bmat = matrix(1, nrow = 3, ncol = 3)
a = 1:3
for (i in 1:n) {
for (j in 1:3) {
a[j] = trimat[xtri[i],j]
bmat[j,2] = knots[a[j],1]
bmat[j,3] = knots[a[j],2]
}
binv = solve(bmat)
for (j in 1:3) {
dmat[i,a[j]] = binv[1,j] + binv[2,j]*x1[i] + binv[3,j]*x2[i]
}
}
#dmatc = cbind(dmat,zmat)
Dmat = cbind(Dmat, dmat)
vari = 1:capk*0 + ipr
varlist = c(varlist, vari)
#print (head(dmatc))
### make the constraint matrix
nconstr = sum(adjk > 0)
amat = matrix(0, nrow = nconstr, ncol = capk)
nr = 0
for (itri in 1:ntri) {
a = trimat[itri,]
for (j in 1:3) {
bmat[j,2] = knots[a[j],1]
bmat[j,3] = knots[a[j],2]
}
binv = solve(bmat)
for (i in 1:3) {
k = adjk[itri,i]
if(k > 0) {
nr = nr + 1
amat[nr,k] = 1
for (j in 1:3) {
amat[nr,a[j]] = -(binv[1,j] + binv[2,j]*knots[k,1] + binv[3,j]*knots[k,2])
}
}
}
}
#m = dim(amat)[1]
#a0 = matrix(0, nrow = m, ncol = p)
#new: s.conc.conc
if (all(!cvs)) {
amat = -amat
} else if (any(cvs) & any(!cvs)) {
stop ('Convex-concave or concave-convex fit is not implemented!')
}
amat_lst[[ipr]] = amat
#amatc = cbind(amat, a0)
## make the penalty matrix
# find common edges & penalize change in slope
pmat = matrix(0, nrow = 4 * m1 * m2,ncol = capk)
six = 1:6;nu = 1:4;obs = 1:4
nr = 0
for (i in 1:(ntri-1)) {
for (j in (i + 1):ntri) {
six[1:3] = trimat[i,]
six[4:6] = trimat[j,]
sixu = unique(six)
if (length(sixu) == 4) {
nr = nr + 1
for (ii in 1:4) {nu[ii] = sum(six == sixu[ii])}
a = sixu[min(obs[nu == 2])]
b = sixu[max(obs[nu == 2])]
c = sixu[min(obs[nu == 1])]
d = sixu[max(obs[nu == 1])]
bmat[1,2] = knots[a,1]
bmat[1,3] = knots[a,2]
bmat[2,2] = knots[b,1]
bmat[2,3] = knots[b,2]
bmat[3,2] = knots[c,1]
bmat[3,3] = knots[c,2]
binv = solve(bmat)
pmat[nr,a] = binv[1,1] + binv[2,1] * knots[d,1] + binv[3,1] * knots[d,2]
pmat[nr,b] = binv[1,2] + binv[2,2] * knots[d,1] + binv[3,2] * knots[d,2]
pmat[nr,c] = binv[1,3] + binv[2,3] * knots[d,1] + binv[3,3] * knots[d,2]
pmat[nr,d] = -1
}
}
}
pmat = pmat[1:nr,]
#p0 = matrix(0, nrow = nr, ncol = p)
#Pmat = cbind(Pmat, pmat)
#pmatc = cbind(pmat, p0)
pmat_lst[[ipr]] = pmat
#print (paste('nr: ', nr))
knots_lst[[ipr]] = knots
m12_lst[[ipr]] = c(m1,m2)
trimat_lst[[ipr]] = trimat
bmat_lst[[ipr]] = bmat
capk_lst[[ipr]] = capk
}
amat = as.matrix(bdiag(amat_lst))
m = dim(amat)[1]
if (p > 0) {
a0 = matrix(0, nrow = m, ncol = p)
} else {a0 = NULL}
amatc = cbind(amat, a0)
#one = 1:n*0 + 1
#pm = one %*% solve(crossprod(one), t(one))
#Dmat = Dmat - pm %*% Dmat
dmatc = cbind(Dmat, zmat)
pmat = as.matrix(bdiag(pmat_lst))
if (p > 0) {
p0 = matrix(0, nrow = nrow(pmat), ncol = p)
} else {p0 = NULL}
pmatc = cbind(pmat, p0)
#capk is for all columns of tri-surfaces pairs
capk = sum(unlist(capk_lst))
}
#print (dim(amatc))
nr = nrow(amatc); nc = ncol(amatc)
pb = 0
if (!is.null(delta_add)) {
pb = nrow(delta_add)
dmatc = cbind(t(delta_add), dmatc)
}
if (pb >= 1) {
tmp = matrix(0, nrow = (nr+pb), ncol = (nc+pb))
amatb = diag(pb)
#np_add is shape == 17
if (np_add > 0) {
amatb[1:np_add,1:np_add] = 0
}
tmp[1:pb,1:pb] = amatb
tmp[(pb+1):(nr+pb), (pb+1):(nc+pb)] = amatc
amatc = tmp
}
if (pb >= 1) {
pmatb = matrix(0, nrow = dim(pmatc)[1], ncol = pb)
pmatc = cbind(pmatb, pmatc)
}
if (!is.null(amat_wp)) {
pwp = ncol(delta_wp)
dmatc = cbind(dmatc, delta_wp)
amatc = as.matrix(bdiag(amatc, amat_wp))
pmatc = as.matrix(bdiag(pmatc, dmat_wp))
} else {pwp = 0}
#new: always let lambda > 0
if (round(lambda, 6) > 1e-6) {
ps = lambda
#} else if (pnt & (round(lambda, 6) == 0)) {
#mat = cbind(1, x1, x2, x1*x2)
#mat = cbind(1, x1t[,1], x2t[,1], x1t[,1]*x2t[,1])
#if (nprs >= 2) {
# for (ipr in 2:nprs) {
# mat = cbind(mat, x1t[,ipr], x2t[,ipr], x1t[,ipr]*x2t[,ipr])
# }
#}
#mu_para = mat %*% solve(t(mat) %*% mat) %*% t(mat) %*% y
#ssr = sum((y - mu_para)^2)
#sc = ssr / (n - ncol(mat))
#ps = max(1e-6, 1 * sc)
} else {
ps = 10*1/n^(1/3)
#ps = 1e-6
}
lambda = ps
#print (paste('pen:',lambda))
if (!wt.iter) {
# weight
yw = y
dw = dmatc
if (!is.null(w)) {
if (min(w) > 1e-8) {
yw = y * sqrt(w)
for (i in 1:n) {
dw[i, ] = dmatc[i, ] * sqrt(w[i])
}
} else {print ("check the user-defined weights!")}
}
#print (dim(dmatc))
umatc = chol(t(dw) %*% dw + lambda * t(pmatc) %*% pmatc)
uinv = solve(umatc)
atil = amatc %*% uinv
zvec = t(uinv) %*% t(dw) %*% yw
ans = coneA(zvec, atil)
thhat = uinv %*% ans$thetahat
muhat = dmatc %*% thhat
etahat = muhat
} else {
etahat = etahat.fun(n, y, fml = family$family)
gr = gr.fun(y, etahat, weights = w, fml = family$family)
wt = wt.fun(y, etahat, n, weights = w, fml = family$family)
cvec = crossprod(dmatc, (wt * etahat - gr))
umatc = chol(t(dmatc) %*% diag(wt) %*% dmatc + lambda * t(pmatc) %*% pmatc)
uinv = solve(umatc)
atil = amatc %*% uinv
zvec = t(uinv) %*% t(dmatc) %*% y
ans = coneA(zvec, atil)
thhat = uinv %*% ans$thetahat
etahat = dmatc %*% thhat
muhat = muhat.fun(etahat, fml = family$family)
diff = 1
nrep = 0
sm = 1e-6
while (diff > sm & nrep < 100) {
oldmu = muhat
nrep = nrep + 1
gr = gr.fun(y, etahat, weights = w, fml = family$family)
wt = wt.fun(y, etahat, n, weights = w, fml = family$family)
cvec = crossprod(dmatc, (wt * etahat - gr))
umatc = chol(t(dmatc) %*% diag(wt) %*% dmatc + lambda * t(pmatc) %*% pmatc)
uinv = solve(umatc)
atil = amatc %*% uinv
zvec = t(uinv) %*% t(dmatc) %*% y
ans = coneA(zvec, atil)
thhat = uinv %*% ans$thetahat
etahat = dmatc %*% thhat
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
}
#llh = llh.fun(y, muhat, etahat, n, w, fml = family$family)
}
llh = llh.fun(y, muhat, etahat, phihat=NULL, n, w, fml = family$family)
coefkeep = ans$thetahat
muhatkeep = muhat
etahatkeep = etahat
thhatkeep = thhat
if (pb > 0) {
#print (dim(delta_add))
#print (varlist_add)
coef_add = thhat[1:pb]
capl = ncol(xmat_add)
thvecs = matrix(0, nrow = capl, ncol = n)
ncon = 0
#vcoef_add = coef_add[1:capl]
vcoef_add = coef_add[1:np_add]
lconv = sum(shapes_add > 2 & shapes_add < 5 | shapes_add > 10 & shapes_add < 13)
if (lconv > 0) {
dcoefs = coef_add[-c(1:lconv)]
delta_add2 = delta_add[-c(1:lconv), ,drop = FALSE]
} else {
dcoefs = coef_add
delta_add2 = delta_add
}
for (i in 1:capl) {
thvecs[i,] = t(delta_add2[varlist_add == i,]) %*% dcoefs[varlist_add == i]
if (shapes_add[i] > 2 & shapes_add[i] < 5 | shapes_add[i] > 10 & shapes_add[i] < 13) {
ncon = ncon + 1
thvecs[i,] = thvecs[i,] + vcoef_add[ncon] * xmat_add[,i]
}
}
} else {coef_add = 0; thvecs = NULL}
if (p > 0) {
zcoefs = thhat[(pb+capk+1):(pb+capk+p)]
} else {zcoefs = 0}
if (pwp > 0) {
nth = length(thhat)
coef_wp = thhat[(nth-pwp+1):nth]
} else {coef_wp = 0}
#vcoefs include zcoefs and shape = 17
vcoefs = zcoefs
#vmat = dmatc[,(pb+capk+1):(pb+capk+p), drop=F]
#vmat = cbind(1:n*0+1, zmat)
vmat = zmat
if (np_add > 0) {
vcoefs = c(thhat[1:np_add], vcoefs)
vmat = cbind(dmatc[, 1:np_add, drop=F], vmat)
}
#pv = vmat %*% solve(crossprod(vmat), t(vmat))
if (is.null(vmat)) {
muvhat = 0
} else {
muvhat = muhat.fun(vmat %*% vcoefs, fml = family$family)
}
if (is.null(w)) {
w = rep(1, n)
}
sse1 = sum(w*(y - muhat)^2)
sse0 = sum(w*(y - muvhat)^2)
#new use edf instead if (n - cpar * edf) < 0
if (!is.null(vmat)) {
np = ncol(vmat)
} else {np = 0}
### find the GCV
atil0 = atil[round(atil %*% coefkeep, 8) == 0,]
ans1 = qr(t(atil0))
ared = qr.Q(ans1)[,1:ans1$rank]
prmat = ared %*% solve(t(ared) %*% ared) %*% t(ared)
#imat = matrix(0, nrow = capk+p, ncol = capk+p)
#for (i in 1:(capk+p)) {imat[i,i] = 1}
#diag(imat) = 1
imat = diag(ncol(dmatc))
bigpr = dmatc %*% uinv %*% (imat - prmat) %*% t(uinv) %*% t(dmatc)
edf = sum(diag(bigpr))
gcv = sse1 / (1 - edf/n)^2
#if ((n - np - cpar * edf) <= 0) {
if ((n - cpar * edf) <= 0) {
sig2hat = sse1 / edf
} else {
sig2hat = sse1 / (n - cpar * edf)
}
#print (sig2hat)
#if (p >= 1) {
# #inmat = matrix(0, nrow = n, ncol = n)
# #diag(inmat) = 1
# inmat = diag(n)
# one = 1:n*0+1
# pm = one %*% solve(crossprod(one)) %*% t(one)
#print (dim(zmat))
#print (dim(bigpr))
# covmat = solve(t(zmat) %*% (inmat - bigpr) %*% zmat)
# print (covmat)
# print (sig2hat)
# sez = sqrt(diag(covmat) * sig2hat)
# tz = zcoef / sez
#new use edf instead if (n - cpar * edf) < 0
# if ((n - p - cpar * edf) <= 0) {
# pz = 2 * (1 - pt(abs(tz), edf))
# if (p > 1) {
# warning ('Effective degrees of freedom is close to the number of observations! Inference about parametric covariates is not reliable!')
# }
#print ('Check pz!')
# } else {
# pz = 2 * (1 - pt(abs(tz), n - p - cpar * edf))
# }
#} else {pz = NULL; sez = NULL}
pz = NULL; sez = NULL
#new: get cic
cic = NULL
if (is.null(w)) {
w = rep(1, n)
}
dw = dmatc
for (i in 1:n) {
dw[i, ] = dmatc[i, ] * sqrt(w[i])
}
if (nsim > 0) {
edfs = 1:nsim*0
if (!wt.iter) {
for (isim in 1:nsim) {
ysim = rnorm(n)
ysim = ysim * sqrt(w)
zvec = t(uinv) %*% t(dw) %*% ysim
ansi = coneA(zvec, atil, msg=FALSE)
thhati = uinv %*% ansi$thetahat
muhati = dmatc %*% thhati
etahati = muhati
edfi = tri_getedf(cf = ansi$thetahat, atil, dmatc, uinv, ncol(dmatc))
edfs[isim] = edfi
}
#cic = log(sse1) + log(2 * (mean(edfs) + p) / (n - p - 1.5 * mean(edfs)) + 1)
#cic = llh + log(2 * (mean(edfs) + p) / (n - p - 1.5 * mean(edfs)) + 1)
cic = llh + log(2 * (mean(edfs)) / (n - np - 1.5 * (mean(edfs) - np)) + 1)
} else {
if (family$family == "poisson") {
mu0 = mean(y)
} else {mu0 = NULL}
for (isim in 1:nsim) {
ysim = ysim.fun(n, mu0, fml = family$family)
etahat = etahat.fun(n, ysim, fml = family$family)
gr = gr.fun(ysim, etahat, weights = w, fml = family$family)
wt = wt.fun(ysim, etahat, n, weights = w, fml = family$family)
cvec = crossprod(dmatc, (wt * etahat - gr))
umatc = chol(t(dmatc) %*% diag(wt) %*% dmatc + lambda * t(pmatc) %*% pmatc)
uinv = solve(umatc)
atil = amatc %*% uinv
zvec = t(uinv) %*% t(dmatc) %*% ysim
ansi = coneA(zvec, atil, msg=FALSE)
thhat = uinv %*% ansi$thetahat
etahat = dmatc %*% thhat
muhat = muhat.fun(etahat, fml = family$family)
diff = 1
nrep = 0
while (diff > sm & nrep < 100) {
oldmu = muhat
nrep = nrep + 1
gr = gr.fun(ysim, etahat, weights = w, fml = family$family)
wt = wt.fun(ysim, etahat, n, weights = w, fml = family$family)
cvec = crossprod(dmatc, (wt * etahat - gr))
umatc = chol(t(dmatc) %*% diag(wt) %*% dmatc + lambda * t(pmatc) %*% pmatc)
uinv = solve(umatc)
atil = amatc %*% uinv
zvec = t(uinv) %*% t(dmatc) %*% ysim
ansi = coneA(zvec, atil)
thhat = uinv %*% ansi$thetahat
etahat = dmatc %*% thhat
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
}
edfi = tri_getedf(cf = ansi$thetahat, atil, dmatc, uinv, ncol(dmatc))
edfs[isim] = edfi
}
#cic = llh + log(2 * (mean(edfs) + p) / (n - p - 1.5 * mean(edfs)) + 1)
cic = llh + log(2 * (mean(edfs)) / (n - np - 1.5 * (mean(edfs) - np)) + 1)
}
}
ans = new.env()
ans$family = family
ans$edf = edf
if (nsim > 0) {
ans$edf0 = mean(edfs) #+ p
} else {ans$edf0 = p}
ans$zcoefs = zcoefs
ans$pvals.beta = pz
ans$se.beta = sez
ans$muhat = muhatkeep
ans$etahat = etahatkeep
ans$gcv = gcv
#ans$knots = knots
ans$thhat = thhatkeep
ans$coef_tri = thhatkeep[(pb+1):(pb+capk)]
ans$trimat = trimat
ans$x1 = x1
ans$x2 = x2
ans$d0 = p
ans$zmat = zmat
ans$capk = capk
ans$cic = cic
ans$sse1 = sse1
#ans$sse0 = sse0
ans$varlist = varlist
ans$coef_add = coef_add
ans$coef_wp = coef_wp
ans$etacomps = thvecs
ans$pen = lambda
ans$knots_lst = knots_lst
#new: in trispl, knots' length is not m1 or m2, it's much larger
ans$m12_lst = m12_lst
ans$trimat_lst = trimat_lst
ans$bmat_lst = bmat_lst
ans$capk_lst = capk_lst
#new
ans$dmatc = dmatc
ans$pmatc = pmatc
ans$amatc = amatc
ans$sig2hat = sig2hat
ans
}
tri_getedf = function(cf = NULL, atil, dmatc, uinv, nc) {
atil0 = atil[round(atil %*% cf, 8) == 0,]
ans1 = qr(t(atil0))
ared = qr.Q(ans1)[,1:ans1$rank]
prmat = ared %*% solve(t(ared) %*% ared) %*% t(ared)
imat = diag(nc)
bigpr = dmatc %*% uinv %*% (imat - prmat) %*% t(uinv) %*% t(dmatc)
edf = sum(diag(bigpr))
return (edf)
}
###
#trispl makedelta: used in predict.trispl
###
makedelta_tri = function(x1, x2, m1 = 0, m2 = 0, k1 = NULL, k2 = NULL, trimat = NULL, capk = NULL, space = c("E",
"E"), cvs = c(TRUE, TRUE), interp = TRUE) {
n = length(x1)
xmat = cbind(x1, x2)
delta = NULL
#### now determine which triangle contains each point
xtri = 1:n*0;still = 1:n>0
ntri = (m2 - 1) * (2 * m1 - 1)
knots = cbind(k1, k2)
for (j in 1:ntri) {
for (i in 1:n) {
if (still[i]) {
if (intri(xmat[i,],knots[trimat[j,1],],knots[trimat[j,2],],knots[trimat[j,3],])) {
still[i] = FALSE
xtri[i] = j
}
}
}
}
### make the design matrix
dmat = matrix(0, nrow = n, ncol = capk)
bmat = matrix(1, nrow = 3, ncol = 3)
a = 1:3
for (i in 1:n) {
for (j in 1:3) {
a[j] = trimat[xtri[i],j]
bmat[j,2] = knots[a[j],1]
bmat[j,3] = knots[a[j],2]
}
binv = solve(bmat)
for (j in 1:3) {
dmat[i,a[j]] = binv[1,j] + binv[2,j]*x1[i] + binv[3,j]*x2[i]
}
}
delta = cbind(delta, dmat)
return (delta)
}
##
s.conv.conv <- function(x1, x2, numknots = c(0, 0), knots = list(k1 = 0, k2 = 0), space = c("E", "E"))
{
cl <- match.call()
pars1 <- match.call()[2]
pars2 <- match.call()[3]
xm <- cbind(x1, x2)
attr(xm, "name") <- c(deparse(pars1$x1), deparse(pars2$x2))
attr(xm, "shape") <- "tri_cvs"
attr(xm, "numknots") <- numknots
attr(xm, "knots") <- knots
attr(xm, "space") <- space
attr(xm, "cvs") <- c(TRUE, TRUE)
attr(xm, "categ") <- "tri"
#warp <<- TRUE
#class(xm) <- "tri"
return (xm)
}
s.conc.conc <- function(x1, x2, numknots = c(0, 0), knots = list(k1 = 0, k2 = 0), space = c("E", "E"))
{
cl <- match.call()
pars1 <- match.call()[2]
pars2 <- match.call()[3]
xm <- cbind(x1, x2)
attr(xm, "name") <- c(deparse(pars1$x1), deparse(pars2$x2))
attr(xm, "shape") <- "tri_ccs"
attr(xm, "numknots") <- numknots
attr(xm, "knots") <- knots
attr(xm, "space") <- space
attr(xm, "cvs") <- c(FALSE, FALSE)
attr(xm, "categ") <- "tri"
#warp <<- TRUE
#class(xm) <- "tri"
return (xm)
}
################
#summary.trispl#
################
#summary.trispl <- function(object,...) {
# if (!is.null(object$zcoefs)) {
# coefs <- object$zcoefs
# se <- object$se.beta
# #tval <- object$tz
# pvalbeta <- object$pvals.beta
# tval <- coefs / se
# n <- length(coefs)
# #sse0 <- object$SSE0
# #sse1 <- object$SSE1
# zid <- object$zid
#new: zid1, zid2 just index zmat not bigmat
# zid1 <- object$zid1
# zid2 <- object$zid2
# #tms <- object$tms
# #zmat <- object$zmat
# #is_mat <- object$is_mat
# is_param <- object$is_param
# is_fac <- object$is_fac
# vals <- object$vals
# tms <- object$tms
#new:
# cic <- object$cic
# rslt1 <- data.frame("Estimate" = round(coefs, 4), "StdErr" = round(se, 4), "t.value" = round(tval, 4), "p.value" = round(pvalbeta, 4))
# rownames(rslt1)[1] <- "(Intercept)"
# if (n > 1) {
# lzid <- length(zid1)
# for (i in 1:lzid) {
# pos1 <- zid1[i]; pos2 <- zid2[i]
# for (j in pos1:pos2) {
# if (!is_param[i]) {
# rownames(rslt1)[j + 1] <- paste(attributes(tms)$term.labels[zid[i] - 1], rownames(rslt1)[j + 1], sep = "")
# } else {
# rownames(rslt1)[j + 1] <- paste(attributes(tms)$term.labels[zid[i] - 1], vals[j], sep = "")
# }
# }
# }
# }
# rslt1 <- as.matrix(rslt1)
# #if (!is.null(sse0) & !is.null(sse1)) {
# # rslt2 <- data.frame("SSE.Linear" = sse0, "SSE.Full" = sse1)
#new:
# # rownames(rslt2)[1] <- ""
# #rslt2 <- as.matrix(rslt2)
# # ans <- list(call = object$call, coefficients = rslt1, residuals = rslt2, zcoefs = coefs)
# # class(ans) <- "summary.wps"
# # ans
# #} else {
# ans <- list(call = object$call, coefficients = rslt1, zcoefs = coefs, cic = cic)
# class(ans) <- "summary.trispl"
# ans
# #}
# } else {
# ans <- list(zcoefs = object$zcoefs)
# class(ans) <- "summary.trispl"
# ans
# }
#}
#######################
#print.summary.trispl #
#######################
#print.summary.trispl <- function(x,...) {
# if (!is.null(x$zcoefs)) {
# #if (!is.null(x$se.beta)) {
# cat("Call:\n")
# print(x$call)
# cat("\n")
# cat("Coefficients:")
# cat("\n")
# printCoefmat(x$coefficients, P.values = TRUE, has.Pvalue = TRUE)
# cat("\n")
# if (!is.null(x$cic)) {
# cat("CIC: ", round(x$cic,4), "\n", sep = "")
# }
# } else {
# print ("No linear predictor is defined")
# }
#}
#################
#plotpersp.tri#
################
plotpersp.trispl = function(object, x1 = NULL, x2 = NULL, x1nm = NULL, x2nm = NULL,
data = NULL, surface = "C", categ = NULL, col = NULL,
random = FALSE, ngrid = 12, xlim = range(x1),
ylim = range(x2), zlim = NULL, xlab = NULL,
ylab = NULL, zlab = NULL, th = NULL, ltheta = NULL,
main = NULL, ticktype = "simple",...) {
if (!inherits(object, "trispl")) {
warning("calling plotpersp(<fake-trisp-object>) ...")
}
#x1nm = deparse(substitute(x1))
#x2nm = deparse(substitute(x2))
xnms = object$xnms_tri
xmat = object$xmat_tri
#if (x1nm == "NULL" | x2nm == "NULL") {
if (is.null(x1nm) | is.null(x2nm)) {
if (length(xnms) >= 2) {
x1nm = xnms[1]
x2nm = xnms[2]
x1id = 1
x2id = 2
x1 = xmat[, 1]
x2 = xmat[, 2]
} else {stop ("Number of non-parametric predictors must >= 2!")}
}
#x1nm0 = xnms[1]
#x2nm0 = xnms[2]
#x1 = xmat[, 1]
#x2 = xmat[, 2]
is_fac = object$is_fac
ynm = object$ynm
#xmat is delta
#delta = object$delta
znms = object$znms
kznms = length(znms)
#zmat not include 1 vector
zmat = object$zmat
#zmat0 = zmat[, -1, drop = FALSE]
zmat0 = zmat
#zcoefs = object$zcoefs[-1]
zcoefs = object$zcoefs
zid1 = object$zid1
zid2 = object$zid2
p = object$d0
cvss = object$cvss
labels = object$labels
labels = labels[which(grepl("tri", labels, fixed = TRUE))]
varlist = object$varlist_tri
#varlist = varlist[-1]
#knots = object$kts
#trimat = object$trimat
family = object$family
fml = family$family
#print (family)
cicfamily = CicFamily(family)
muhat.fun = cicfamily$muhat.fun
#if (!is.null(categ)) {
# if (!is.character(categ)) {
# warning("categ must be a character argument!")
# } else if (!any(znms == categ)) {
#print ('TRUE')
# warning(paste(categ, "is not an exact character name defined in the cgam fit!"))
# categ = NULL
# } else {
# obsz = 1:kznms
# zid = obsz[znms == categ]
# if (!(is_fac[zid])) {
# categ = NULL
# }
# }
#}
if (!is.null(categ)) {
if (!is.character(categ)) {
warning("categ must be a character argument!")
} else if (!any(znms == categ)) {
if (any(grepl(categ, znms))) {
id = which(grepl(categ, znms))
znmi = znms[id]
if (grepl("as.factor", znmi)) {
categ = paste("as.factor(", categ, ")", sep = "")
} else if (grepl("factor", znmi)) {
categ = paste("factor(", categ, ")", sep = "")
} else {print(paste(categ, "is not an exact character name defined in the cgam fit!"))}
} else {print(paste(categ, "is not an exact character name defined in the cgam fit!"))}
} else {
obsz = 1:kznms
zid = obsz[znms == categ]
#linear term:
if (!(is_fac[zid])) {
categ = NULL
}
}
}
#new: switch xnms
if (!is.null(data)) {
if (!is.data.frame(data)) {
stop ("User need to make the data argument a data frame with names for each variable!")
}
datnms = names(data)
if (!any(datnms == x1nm) | !any(datnms == x2nm)) {
stop ("Check the accuracy of the names of x1 and x2!")
}
x1 = data[ ,which(datnms == x1nm)]
x2 = data[ ,which(datnms == x2nm)]
} else {
if (all(xnms != x1nm)) {
#stop (paste(paste("'", x1nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
#new: in case of wrong data fame
if (length(x1) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x1!")
}
bool = apply(xmat, 2, function(x) all(x1 == x))
if (any(bool)) {
#x1id = obs[bool]
x1nm = xnms[bool]
} else {
stop (paste(paste("'", x1nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
if (all(xnms != x2nm)) {
#stop (paste(paste("'", x2nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
if (length(x2) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x2!")
}
bool = apply(xmat, 2, function(x) all(x2 == x))
if (any(bool)) {
#x2id = obs[bool]
x2nm = xnms[bool]
} else {
stop (paste(paste("'", x2nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
}
xnm12 = c(x1nm, x2nm)
#print (xnms)
#print(xnm12)
id_lab = which(xnms %in% xnm12)
#print (labels)
#print (xnm12)
xnm12_lab = labels[id_lab]
id1 = id2 = ipr = NULL
if (length(unique(xnm12_lab)) > 1 | length(id_lab) != 2) {
stop ("Two non-parametric predictors do not form a triangle-spline surface!")
} else {
id1 = sort(id_lab)[1]
id2 = sort(id_lab)[2]
ipr = id2 / 2
}
#decrs = decrs0[[ipr]]
#ktsi = kts[[ipr]]
#k1 = ktsi[[1]]
#k2 = ktsi[[2]]
knots_lst = object$knots_lst
trimat_lst = object$trimat_lst
bmat_lst = object$bmat_lst
thhat_all = object$coef_tri
capk_lst = object$capk_lst
knots = knots_lst[[ipr]]
trimat = trimat_lst[[ipr]]
bmat = bmat_lst[[ipr]]
capk = capk_lst[[ipr]]
cvs = cvss[[ipr]]
thhat = thhat_all[which(varlist == ipr)]
if (p > 0) {
thhat = c(thhat, zcoefs)
}
#additive
thvecs = object$etacomps
xnms_add = object$xnms_add
xmat_add = object$xmat_add
knms = length(xnms_add)
x3_add = 0
if (knms >= 1) {
#x3id <- obs[-c(x1id, x2id)]
#kx3 <- length(x3id)
for (i in 1:knms) {
x3i = xmat_add[, i]
x3i_use = max(x3i[x3i <= median(x3i)])
x3i_add = min(thvecs[i, x3i == x3i_use])
x3_add = x3_add + x3i_add
}
}
ntri = nrow(trimat)
if (x1nm != xnms[1] & x2nm != xnms[2]) {
nm = x1nm
x1nm = x2nm
x2nm = nm
tmp = x1
x1 = x2
x2 = tmp
} else {x1nm = x1nm; x2nm = x2nm}
if (is.null(th) | !is.numeric(th)) {
ang = NULL
if (cvs[1] & cvs[2]) {
if (is.null(ang)) {
ang = 140
}
} else if (!cvs[1] & !cvs[2]) {
if (is.null(ang)) {
ang = 25
}
}
} else {ang = th}
if (is.null(ltheta) | !is.numeric(ltheta)) {
ltheta <- -135
}
#make the surface
g = ngrid
ng = g^2
x1g = 0:(g-1)/(g-1) * (max(x1)-min(x1)) + min(x1)
x2g = 0:(g-1)/(g-1) * (max(x2)-min(x2)) + min(x2)
gg = matrix(0, nrow = ng, ncol = 2)
for (i in 1:g) {
gg[((i-1) * g + 1):(i * g),1] = x1g
gg[((i-1) * g + 1):(i * g),2] = 1:g * 0 + x2g[i]
}
gtri = 1:ng * 0
still = 1:ng>0
for (j in 1:ntri) {
for (i in 1:ng) {
if (still[i]) {
if (intri(gg[i,],knots[trimat[j,1],],knots[trimat[j,2],],knots[trimat[j,3],])) {
still[i] = FALSE
gtri[i] = j
}
}
}
}
gmat = matrix(0,nrow = ng,ncol = capk)
#print (gmat)
bmat = matrix(1,nrow = 3,ncol = 3)
a = 1:3
for (i in 1:ng) {
for (j in 1:3) {
#if (gtri[i] > 0) {
a[j] = trimat[gtri[i],j]
bmat[j,2] = knots[a[j],1]
bmat[j,3] = knots[a[j],2]
#}
}
binv = solve(bmat)
for (j in 1:3) {
gmat[i,a[j]] = binv[1,j] + binv[2,j] * gg[i,1] + binv[3,j] * gg[i,2]
}
}
#?
#if (p > 0) {
g0 = matrix(0,nrow = dim(gmat)[1],ncol = p)
#} else {g0 = NULL}
#print (g0)
#print (dim(gmat))
#print (dim(thhat))
gvals = cbind(gmat, g0) %*% thhat
#print (gvals)
mupl = matrix(gvals, nrow = g)
m1 = g
m2 = ncol(mupl)
if (fml != "gaussian") {
for (i1 in 1:m1) {
for (i2 in 1:m2) {
mupl[i1, i2] = muhat.fun(mupl[i1, i2], fml = fml)
}
}
#mupl = muhat.fun(mupl, fml = fml)
}
if (is.null(categ)) {
z_add = 0
if (!is.null(znms)) {
#if (p > 0) {
#print ('skip')
kzids = length(zid1)
for (i in 1:kzids) {
pos1 = zid1[i]; pos2 = zid2[i]
#zi is a factor
zi = zmat0[, pos1:pos2, drop = FALSE]
zcoefsi = zcoefs[pos1:pos2]
for (j in 1:ncol(zi)){
#find the 'mode' of the jth column of zi; add the coef corresponding to the 'mode'
uzij = unique(zi[,j])
kuzij = length(uzij)
nmodej = sum(zi[,j] == uzij[1])
zij_mode = uzij[1]
for (u in 2:kuzij) {
if (sum(zi[,j] == uzij[u]) > nmodej) {
zij_mode = uzij[u]
nmodej = sum(zi[,j] == uzij[u])
}
}
obsuzij = 1:length(uzij)
uzhatij = uzij * zcoefsi[j]
zij_add = uzhatij[obsuzij[uzij == zij_mode]]
z_add = z_add + zij_add
}
}
}
mupl = mupl + as.numeric(z_add) + as.numeric(x3_add)
#print (mupl)
m1 = nrow(mupl)
m2 = ncol(mupl)
if (fml != "gaussian") {
for (i1 in 1:m1) {
for (i2 in 1:m2) {
mupl[i1, i2] = muhat.fun(mupl[i1, i2], fml = fml)
}
}
#mupl = muhat.fun(mupl, fml = fml)
}
mins = min(mupl); maxs = max(mupl)
} else {
mupls = list()
mins = maxs = NULL
obsz = 1:kznms
zid = obsz[znms == categ]
pos1 = zid1[zid]; pos2 = zid2[zid]
zcoefsi = zcoefs[pos1:pos2]
#include the base level
zcoefsi = c(0, zcoefsi)
z_add = sort(zcoefsi)
kz_add = length(z_add)
for (iz in 1:kz_add) {
mupls[[iz]] = mupl + z_add[iz] + as.numeric(x3_add)
mins = c(mins, min(mupls[[iz]]))
maxs = c(maxs, max(mupls[[iz]]))
}
m1 = nrow(mupl)
m2 = ncol(mupl)
if (fml != "gaussian") {
for (iz in 1:kz_add) {
mupli = mupls[[iz]]
for (i1 in 1:m1) {
for (i2 in 1:m2) {
mupli[i1, i2] = muhat.fun(mupli[i1, i2], fml = fml)
}
}
#mupli = muhat.fun(mupli, fml = fml)
mupls[[iz]] = mupli
}
}
}
palette = c("peachpuff", "lightblue", "limegreen", "grey", "wheat", "yellowgreen", "seagreen1", "palegreen", "azure", "whitesmoke")
if (is.null(xlab)) {
xlab = x1nm
}
if (is.null(ylab)) {
ylab = x2nm
}
if (is.null(zlab)) {
if (fml == "binomial") {
zlab = paste("Pr(", ynm, ")")
} else if (fml == "poisson" | fml == "gaussian" | fml == "Gamma") {
zlab = paste("Est mean of", ynm)
}
}
if (is.null(categ)) {
if (is.null(col)) {
if (random) {
col = sample(palette, size = 1, replace = FALSE)
} else {
#col = "white"
musurf = mupl
nr = nrow(musurf)
nc = ncol(musurf)
ncol = 100
facet = musurf[-1,-1] + musurf[-1,-nc] + musurf[-nr,-1] + musurf[-nr,-nc]
#print (facet)
facetcol = cut(facet, ncol)
col = heat.colors(ncol)[facetcol]
}
} else {
if (col == "heat" | col == "topo" | col == "terrain" | col == "cm") {
nr = nrow(mupl)
nc = ncol(mupl)
ncol = 100
facet = mupl[-1,-1] + mupl[-1,-nc] + mupl[-nr,-1] + mupl[-nr,-nc]
facetcol = cut(facet, ncol)
if (col == "heat") {
col = heat.colors(ncol)[facetcol]
} else if (col == "topo") {
col = topo.colors(ncol)[facetcol]
} else if (col == "terrain") {
col = terrain.colors(ncol)[facetcol]
} else {
col = cm.colors(ncol)[facetcol]
}
}
if (random) {
print ("User defined color is used!")
}
}
#if (surface == 'C') {
musurf = mupl
#if (is.null(main)) {
# main = 'Constrained Warped-Plane Spline Surface'
#}
if (is.null(zlim)) {
lwr = min(mins)
upp = max(maxs)
zlim0 = c(lwr - (upp-lwr)/5, upp + (upp-lwr)/5)
} else {
zlim0 = zlim
}
#}
#persp(k1, k2, musurf, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype,...)
persp(x1g, x2g, musurf, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype,...)
res = list(musurf = mupl, gg = gg, x1g=x1g, x2g=x2g, z_add = z_add, x3_add = x3_add, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype)
invisible(res)
} else {
kxgm = length(mupls)
if (is.null(col)) {
if (random) {
#new:
col = topo.colors(kxgm)
} else {
if (kxgm > 1 & kxgm < 11) {
col = palette[1:kxgm]
} else {
#new:
col = topo.colors(kxgm)
}
}
} else {
col0 = col
if (col0 == "heat" | col0 == "topo" | col0 == "terrain" | col0 == "cm") {
#col0 <- col
ncol = 100
facets = facetcols = list()
col = list()
for (i in 1:kxgm) {
nr = nrow(mupls[[i]])
nc = ncol(mupls[[i]])
facets[[i]] = (mupls[[i]])[-1,-1] + (mupls[[i]])[-1,-nc] + (mupls[[i]])[-nr,-1] + (mupls[[i]])[-nr,-nc]
facetcols[[i]] = cut(facets[[i]], ncol)
#print (head(facetcols[[i]]))
if (col0 == "heat") {
col[[i]] = (heat.colors(ncol))[facetcols[[i]]]
#print (head(col[[i]]))
} else if (col0 == "topo") {
col[[i]] = (topo.colors(ncol))[facetcols[[i]]]
} else if (col0 == "terrain") {
col[[i]] = (terrain.colors(ncol))[facetcols[[i]]]
} else {
col[[i]] = (cm.colors(ncol))[facetcols[[i]]]
}
}
} else if (length(col0) < kxgm) {
#new:
col = topo.colors(kxgm)
} else if (length(col0) > kxgm) {
col = col0[1:kxgm]
}
}
for (i in 1:kxgm) {
mupli = mupls[[i]]
#if (surface == 'C') {
musurf = mupli
#if (is.null(main)) {
# main = 'Constrained Warped-Plane Spline Surface'
#}
if (is.null(zlim)) {
lwr = min(mins)
upp = max(maxs)
zlim0 = c(lwr - (upp-lwr)/5, upp + (upp-lwr)/5)
} else {
zlim0 = zlim
}
#}
if (is.list(col)) {
coli = unlist(col[[i]])
#print (head(coli))
} else {coli = col[i]}
#persp(k1, k2, musurf, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = col[i], cex.axis = .75, main = main, ticktype = ticktype,...)
persp(x1g, x2g, musurf, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = coli, cex.axis = .75, main = main, ticktype = ticktype,...)
par(new = TRUE)
}
par(new = FALSE)
}
}
##########################################
#apply plotpersp on a trispl.predict object
#not done: >= 1 tri pair + additive + z, ignore wps
#one pair + z only
##########################################
plotpersp.trisplp = function(object, x1=NULL, x2=NULL, x1nm=NULL, x2nm=NULL, data=NULL, up = TRUE, main=NULL, cex.main=.8, xlab = NULL, ylab = NULL, zlab = NULL, th = NULL, ltheta = NULL, ticktype = "simple",...) {
#obj is prediction for trispl
if (!inherits(object, "trisplp")) {
warning("calling plotpersp(<fake-trisplp-object>) ...")
}
t_col = function(color, percent = 50, name = NULL) {
rgb.val <- col2rgb(color)
## Make new color using input color as base and alpha set by transparency
t.col <- rgb(rgb.val[1], rgb.val[2], rgb.val[3],
maxColorValue = 255,
alpha = (100-percent)*255/100,
names = name)
## Save the color
invisible(t.col)
}
if (up) {
mycol = t_col("green", perc = 90, name = "lt.green")
} else {
mycol = t_col("pink", perc = 80, name = "lt.pink")
}
acov = object$acov
mult = object$mult
#obj is the wps fit
obj = object$object
xnms = obj$xnms_tri
xmat = obj$xmat_tri
xnms_add = obj$xnms_add
xmat_add = obj$xmat_add
delta = obj$dmatc
#if (x1nm == "NULL" | x2nm == "NULL") {
if (is.null(x1nm) | is.null(x2nm)) {
if (length(xnms) >= 2) {
x1nm = xnms[1]
x2nm = xnms[2]
x1id = 1
x2id = 2
x1 = xmat[, 1]
x2 = xmat[, 2]
} else {stop ("Number of non-parametric predictors must >= 2!")}
}
labels = obj$labels
labels = labels[which(grepl("tri", labels, fixed = TRUE))]
is_fac = obj$is_fac
ynm = obj$ynm
varlist = obj$varlist_tri
kts = obj$knots_lst
np = obj$d0
#switch xnms
if (!is.null(data)) {
if (!is.data.frame(data)) {
stop ("User need to make the data argument a data frame with names for each variable!")
}
datnms = names(data)
if (!any(datnms == x1nm) | !any(datnms == x2nm)) {
stop ("Check the accuracy of the names of x1 and x2!")
}
x1 = data[ ,which(datnms == x1nm)]
x2 = data[ ,which(datnms == x2nm)]
} else {
if (all(xnms != x1nm)) {
#stop (paste(paste("'", x1nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
#new: in case of wrong data fame
if (length(x1) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x1!")
}
bool = apply(xmat, 2, function(x) all(x1 == x))
if (any(bool)) {
#x1id = obs[bool]
x1nm = xnms[bool]
} else {
stop (paste(paste("'", x1nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
if (all(xnms != x2nm)) {
#stop (paste(paste("'", x2nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
if (length(x2) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x2!")
}
bool = apply(xmat, 2, function(x) all(x2 == x))
if (any(bool)) {
#x2id = obs[bool]
x2nm = xnms[bool]
} else {
stop (paste(paste("'", x2nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
}
xnm12 = c(x1nm, x2nm)
id_lab = which(xnms %in% xnm12)
xnm12_lab = labels[id_lab]
#new:
xnm_other = xnms[-id_lab]
id1 = id2 = ipr = NULL
if (length(unique(xnm12_lab)) > 1 | length(id_lab) != 2) {
stop ("Two non-parametric predictors do not form a triangle-spline surface!")
} else {
id1 = sort(id_lab)[1]
id2 = sort(id_lab)[2]
ipr = id2 / 2
}
#find the pairs to be plotted
if (x1nm != xnms[1] & x2nm != xnms[2]) {
nm = x1nm
x1nm = x2nm
x2nm = nm
tmp = x1
x1 = x2
x2 = tmp
#new:
xnm12 = c(x1nm, x2nm)
} else {x1nm = x1nm; x2nm = x2nm}
newz = object$newz
npr = round(length(xnms) / 2, 0L)
#zlwr = min(object$lower) - (max(object$fit) - min(object$fit)) / 4
#zupp = max(object$upper) + (max(object$fit) - min(object$fit)) / 4
res = plotpersp.trispl(obj, x1, x2, ngrid = 7, col='white', xlab=xlab, ylab=ylab, zlab=zlab, th=th, ltheta=ltheta, ticktype=ticktype)
newData = as.data.frame(res$gg)
#if (!is.null(newz)) {
# znms = obj$znms
# nz = matrix(0, nrow=nrow(gg), ncol=ncol(newz))
# nznm = gsub("[\\(\\)]", "", regmatches(znms, gregexpr("\\(.*?\\)", znms))[[1]])
# gg = cbind(gg, nz)
# colnames(gg) = c(x1nm, x2nm, nznm)
#} else {
# colnames(gg) = c(x1nm, x2nm)
#}
if (npr > 1) {
new_other = matrix(0, nrow=nrow(newData), ncol=(2*(npr-1)))
kts_other = kts[,-c(ipr*2-1,ipr*2)]
for (i in 1:(npr-1)) {
for (j in 1:2) {
newi = mean(kts_other[,(i-1)*2+j])
new_other[,(i-1)*2+j] = newi
}
}
newd = cbind(newData, new_other)
colnames(newd) = c(xnm12, xnm_other)
newData = as.data.frame(newd)
}
if (length(xnms_add) > 0) {
#new_add = matrix(0, nrow=nrow(newData), ncol=ncol(xmat_add))
means = apply(xmat_add, 2, mean)
new_add = matrix(rep(means, nrow(newData)), ncol=ncol(xmat_add), byrow=T)
nms = colnames(newData)
newd = cbind(newData, new_add)
colnames(newd) = c(nms, xnms_add)
newData = as.data.frame(newd)
}
if (!is.null(newz)) {
znms = obj$znms
nz = matrix(0, nrow=nrow(newData), ncol=ncol(newz))
nznm = gsub("[\\(\\)]", "", regmatches(znms, gregexpr("\\(.*?\\)", znms))[[1]])
nms = colnames(newData)
newData = cbind(newData, nz)
colnames(newData) = c(nms, nznm)
}
gg = newData
pfit.gg = predict.trispl(obj, gg, interval='none')
#upper = pfit.gg$upper
#lower = pfit.gg$lower
xmatpr = pfit.gg$xmatpr
muhat = pfit.gg$fit
lower = muhat - mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
upper = muhat + mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
#spls = pfit.bb$spls
#ignore z
#spl_use = cbind(1, spls[[ipr]])
#get the fit for each pair
#mus = pfit.knots$mus
#muhat_use = mus[[ipr]]
#get the acov for each pair
#acov_use = acov[c(1, which(varlist == ipr)+np), c(1, which(varlist == ipr)+np)]
#lower = muhat_use - mult*sqrt(diag(spl_use%*%acov_use%*%t(spl_use)))
#upper = muhat_use + mult*sqrt(diag(spl_use%*%acov_use%*%t(spl_use)))
x1g = res$x1g
x2g = res$x2g
k1 = length(x1g)
k2 = length(x2g)
surf = matrix(0, k1, k2)
for(i2 in 1:k2) {
for(i1 in 1:k1) {
if (up) {
surf[i1,i2] = upper[(i2-1)*k1 + i1]
} else {
surf[i1,i2] = lower[(i2-1)*k1 + i1]
}
}
}
#gaussian only
z_add = res$z_add
x3_add = res$x3_add
surf = surf + z_add + x3_add
if (up) {
if (is.null(main)) {
main = "Triangle-Spline Surface with Upper 95% Confidence Surface"
}
}
if (!up) {
if (is.null(main)) {
main = "Triangle-Spline Surface with Lower 95% Confidence Surface"
}
}
par(new = TRUE)
persp(x1g, x2g, surf, zlim = res$zlim, xlab = "", ylab = "", zlab = "", theta = res$theta,
ltheta = res$ltheta, cex.axis = res$cex.axis, main = main, cex.main = cex.main,
ticktype = res$ticktype, col=mycol, box=FALSE, axes=FALSE,...)
par(new=FALSE)
}
#####################################################################################
#### SUBROUTINES
#####################################################################################
### subroutine to determine if point p is inside the triangle formed by a,b,c
intri = function(p, a, b, c) {
if (sameside(p, a, b, c) & sameside(p, b, a, c) & sameside(p, c, a, b)) {
ins = TRUE
} else {ins = FALSE}
ins
}
### subroutine to determine if p1 and p2 are on the same side of the line formed by a,b
sameside = function(p1, p2, a, b) {
cp1 = cpfun(b-a, p1-a)
cp2 = cpfun(b-a, p2-a)
if (cp1 * cp2 >= 0) {ss = TRUE} else {ss = FALSE}
ss
}
## subroutine to find 3rd value of cross product of a and b, where a=(a1,a2,0) and b=(b1,b2,0)
cpfun = function(a, b) {
c = a[1] * b[2] - a[2] * b[1]
c
}
###########
#prop odds#
###########
cgam.polr <- function(formula, data = NULL, weights = NULL, family = NULL, nsim = 0, cpar = 1.2)
{
cl <- match.call()
mf <- match.call(expand.dots = FALSE)
m <- match(c("formula", "data"), names(mf), 0L)
mf <- mf[c(1L, m)]
#print (mf)
mf[[1L]] <- as.name("model.frame")
#print (class(eval.parent(mf$data)))
#if(is.matrix(eval.parent(mf$data))) {
# mf$data <- as.data.frame(data)
#} else {mf$data <- data}
mf <- eval(mf, parent.frame())
ynm <- names(mf)[1]
mt <- attr(mf, "terms")
y <- model.response(mf, "any")
shapes1 <- NULL; shapes2 <- NULL
xmat <- NULL; xnms <- NULL
nums <- NULL; ks <- list(); sps <- NULL; xid <- 1
zmat <- NULL; zid <- NULL; zid0 <- NULL; zid1 <- NULL; zid2 <- NULL; znms <- NULL; is_param <- NULL; is_fac <- NULL; vals <- NULL; st <- 1; ed <- 1
ztb <- list(); iztb <- 1
pl <- NULL
tree.delta <- NULL
tid1 <- NULL; tid2 <- NULL; tpos2 <- 0
tr <- NULL
umbrella.delta <- NULL
uid1 <- NULL; uid2 <- NULL; upos2 <- 0
umb <- NULL
for (i in 2:ncol(mf)) {
if (is.numeric(attributes(mf[,i])$shape)) {
shapes1 <- c(shapes1, attributes(mf[,i])$shape)
xmat <- cbind(xmat, mf[,i])
xnms <- c(xnms, attributes(mf[,i])$nm)
nums <- c(nums, attributes(mf[,i])$numknots)
sps <- c(sps, attributes(mf[,i])$space)
ks[[xid]] <- attributes(mf[,i])$knots
xid <- xid + 1
}
if (is.character(attributes(mf[,i])$shape)) {
shapes2 <- c(shapes2, attributes(mf[,i])$shape)
if (attributes(mf[,i])$shape == "tree") {
pl <- c(pl, attributes(mf[,i])$pl)
treei <- tree.fun(mf[,i], attributes(mf[,i])$pl)
tree.delta <- rbind(tree.delta, treei)
tpos1 <- tpos2 + 1
tpos2 <- tpos2 + nrow(treei)
tid1 <- c(tid1, tpos1)
tid2 <- c(tid2, tpos2)
tr <- cbind(tr, mf[,i])
}
if (attributes(mf[,i])$shape == "umbrella") {
umbi <- umbrella.fun(mf[,i])
umbrella.delta <- rbind(umbrella.delta, umbi)
upos1 <- upos2 + 1
upos2 <- upos2 + nrow(umbi)
uid1 <- c(uid1, upos1)
uid2 <- c(uid2, upos2)
umb <- cbind(umb, mf[,i])
}
}
if (is.null(attributes(mf[, i])$shape)) {
if (!is.null(names(mf)[i])) {
znms <- c(znms, names(mf)[i])
}
if (!is.matrix(mf[, i])) {
zid <- c(zid, i)
is_param <- c(is_param, TRUE)
if (is.factor(mf[, i])) {
is_fac <- c(is_fac, TRUE)
ch_char <- suppressWarnings(is.na(as.numeric(levels(mf[, i]))))
if (any(ch_char)) {
vals <- c(vals, unique(levels(mf[, i]))[-1])
} else {
vals <- c(vals, as.numeric(levels(mf[, i]))[-1])
}
nlvs <- length(attributes(mf[, i])$levels)
ed <- st + nlvs - 2
zid1 <- c(zid1, st)
zid2 <- c(zid2, ed)
st <- st + nlvs - 1
zmat0 <- model.matrix(~ mf[, i])[, -1, drop = FALSE]
zmat <- cbind(zmat, zmat0)
} else {
is_fac <- c(is_fac, FALSE)
zmat <- cbind(zmat, mf[, i])
ed <- st
zid1 <- c(zid1, st)
zid2 <- c(zid2, ed)
st <- st + 1
vals <- c(vals, "")
}
} else {
is_param <- c(is_param, FALSE)
is_fac <- c(is_fac, FALSE)
zmat0 <- mf[, i]
zmat <- cbind(zmat, zmat0)
zid <- c(zid, i)
nlvs <- ncol(zmat0) + 1
ed <- st + nlvs - 2
zid1 <- c(zid1, st)
zid2 <- c(zid2, ed)
st <- st + nlvs - 1
}
}
}
dimnames(zmat)[[2]] <- NULL
xmat0 <- xmat; shapes0 <- shapes1; nums0 <- nums; ks0 <- ks; sps0 <- sps; xnms0 <- xnms; idx_s <- NULL; idx <- NULL
if (any(shapes1 == 17)) {
kshapes <- length(shapes1)
obs <- 1:kshapes
idx_s <- obs[which(shapes1 == 17)]; idx <- obs[which(shapes1 != 17)]
xmat0[ ,1:length(idx_s)] <- xmat[ ,idx_s]
shapes0[1:length(idx_s)] <- shapes1[idx_s]
nums0[1:length(idx_s)] <- nums[idx_s]
sps0[1:length(idx_s)] <- sps[idx_s]
ks0[1:length(idx_s)] <- ks[idx_s]
xnms0[1:length(idx_s)] <- xnms[idx_s]
if (length(idx) > 0) {
xmat0[ ,(1 + length(idx_s)):kshapes] <- xmat[ ,idx]
shapes0[(1 + length(idx_s)):kshapes] <- shapes1[idx]
nums0[(1 + length(idx_s)):kshapes] <- nums[idx]
sps0[(1 + length(idx_s)):kshapes] <- sps[idx]
ks0[(1 + length(idx_s)):kshapes] <- ks[idx]
xnms0[(1 +length(idx_s)):kshapes] <- xnms[idx]
}
#xmat <- xmat0; nums <- nums0; ks <- ks0; sps <- sps0; xnms <- xnms0
}
ans <- cgam.polr.fit(y, xmat0, zmat, umbrella.delta = umbrella.delta, tree.delta = tree.delta, shapes = shapes1, nums0, ks0, sps0, family, idx_s, idx, nsim, cpar, weights)
rslt <- list(muhat = ans$muhat, zeta = ans$ac, wta = ans$wta, lev = ans$lev, vcoefs = ans$vcoefs, xcoefs = ans$xcoefs, zcoefs = ans$zcoefs, coefs = ans$coefs, ucoefs = ans$ucoefs, tcoefs = ans$tcoefs, cic = ans$cic, d0 = ans$d0, edf0 = NULL, etacomps = ans$etacomps, xmat = xmat, zmat = zmat, ztb = ztb, tr = tr, umb = umb, tree.delta = tree.delta, umbrella.delta = umbrella.delta, bigmat = ans$bigmat, shapes = shapes1, shapesx = shapes1, wt = ans$wt, wt.iter = TRUE, family = family, SSE0 = NULL, SSE1 = NULL, pvals.beta = NULL, se.beta = NULL, df.null = ans$df.null, df = ans$df, df.residual = ans$df.residual, null.deviance = ans$dev.null, deviance = ans$dev, tms = mt, capm = ans$capm, capms = ans$capms, capk = ans$capk, capt = ans$capt, capu = ans$capu, xid1 = ans$xid1, xid2 = ans$xid2, tid1 = tid1, tid2 = tid2, uid1 = uid1, uid2 = uid2, zid = zid, vals = vals, zid1 = zid1, zid2 = zid2, nsim = nsim, xnms = xnms, ynm = ynm, znms = znms, is_param = is_param, is_fac = is_fac, knots = ans$knots, numknots = ans$numknots, sps = sps, ms = NULL, cpar = cpar, pl = pl, idx_s = idx_s, idx = idx, xmat0 = ans$xmat2, knots0 = ans$knots2, numknots0 = ans$numknots2, sps0 = ans$sps2, ms0 = ans$ms2)
rslt$call <- cl
class(rslt) <- "cgam.polr"
return (rslt)
}
#
cgam.polr.fit = function(y = NULL, xmat = NULL, zmat = NULL, umbrella.delta = NULL, tree.delta = NULL, shapes = NULL, numknots = NULL, knots = NULL, space = NULL, family = NULL, idx_s = NULL, idx = NULL, nsim = 0, cpar = 1.2, weights = NULL) {
fmin = function(a) {
nc = length(a) + 1
y_id = t(col(matrix(0, length(y), nc)) == y)
llh = 0
for (i in 1:nc) {
if (i == 1) {
llhi = sum(w * y_id[i,] * log(pfun(a[1] - eta)))
} else if (i == nc) {
llhi = sum(w * y_id[i,] * log(1 - pfun(a[nc-1] - eta)))
} else {
llhi = sum(w * y_id[i,] * log(pfun(a[i] - eta) - pfun(a[i-1] - eta)))
}
llh = llh + llhi
}
-2*llh
}
gmin = function(a) {
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == y)
gr = NULL
for (i in 1:(nc-1)) {
if (i == 1) {
gri = -sum(y_id[1,] * w * (1 - pfun(a[1] - eta))) + sum(y_id[2,] * w * dfun(a[1] - eta) / (pfun(a[2] - eta) - pfun(a[1] - eta)))
} else if (i == (nc-1)) {
gri = -sum(y_id[nc-1,] * w * dfun(a[nc-1] - eta) / (pfun(a[nc-1] - eta) - pfun(a[nc-2] - eta))) + sum(I(y == nc) * w * dfun(a[nc-1] - eta) / (1 - pfun(a[nc-1] - eta)))
#gri = -sum(y_id[nc-1,id] * w[id] * dfun(a[nc-1] - eta[id]) / (pfun(a[nc-1] - eta[id]) - pfun(a[nc-2] - eta[id]))) + sum(y_id[nc,id] * w[id] * dfun(a[nc-1] - eta[id]) / (1 - pfun(a[nc-1] - eta[id])))
} else {
gri = -sum(y_id[i,] * w * dfun(a[i] - eta) / (pfun(a[i] - eta) - pfun(a[i-1] - eta))) + sum(y_id[i+1,] * w * dfun(a[i] - eta) / (pfun(a[i+1] - eta) - pfun(a[i] - eta)))
}
gr = c(gr, gri)
}
return (gr)
}
if (is.factor(y)) {
lev = levels(y)
y = unclass(y)
} else {
lev = attributes(factor(y))$levels
}
n = length(y)
w = weights
if(is.null(w)) {
w = rep(1, n)
}
sc_x = FALSE
capl = length(xmat) / n
#print (dim(xmat))
if (capl < 1) {capl = 0}
if (round(capl, 8) != round(capl, 1)) {stop ("Incompatible dimensions for xmat!")}
if (capl > 0 & sc_x) {
for (i in 1:capl) {xmat[,i] = (xmat[,i] - min(xmat[,i])) / (max(xmat[,i]) - min(xmat[,i]))}
}
capk = length(zmat) / n
#print (capk)
if (capk < 1) {capk = 0}
if (round(capk, 8) != round(capk, 1)) {stop ("Incompatible dimensions for zmat!")}
#smooth only
#if (!is.null(shapes)) {
capls = sum(shapes == 17)
#} else {capls = 0}
bigmat = NULL; delta = NULL
varlist = NULL
xid1 = NULL; xid2 = NULL; xpos2 = 0
knotsuse = list(); numknotsuse = NULL
mslst = list()
capm = 0
capms = 0
if (capl - capls > 0) {
#print (class(xmat[,1]))
#print (head(xmat))
del1_ans = makedelta(xmat[, 1], shapes[1], numknots[1], knots[[1]], space = space[1], interp=T)
#del1_ans = makedelta(xmat[, 1], shapes[1])
del1 = del1_ans$amat
knotsuse[[1]] = del1_ans$knots
mslst[[1]] = del1_ans$ms
numknotsuse = c(numknotsuse, length(del1_ans$knots))
m1 = length(del1) / n
#new code: record the number of columns of del1 if shapes0[1] == 17:
if (shapes[1] == 17) {capms = capms + m1}
var1 = 1:m1*0 + 1
xpos1 = xpos2 + 1
xpos2 = xpos2 + m1
xid1 = c(xid1, xpos1)
xid2 = c(xid2, xpos2)
if (capl == 1) {
delta = del1
varlist = var1
} else {
for (i in 2:capl) {
#new code:
del2_ans = makedelta(xmat[,i], shapes[i], numknots[i], knots[[i]], space = space[i], interp=T)
#del2_ans = makedelta(xmat[,i], shapes[i])
del2 = del2_ans$amat
knotsuse[[i]] = del2_ans$knots
mslst[[i]] = del2_ans$ms
numknotsuse = c(numknotsuse, length(del2_ans$knots))
m2 = length(del2) / n
#new code: record the number of columns of del2 if shapes0[i] == 17:
if (shapes[i] == 17) {capms = capms + m2}
xpos1 = xpos2 + 1
xpos2 = xpos2 + m2
xid1 = c(xid1, xpos1)
xid2 = c(xid2, xpos2)
delta = rbind(del1, del2)
varlist = 1:(m1 + m2)*0
varlist[1:m1] = var1
varlist[(m1 + 1):(m1 + m2)] = (1:m2)*0 + i
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
np = 0
if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0 & capk > 0) {
bigmat = rbind(t(zmat), t(xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13]), delta)
np = capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0 & capk == 0) {
bigmat = rbind(t(xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13]), delta)
np = sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0 & capk > 0) {
bigmat = rbind(t(zmat), delta)
np = capk + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0 & capk == 0) {
bigmat = delta
np = capms
} else {
print ("error in capk, shapes!")
}
#new:
capm = length(delta) / n - capms
} else {
if (capk + capls > 0) {
#new:
if (capls < 1 & capk > 0) {
#bigmat = rbind(1:n*0 + 1, t(zmat))
bigmat = t(zmat)
#np = 1 + capk
np = capk
} else if (capls > 0) {
delta = NULL; varlist = NULL
del1_ans = makedelta(xmat[,1], 17, numknots[1], knots[[1]], space = space[1], interp=T)
#del1_ans = makedelta(xmat[,i], 9)
del1 = del1_ans$amat
knotsuse[[1]] = del1_ans$knots
mslst[[1]] = del1_ans$ms
numknotsuse = c(numknotsuse, length(del1_ans$knots))
m1 = length(del1) / n
var1 = 1:m1*0 + 1
xpos1 = xpos2 + 1
xpos2 = xpos2 + m1
xid1 = c(xid1, xpos1)
xid2 = c(xid2, xpos2)
if (capls == 1) {
delta = del1
varlist = var1
} else {
for (i in 2:capls) {
del2_ans = makedelta(xmat[,i], 17, numknots[i], knots[[i]], space = space[i], interp=T)
#del2_ans = makedelta(xmat[,i], 9)
del2 = del2_ans$amat
knotsuse[[i]] = del2_ans$knots
mslst[[i]] = del2_ans$ms
numknotsuse = c(numknotsuse, length(del2_ans$knots))
m2 = length(del2) / n
xpos1 = xpos2 + 1
xpos2 = xpos2 + m2
xid1 = c(xid1, xpos1)
xid2 = c(xid2, xpos2)
delta = rbind(del1, del2)
varlist = 1:(m1 + m2)*0
varlist[1:m1] = var1
varlist[(m1 + 1):(m1 + m2)] = (1:m2)*0 + i
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
if (capk < 1){
#bigmat = rbind(1:n*0 + 1, delta)
bigmat = delta
capms = length(delta) / n
#np = 1 + capms
np = capms
} else {
#bigmat = rbind(1:n*0 + 1, t(zmat), delta)
bigmat = rbind(t(zmat), delta)
capms = length(delta) / n
#np = 1 + capk + capms
np = capk + capms
}
}
} else {bigmat = NULL; capm = 0; capms = 0; np = 0}
}
#print (head(zmat))
#print (head(t(bigmat)))
#new:
if (!is.null(umbrella.delta)) {
bigmat <- rbind(bigmat, umbrella.delta)
capu <- length(umbrella.delta) / n
} else {capu <- 0}
if (!is.null(tree.delta)) {
bigmat <- rbind(bigmat, tree.delta)
capt <- length(tree.delta) / n
} else {capt <- 0}
if (!is.null(umbrella.delta) | !is.null(tree.delta))
delta_ut <- rbind(umbrella.delta, tree.delta)
#coneB:
#n = length(y)
nc = length(unique(y)) - 1
#lev = attributes(factor(y))$levels
#initialize a
if (all(w == 1)) {
a = sapply(1:nc, function(ct) log(sum(y <= ct) / (n - sum(y <= ct))))
} else {
#a = sapply(1:nc, function(ct) log(w * sum(y <= ct) / (n - sum(y <= ct))))
a = 1:nc*0
for (i in 1:nc) {
#idi = which(y <= i)
a[i] = log(sum((y <= i)* w) / (sum(w) - sum((y <= i)* w)))
}
}
gr = 1:n*0
wt = 1:n*0
eta = 1:n*0
diff = 100
nrep = 0
olddev = 100
oldmu = 1:n*0+1
face = NULL
while(diff > 1e-8 & nrep < 400){
nrep = nrep+1
#eta step:
gr = fgr(a, y, eta, w)
wt = fwt(a, y, eta, w)
q0 = diag(as.vector(wt))
cvec = wt * eta - gr
zvec = 1:n*0
zvec[wt == 0] = 1 / 1e-4
zvec[wt > 0] = cvec[wt > 0] / sqrt(wt[wt > 0])
gmat = t(bigmat)
for (j in 1:n) {gmat[j,] = bigmat[,j] * sqrt(wt[j])}
if (np > 0) {
zsend = gmat[, 1:np]
if ((capm + capt + capu) > 0) {
dsend = t(gmat[, (np+1):(nrow(bigmat))])
} else {dsend = NULL}
} else {
dsend = t(gmat)
zsend = NULL
}
if ((capm + capt + capu) > 0) {
#ans = coneB(zvec, dsend, vmat = zsend)
if (nrep > 1) {
ans = coneB(zvec, t(dsend), vmat = zsend, face = face)
} else {
ans = coneB(zvec, t(dsend), vmat = zsend)
face = ans$face
}
#ans = coneB(zvec, t(dsend))
bh = coef(ans)
} else {
bh = solve(t(zsend) %*% zsend, t(zsend) %*% zvec)
}
eta = t(bigmat) %*% bh
#a step:
#res = optim(a, fmin, gr = gmin, hessian = TRUE)
#a = res$par
gr_a = fgr_a(a, y, eta, w)
wt_a = fwt_a(a, y, eta, w)
qmat_a = wt_a
a = a - solve(qmat_a, gr_a)
#a = atil + bh[1]
#if (a[1] >= a[2]) {
if (any(a != sort(a))) {
print ('a wrong!')
break
}
#dev = res$value
#diff = (dev-olddev)^2
#olddev = dev
mu = predict_polr(a, eta)$mu
diff = mean((mu-oldmu)^2)
oldmu = mu
}
names(a) = paste(lev[-length(lev)], lev[-1L], sep="|")
#print (diff)
yhat = eta
coefskeep = bh
#df_obs = sum(abs(coefskeep) > 0) + length(a)
#print (coefskeep)
########################
#if capk > 0, we have:#
########################
zcoefs = NULL
if (capk > 0) {
zcoefs = coefskeep[1:capk]
}
#print (zcoefs)
vcoefs = NULL
if (np > 0) {
vcoefs = coefskeep[1:np]
}
#######################
#if capm > 0, we have:#
#######################
xcoefs = NULL
#new:
if (capl > 0) {
xcoefs = coefskeep[(np - capms + 1):(np + capm)]
}
#######################
#if capu > 0, we have:#
#######################
ucoefs = NULL
if (capu > 0) {
ucoefs = coefskeep[(np + 1 + capm):(np + capm + capu)]
}
#######################
#if capt > 0, we have:#
#######################
tcoefs = NULL
if (capt > 0) {
tcoefs =
coefskeep[(np + 1 + capm + capu):(np + capm + capu + capt)]
}
#########################################################
#if we have at least one constrained predictor, we have:#
#########################################################
thvecs = NULL
if (capl > 0) {
#new code:
dcoefs = coefskeep[(np - capms + 1):(np + capm)]
#####################################################
#thvecs is f(x), where x has one of the eight shapes#
#####################################################
thvecs = matrix(0, nrow = capl, ncol = n)
ncon = 1
for (i in 1:capl) {
thvecs[i,] = t(delta[varlist == i,]) %*% dcoefs[varlist == i]
if (shapes[i] > 2 & shapes[i] < 5 | shapes[i] > 10 & shapes[i] < 13) {
ncon = ncon + 1
thvecs[i,] = thvecs[i,] + vcoefs[capk + ncon] * xmat[,i]
}
}
}
#new:order thvecs back
#if (!is.null(idx_s)) {
if (length(idx_s) > 0) {
thvecs0 = thvecs
thvecs0[idx_s,] = thvecs[1:length(idx_s), ]
#if (!is.null(idx)) {
if (length(idx) > 0) {
thvecs0[idx,] = thvecs[(1+length(idx_s)):capl, ]
}
thvecs = thvecs0
}
thvecs_ut = NULL
if (capu + capt > 0) {
thvecs_ut = t(delta_ut) %*% coefskeep[(np + 1 + capm):(np + capm + capu + capt)]
}
if (!is.null(thvecs_ut)) {
thvecs = rbind(thvecs, t(thvecs_ut))
}
etakeep = eta
muhatkeep = eta
df_obs = sum(abs(coefskeep) > 0) + length(a)
#deviance
dev = dev_fun(y, a = a, eta = eta, flat = FALSE, w = w)
#print (dev)
llh = dev/n
#null deviance
dev.null = dev_fun(y, a = a, eta = eta, flat = TRUE, w = w)
#print (dev.null)
cic = NULL
dfmean = 0
if (nsim > 0) {
if (capm + capms > 0) {
dfs = 1:nsim*0
for (isim in 1:nsim) {
#print (isim)
ysti = rlogis(n, scale = 1)
#print (nc)
cts = quantile(ysti, probs = seq(0, 1, length = (nc+2)))
#print (cts)
yordi = cut(ysti, breaks=cts, include.lowest = TRUE, labels = c(1:(nc+1)), ordered = TRUE)
ysim = as.numeric(levels(yordi))[yordi]
edfi = polr_getedf(ysim, bigmat, np, capm, shapes, w)
#dfs[isim] = sum(abs(bhi) > 0)
dfs[isim] = edfi
}
if (any(shapes == 11) | any(shapes == 12)) {
dfmean = mean(dfs) - sum(shapes > 10 & shapes < 13)
} else {dfmean = mean(dfs)}
} else {dfmean = 0}
#cic = llh + log(1 + 2 * (dfmean + np) / (n - np - cpar * dfmean))
#check! length(a)?
if ((n - np - 1.5 * (dfmean - np)) <= 0) {
cic = llh + log(1 + 2 * dfmean / (dfmean - np))
} else {
cic = llh + log(1 + 2 * dfmean / (n - np - 1.5 * (dfmean - np)))
}
}
#print (cic)
env = new.env()
#tm=proc.time()-tm0
#env$tm=tm
env$dev=dev
env$dev.null=dev.null
#print (lev)
env$lev=lev
env$etacomps=thvecs
env$zcoefs=zcoefs
env$ac=a
env$etahat=eta
env$muhat=eta
env$vcoefs=vcoefs
env$xcoefs=xcoefs
env$zcoefs=zcoefs
env$ucoefs=ucoefs
env$tcoefs=tcoefs
env$coefs=coefskeep
env$cic=cic
env$d0=np
env$capm = capm
env$capms = capms
env$capk = capk
env$capu = capu
env$capt = capt
env$edf=df_obs
env$edf0=dfmean
env$bigmat=bigmat
#env$family=family
env$sse0=NULL
env$sse1=NULL
env$pvals.beta=NULL
env$se.beta=NULL
env$wt=wt
env$gr=gr
env$mu=mu
env$oldmu=oldmu
env$diff=diff
env$bh=bh
env$thvecs=thvecs
#gr_a=NULL
env$gra=gr_a
env$wta=wt_a
knotsuse2=knotsuse
numknotsuse2=numknotsuse
mslst2=mslst
xmat2=xmat
#if (!is.null(idx_s)) {
if (length(idx_s) > 0) {
knotsuse0 = knotsuse
numknotsuse0 = numknotsuse
mslst0 = mslst
knotsuse0[idx_s] = knotsuse[1:length(idx_s)]
numknotsuse0[idx_s] = numknotsuse[1:length(idx_s)]
mslst0[idx_s] = mslst[1:length(idx_s)]
#if (!is.null(idx)) {
if (length(idx) > 0) {
knotsuse0[idx] = knotsuse[(1+length(idx_s)):capl]
numknotsuse0[idx] = numknotsuse[(1+length(idx_s)):capl]
mslst0[idx] = mslst[(1+length(idx_s)):capl]
}
knotsuse = knotsuse0
numknotsuse = numknotsuse0
mslst = mslst0
}
env$knots = knotsuse
env$numknots = numknotsuse
env$xid1 = xid1
env$xid2 = xid2
env$xmat2 = xmat2
env$knotsuse2 = knotsuse2
env$numknotsuse2 = numknotsuse2
env$df = n - length(a)
env$df.null = n - length(a)
env$df.residual = n - cpar * df_obs
#env$df.residual = n - np - length(a) - cpar * df_obs
#env$sps2 = sps2
#env$ms2 = ms2
return(env)
}
###################
#summary.cgam.polr#
###################
summary.cgam.polr = function(object,...) {
coefs = object$zcoefs
n = length(coefs)
zid = object$zid
zid1 = object$zid1
zid2 = object$zid2
tms = object$tms
is_param = object$is_param
is_fac = object$is_fac
vals = object$vals
zeta = object$zeta
hess = object$wta
pc = length(zeta)
np = object$d0
df_obs = object$df_obs
cpar = object$cpar
#pvals = object$pvals
#if ((n - np - cpar * df_obs) <= 0) {
# pvals.beta[i] <- 2 * (1 - pt(abs(tstat[i]), df_obs))
# warning ('Effective degrees of freedom is close to the number of observations! Inference about parametric covariates is not reliable!')
#} else {
# pvals.beta[i] <- 2 * (1 - pt(abs(tstat[i]), n - np - cpar * df_obs))
#}
if (length(coefs) >= 1) {
rslt1 = data.frame("Estimate" = round(coefs, 4))
#rownames(rslt1)[1] <- "(Intercept)"
if (n >= 1) {
lzid = length(zid1)
for (i in 1:lzid) {
pos1 = zid1[i]
pos2 = zid2[i]
for (j in pos1:pos2) {
if (!is_param[i]) {
rownames(rslt1)[j] = paste(attributes(tms)$term.labels[zid[i] - 1], rownames(rslt1)[j], sep = "")
} else {
rownames(rslt1)[j] = paste(attributes(tms)$term.labels[zid[i] - 1], vals[j], sep = "")
}
}
}
}
rslt1 = as.matrix(rslt1)
} else {rslt1 = NULL}
rslt = matrix(0, pc, 3L, dimnames = list(names(zeta), c("Estimate", "StdErr", "t.value")))#"p.value"
rslt[, 1L] = round(zeta, 4)
hess = object$wta
covmat = solve(hess)
rslt[, 2L] = round(sqrt(diag(covmat)), 4)
rslt[, 3L] = round(rslt[, 1L]/rslt[, 2L], 4)
#tstat = rslt[, 3L]
#pvals = 2 * (1 - pt(abs(tstat), n - np - pc - cpar * (nzeta+df_obs)))
#rslt[, 4L] = pvals
#object$coefficients = coefs
#object$pc = pc
#if(correlation)
# object$correlation <- (vc/sd)/rep(sd, rep(pc+q, pc+q))
ans = list(call = object$call, coefficients = rslt, cic = object$cic, pc=pc, deviance=object$deviance, df.residual=object$df.residual, rslt1 = rslt1)
class(ans) = "summary.cgam.polr"
return (ans)
}
#########################
#print.summary.cgam.polr#
#########################
print.summary.cgam.polr = function(x,...) {
#rslt = x$coefficients
#pc = x$pc
#if(pc > 0) {
# cat("\nCoefficients:\n")
# print(x$coefficients[seq_len(pc), , drop=FALSE], quote = FALSE,
# digits = digits, ...)
#} else {
# cat("\nNo coefficients\n")
#}
cat("Call:\n")
print(x$call)
if (!is.null(x$rslt1)) {
cat("\n")
cat("Coefficients:")
cat("\n")
print (x$rslt1)
}
cat("\nIntercepts:\n")
#print(rslt[(pc+1L):nrow(rslt), , drop=FALSE], quote = FALSE)
printCoefmat(x$coefficients, P.values = FALSE, has.Pvalue = FALSE)
#cat("\nResidual Deviance:", format(x$deviance, nsmall=2L), "\n")
cat("\nResidual deviance: ", round(x$deviance, 4), " ", "on ", x$df.residual, " ", "observed degrees of freedom", sep="", "\n")
if (!is.null(x$cic)) {
cat("CIC:", format(x$cic), "\n")
}
#if(nzchar(mess <- naprint(x$na.action))) cat("(", mess, ")\n", sep="")
#if(!is.null(correl <- x$correlation)) {
# cat("\nCorrelation of Coefficients:\n")
# ll <- lower.tri(correl)
# correl[ll] <- format(round(correl[ll], digits))
# correl[!ll] <- ""
# print(correl[-1L, -ncol(correl)], quote = FALSE, ...)
#}
invisible(x)
}
dev_fun = function(y, a = NULL, eta = NULL, flat = TRUE, w = NULL) {
n = length(y)
if (is.null(w)) {
w = rep(1, n)
}
if (flat) {
eta = rep(0, n)
luy = length(unique(y))-1
if (all(w == 1)) {
a = sapply(1:luy, function(ct) log(sum(y <= ct)/(n-sum(y <= ct))))
} else {
a = 1:luy*0
for (i in 1:luy) {
a[i] = log(sum((y <= i)* w) / (sum(w) - sum((y <= i)* w)))
}
}
}
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == y)
llh = 0
for (i in 1:nc) {
if (i == 1) {
llhi = sum(w * y_id[i,] * log(pfun(a[1] - eta)))
} else if (i == nc) {
llhi = sum(w * y_id[i,] * log(1 - pfun(a[nc-1] - eta)))
} else {
llhi = sum(w * y_id[i,] * log(pfun(a[i] - eta) - pfun(a[i-1] - eta)))
}
llh = llh + llhi
}
#llh = -2/n*llh
dev = -2*llh
return (dev)
}
##
predict_polr = function(a, eta) {
nc = length(a) + 1
n = length(eta)
ps = matrix(0, nrow = nc, ncol = n)
cums = matrix(0, nrow = nc, ncol = n)
for (i in 1:nc) {
if (i == 1) {
ps[i,] = pfun(a[1] - eta)
#cums[, i] = ps[, i]
} else if (i == nc) {
ps[i,] = 1 - pfun(a[nc-1] - eta)
} else {
ps[i,] = pfun(a[i] - eta) - pfun(a[i-1] - eta)
#cums[, i] = ps[, i] + ps[, i-1]
}
}
cums = apply(ps, 2, cumsum)
rhs = a[nc-1] - eta
mu = exp(rhs) / (1 + exp(rhs))
rslt = new.env()
rslt$ps = ps
rslt$mu = mu
rslt$cums = cums
return (rslt)
}
polr_getedf = function(ysim, bigmat, np, capm, shapes, w = NULL) {
fmin = function(a) {
nc = length(a) + 1
y_id = t(col(matrix(0, length(ysim), nc)) == ysim)
llh = 0
for (i in 1:nc) {
if (i == 1) {
llhi = sum(w * y_id[i,] * log(pfun(a[1] - eta)))
} else if (i == nc) {
llhi = sum(w * y_id[i,] * log(1 - pfun(a[nc-1] - eta)))
} else {
llhi = sum(w * y_id[i,] * log(pfun(a[i] - eta) - pfun(a[i-1] - eta)))
}
llh = llh + llhi
}
-2*llh
}
gmin = function(a) {
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == ysim)
gr = NULL
for (i in 1:(nc-1)) {
if (i == 1) {
gri = -sum(y_id[1,] * w * (1 - pfun(a[1] - eta))) + sum(y_id[2,] * w * dfun(a[1] - eta) / (pfun(a[2] - eta) - pfun(a[1] - eta)))
} else if (i == (nc-1)) {
gri = -sum(y_id[nc-1,] * w * dfun(a[nc-1] - eta) / (pfun(a[nc-1] - eta) - pfun(a[nc-2] - eta))) + sum(I(ysim == nc) * w * dfun(a[nc-1] - eta) / (1 - pfun(a[nc-1] - eta)))
#gri = -sum(y_id[nc-1,id] * w[id] * dfun(a[nc-1] - eta[id]) / (pfun(a[nc-1] - eta[id]) - pfun(a[nc-2] - eta[id]))) + sum(y_id[nc,id] * w[id] * dfun(a[nc-1] - eta[id]) / (1 - pfun(a[nc-1] - eta[id])))
} else {
gri = -sum(y_id[i,] * w * dfun(a[i] - eta) / (pfun(a[i] - eta) - pfun(a[i-1] - eta))) + sum(y_id[i+1,] * w * dfun(a[i] - eta) / (pfun(a[i+1] - eta) - pfun(a[i] - eta)))
}
gr = c(gr, gri)
}
return (gr)
}
nc = length(unique(ysim)) - 1
n = length(ysim)
if (is.null(w)) {
w = rep(1, n)
}
if (all(w == 1)) {
a = sapply(1:nc, function(ct) log(sum(ysim <= ct) / (n - sum(ysim <= ct))))
} else {
a = 1:nc*0
for (i in 1:nc) {
a[i] = log(sum((ysim <= i)* w) / (sum(w) - sum((ysim <= i)* w)))
}
}
gr = 1:n*0
wt = 1:n*0
eta = 1:n*0
diff = 100
nrep = 0
oldmu = 1:n*0+1
face = NULL
while(diff > 1e-8 & nrep < 400){
nrep = nrep+1
#eta step:
gr = fgr(a, ysim, eta, w)
wt = fwt(a, ysim, eta, w)
q0 = diag(as.vector(wt))
cvec = wt * eta - gr
zvec = 1:n*0
zvec[wt == 0] = 1 / 1e-4
zvec[wt > 0] = cvec[wt > 0] / sqrt(wt[wt > 0])
gmat = t(bigmat)
for (j in 1:n) {gmat[j,] = bigmat[,j] * sqrt(wt[j])}
if (np > 0) {
zsend = gmat[, 1:np]
if (capm > 0) {
dsend = t(gmat[, (np+1):(nrow(bigmat))])
} else {dsend = NULL}
} else {
dsend = t(gmat)
zsend = NULL
}
#print (dsend)
if (capm > 0) {
#ans = coneB(zvec, dsend, vmat = zsend)
if (nrep > 1) {
ans = coneB(zvec, t(dsend), vmat = zsend, face = face)
} else {
ans = coneB(zvec, t(dsend), vmat = zsend)
face = ans$face
}
bh = coef(ans)
} else {
bh = solve(t(zsend) %*% zsend, t(zsend) %*% zvec)
}
#print (bh)
eta = t(bigmat) %*% bh
#a step:
#res = optim(a, fmin, gr = gmin)
#a = res$par
#print (a)
gr_a = fgr_a(a, ysim, eta, w)
wt_a = fwt_a(a, ysim, eta, w)
qmat_a = wt_a
a = a - solve(qmat_a, gr_a)
#a = atil + bh[1]
#if (a[1] >= a[2]) {
if (any(a != sort(a))) {
print ('a wrong!')
break
}
mu = predict_polr(a, eta)$mu
diff = mean((mu-oldmu)^2)
oldmu = mu
}
edf = sum(abs(bh) > 0)
return (edf)
}
#big phi
pfun = function(x, sc = 1) {
if (sc == 1) {
#return (exp(x) / (1 + exp(x)))
return (1 - 1 / (1 + exp(x)))
} else {
xtil = x / sc
return (exp(xtil) / (1 + exp(xtil)))
}
}
#small phi
dfun = function(x, sc = 1) {
#d1 = exp(x) / (1 + exp(x))
d1 = 1 - 1 / (1 + exp(x))
d2 = 1 / (1 + exp(x))
if (sc == 1) {
#print (range(d1*d2))
return (d1 * d2)
} else {
xtil = x / sc
d1 = exp(xtil) / (1 + exp(xtil))
d2 = 1 / (1 + exp(xtil))
return (1 / sc * d1 * d2)
}
}
#derivative of small phi
ddfun = function(x, sc = 1) {
if (sc == 1) {
#dd = dfun(x) * (1 - exp(x)) / (1 + exp(x))
dd = dfun(x) * (2 / (1 + exp(x)) - 1)
return (dd)
} else {
xtil = x / sc
dd = 1 / sc * dfun(xtil, sc = sc) * (1 - exp(xtil)) / (1 + exp(xtil))
return (dd)
}
}
#k = 4: gr w.r.t eta
fgr = function(a, y, eta, w = NULL) {
n = length(y)
if (is.null(w)) {
w = rep(1, n)
}
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == y)
gr = 1:n*0
for (i in 1:nc) {
if (i == 1) {
gri = y_id[i,] * (1 - pfun(a[1] - eta)) * w
} else if (i == nc) {
gri = -y_id[i,] * (pfun(a[nc-1] - eta)) * w
} else {
gri = y_id[i,] * (1 - pfun(a[i-1] - eta) - pfun(a[i] - eta)) * w
}
gr = gr + gri
}
gr = round(gr, 6)
return (gr)
}
#k = 4: Hess w.r.t eta
fwt = function(a, y, eta, w = NULL) {
n = length(y)
if (is.null(w)) {
w = rep(1, n)
}
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == y)
wt = 1:n*0
for (i in 1:nc) {
if (i == 1) {
wti = y_id[i,] * dfun(a[1] - eta) * w
} else if (i == nc) {
wti = y_id[i,] * dfun(a[nc-1] - eta) * w
} else {
wti = y_id[i,] * (dfun(a[i-1] - eta) + dfun(a[i] - eta)) * w
}
wt = wt + wti
}
wt = round(wt, 6)
return (wt)
}
#k = 4: gr w.r.t a1, a2, a3
fgr_a = function(a, y, eta, w = NULL) {
n = length(y)
if (is.null(w)) {
w = rep(1, n)
}
gr = NULL
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == y)
for (i in 1:(nc-1)) {
if (i == 1) {
id = (pfun(a[2] - eta) - pfun(a[1] - eta)) != 0
gri = -sum(y_id[1,id] * w[id] * (1 - pfun(a[1] - eta[id]))) + sum(y_id[2,id] * w[id] * dfun(a[1] - eta[id]) / (pfun(a[2] - eta[id]) - pfun(a[1] - eta[id])))
} else if (i == (nc-1)) {
id = (pfun(a[nc-1] - eta) - pfun(a[nc-2] - eta)) != 0
gri = -sum(y_id[nc-1,id] * w[id] * dfun(a[nc-1] - eta[id]) / (pfun(a[nc-1] - eta[id]) - pfun(a[nc-2] - eta[id]))) + sum(I(y[id] == nc) * w[id] * dfun(a[nc-1] - eta[id]) / (1 - pfun(a[nc-1] - eta[id])))
#gri = -sum(y_id[nc-1,id] * w[id] * dfun(a[nc-1] - eta[id]) / (pfun(a[nc-1] - eta[id]) - pfun(a[nc-2] - eta[id]))) + sum(y_id[nc,id] * w[id] * dfun(a[nc-1] - eta[id]) / (1 - pfun(a[nc-1] - eta[id])))
} else {
id1 = (pfun(a[i] - eta) - pfun(a[i-1] - eta)) != 0
id2 = (pfun(a[i+1] - eta) - pfun(a[i] - eta)) != 0
id12 = id1 & id2
gri = -sum(y_id[i,id12] * w[id12] * dfun(a[i] - eta[id12]) / (pfun(a[i] - eta[id12]) - pfun(a[i-1] - eta[id12]))) + sum(y_id[i+1,id12] * w[id12] * dfun(a[i] - eta[id12]) / (pfun(a[i+1] - eta[id12]) - pfun(a[i] - eta[id12])))
}
gr = c(gr, gri)
}
return (gr)
}
#k = 4: Hess diagonal w.r.t a1, a2, a3 and off-diagonal
fwt_a = function(a, y, eta, w = NULL) {
n = length(y)
if (is.null(w)) {
w = rep(1, n)
}
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == y)
wt = matrix(0, (nc-1), (nc-1))
for (i in 1:(nc-1)) {
if (i == 1) {
id = (pfun(a[2] - eta) - pfun(a[1] - eta)) != 0
wt[1,1] = sum(y_id[1,id] * w[id] * dfun(a[1] - eta[id])) + sum(y_id[2,id] * w[id] * (ddfun(a[1] - eta[id]) / (pfun(a[2] - eta[id]) - pfun(a[1] - eta[id])) + (dfun(a[1] - eta[id]) / (pfun(a[2] - eta[id]) - pfun(a[1] - eta[id])))^2))
wt[1,2] = wt[2,1] = -sum(y_id[2,id] * w[id] * (dfun(a[2] - eta[id]) * dfun(a[1] - eta[id])) / (pfun(a[2] - eta[id]) - pfun(a[1] - eta[id]))^2)
} else if (i == (nc-1)) {
id = (pfun(a[nc-1] - eta) - pfun(a[nc-2] - eta)) != 0
wt[nc-1, nc-1] = -sum(y_id[nc-1,id] * w[id] * (ddfun(a[nc-1] - eta[id]) / (pfun(a[nc-1] - eta[id]) - pfun(a[nc-2] - eta[id])) - (dfun(a[nc-1] - eta[id]) / (pfun(a[nc-1] - eta[id]) - pfun(a[nc-2] - eta[id])))^2)) + sum(y_id[nc,id] * w[id] * dfun(a[nc-1] - eta[id]))
} else {
id1 = (pfun(a[i] - eta) - pfun(a[i-1] - eta)) != 0
id2 = (pfun(a[i+1] - eta) - pfun(a[i] - eta)) != 0
id12 = id1 & id2
wt[i,i] = -sum(y_id[i,id12] * w[id12] * (ddfun(a[i] - eta[id12]) / (pfun(a[i] - eta[id12]) - pfun(a[i-1] - eta[id12])) - (dfun(a[i] - eta[id12]) / (pfun(a[i] - eta[id12]) - pfun(a[i-1] - eta[id12])))^2)) + sum(y_id[i+1,id12] * w[id12] * (ddfun(a[i] - eta[id12]) / (pfun(a[i+1] - eta[id12]) - pfun(a[i] - eta[id12])) + (dfun(a[i] - eta[id12]) / (pfun(a[i+1] - eta[id12]) - pfun(a[i] - eta[id12])))^2))
wt[i,i+1] = wt[i+1,i] = -sum(y_id[i+1,id12] * w[id12] * (dfun(a[i+1] - eta[id12]) * dfun(a[i] - eta[id12])) / (pfun(a[i+1] - eta[id12]) - pfun(a[i] - eta[id12]))^2)
}
}
return (wt)
}
####
#estimate the probability of the latent variable lying
#between cut-points
####
#predict.cgam.polr = function(object,...) {
#fitted.cgam.polr = function(object) { #
# a = object$zeta
# eta = object$muhat
# lev = object$lev
# nc = length(a) + 1
# n = length(eta)
# ps = matrix(0, nrow = nc, ncol = n)
# for (i in 1:nc) {
# if (i == 1) {
# ps[i,] = pfun(a[1] - eta)
# } else if (i == nc) {
# ps[i,] = 1 - pfun(a[nc-1] - eta)
# } else {
# ps[i,] = pfun(a[i] - eta) - pfun(a[i-1] - eta)
# }
# }
# ps = t(ps)
# dimnames(ps) = list(1:n, lev)
# return (ps)
#}
#####
Ord = function(link = "identity") {
linktemp <- substitute(link)
if (!is.character(linktemp))
linktemp <- deparse(linktemp)
if (linktemp %in% c("identity"))
stats <- make.link(linktemp)
else if (is.character(link)) {
stats <- make.link(link)
linktemp <- link
}
else {
if (inherits(link, "link-glm")) {
stats <- link
if (!is.null(stats$name))
linktemp <- stats$name
}
else stop(linktemp, " link not available for ordered categorical family; available links are \"identity\"")
}
structure(list(family = "ordered", link = linktemp), class = "family")
}
#########################################
#subroutines for confidence interval
#########################################
makebin = function(x) {
k = length(x)
r = 0
for (i in 1:k) {
r = r + x[k-i+1]*2^(i-1)
}
r
}
getvars = function(num) {
i = num
digits = 0
power = 0
while (digits == 0) {
if (i < 2^power) {
digits = power
}
power = power+1
}
binry = 1:digits*0
if (num > 0) {
binry[1] = 1
}
i = i - 2^(digits - 1)
power = digits - 2
for (p in power:0) {
if (i >= 2^p) {
i = i - 2^p
binry[digits-p] = 1
}
}
binry
}
getbin = function(num, capl) {
br = getvars(num-1)
digits = length(br)
binrep = 1:capl*0
binrep[(capl-digits+1):capl] = br
binrep
}
########################################################
#cgam.pv:get p-values for smooth-constrained components#
#when there is only one x and one z, and test for x
#then it's not a sub-cone test and we don't use amat0 and coneA
#include mixed-effect for gaussian: weights is uinv_mat
###############################################################
cgam.pv = function(y, xmat, zmat, shapes, delta=NULL, np=NULL, capms=NULL,
numknotsuse=NULL, varlist=NULL, family=gaussian(),
weights=NULL, test_id=1, nsims=1000, skip=TRUE) {
n = length(y)
cicfamily <- CicFamily(family)
llh.fun <- cicfamily$llh.fun
#new: use log link in gamma
linkfun <- cicfamily$linkfun
etahat.fun <- cicfamily$etahat.fun
gr.fun <- cicfamily$gr.fun
wt.fun <- cicfamily$wt.fun
zvec.fun <- cicfamily$zvec.fun
muhat.fun <- cicfamily$muhat.fun
ysim.fun <- cicfamily$ysim.fun
deriv.fun <- cicfamily$deriv.fun
dev.fun <- cicfamily$dev.fun
capl = length(xmat) / n
if (capl < 1) {capl = 0}
capk = length(zmat) / n
if (capk < 1) {capk = 0}
capls = sum(shapes == 17)
one = 1:n*0 + 1
if (!skip) {
#numknots = c(0,0,0)
#knots = list(); for (i in 1:3) knots[[i]] = 0
#space = rep('E',3)
numknots <- rep(0, capl)
knots <- list(); for (i in 1:capl) knots[[i]] <- 0
space <- rep('E',capl)
delta <- NULL
varlist <- NULL
xid1 <- NULL; xid2 <- NULL; xpos2 <- 0
knotsuse <- list(); numknotsuse <- NULL
mslst <- list()
#new:
capm <- 0
capms <- 0
del1_ans <- makedelta(xmat[, 1], shapes[1], numknots[1], knots[[1]], space = space[1])
del1 <- del1_ans$amat
knotsuse[[1]] <- del1_ans$knots
mslst[[1]] <- del1_ans$ms
if(shapes[1] >= 9 & shapes[1] <= 17) {
numknotsuse <- c(numknotsuse, length(del1_ans$knots))
} else{
numknotsuse <- c(numknotsuse, nrow(del1))
}
m1 <- length(del1) / n
#new code: record the number of columns of del1 if shapes0[1] == 17:
if (shapes[1] == 17) {capms <- capms + m1}
var1 <- 1:m1*0 + 1
xpos1 <- xpos2 + 1
xpos2 <- xpos2 + m1
xid1 <- c(xid1, xpos1)
xid2 <- c(xid2, xpos2)
if (capl == 1) {
delta <- del1
varlist <- var1
} else {
for (i in 2:capl) {
#new code:
del2_ans <- makedelta(xmat[,i], shapes[i], numknots[i], knots[[i]], space = space[i])
del2 <- del2_ans$amat
knotsuse[[i]] <- del2_ans$knots
mslst[[i]] <- del2_ans$ms
if(shapes[i] >= 9 & shapes[i] <= 17) {
numknotsuse <- c(numknotsuse, length(del2_ans$knots))
} else{
numknotsuse <- c(numknotsuse, nrow(del2))
}
m2 <- length(del2) / n
#new code: record the number of columns of del2 if shapes0[i] == 17:
if (shapes[i] == 17) {capms <- capms + m2}
xpos1 <- xpos2 + 1
xpos2 <- xpos2 + m2
xid1 <- c(xid1, xpos1)
xid2 <- c(xid2, xpos2)
delta <- rbind(del1, del2)
varlist <- 1:(m1 + m2)*0
varlist[1:m1] <- var1
varlist[(m1 + 1):(m1 + m2)] <- (1:m2)*0 + i
var1 <- varlist
m1 <- m1 + m2
del1 <- delta
}
}
}
umbrella.delta = tree.delta = NULL
#ignore ut for now
delta_ut = NULL; caput = 0
if (!is.null(umbrella.delta) | !is.null(tree.delta)) {
delta_ut = rbind(umbrella.delta, tree.delta)
caput = nrow(delta_ut)
}
#del1 is edges for the component being tested; del0 is the cone with del1 removed
del1 = t(delta[varlist == test_id, ])
if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0 & capk > 0) {
del0 = cbind(t(delta[varlist != test_id, ]), one, zmat, xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13])
del = cbind(t(delta), one, zmat, xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13])
np = 1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0 & capk == 0) {
del0 = cbind(t(delta[varlist != test_id, ]), one, xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13])
del = cbind(t(delta), one, xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13])
np = 1 + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0 & capk > 0) {
del0 = cbind(t(delta[varlist != test_id, ]), one, zmat)
del = cbind(t(delta), one, zmat)
np = 1 + capk + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0 & capk == 0) {
del0 = cbind(t(delta[varlist != test_id, ]), one)
del = cbind(t(delta), one)
np = 1 + capms
} else {
print ("error in capk, shapes!")
}
m0 = dim(del0)[2]
m = dim(del)[2]
#nkts is the col number of edges for each component
nkts = numknotsuse
id_add = which(shapes >= 13 & shapes <= 17)
if (length(id_add) >= 1) {
nkts[id_add] = nkts[id_add] + 1
}
nr = sum(nkts)
nc = nr + np
amat = matrix(0, nrow=nr, ncol=nc)
for(i in 1:nr){amat[i,i]=1}
#if (capl>1) {
nr0 = sum(nkts) - nkts[test_id]
#} else {nr0 = sum(nkts)}
#nc0 = nr0 + np
#debugged
if (any(shapes == 17)) {
nc0 = nr0 + np - capms
} else {
nc0 = nr0 + np
}
amat0 = matrix(0, nrow=nr0, ncol=nc0)
#when there is only one component, flat vs s.incr
if (nr0 > 0) {
for(i in 1:nr0){amat0[i,i]=1}
} #else {'Use shapereg in coneproj'}
wt.iter = FALSE
if (family$family %in% c("binomial", "poisson")) {
wt.iter = TRUE
}
if (!wt.iter) {
if (is.null(weights)) {
weights = 1:n*0 + 1
}
w = weights
#new: to check if w is a matrix or not to include the mixed-effect case
### null hyp fit
if(!is.matrix(w)){
ytil = y*sqrt(w)
deltil = del0
for(i in 1:m0){deltil[,i] = deltil[,i]*sqrt(w)}
} else {
#w is uinv_mat
ytil = w %*% y
deltil = w %*% del0
}
#print (m0)
#print (np)
#print (head(del0))
if (m0 > np) {
umat = chol(crossprod(deltil))
uinv = solve(umat)
ytiltil = t(uinv) %*% crossprod(deltil, ytil)
atil = amat0 %*% uinv
ans = coneA(ytiltil, atil)
chat = uinv %*% ans$thetahat
mu1 = del0 %*% chat
#d0 = cbind(del2, del3)
} else {
cvec = t(deltil) %*% ytil
chat = solve(crossprod(deltil), cvec)
mu1 = del0 %*% chat
}
if (m0 > np) {
d0 = t(delta[varlist != test_id, ])
pr0 = -d0 %*% solve(crossprod(d0), t(d0))
for(i in 1:n){pr0[i,i] = 1+pr0[i,i]}
d1tr = pr0 %*% del1
#} else {
#d1tr = del1
#}
## do weighted projection of xi=z, weights w, onto d1tr cone
d1trw = d1tr
nk1 = nkts[test_id]
#new
if(!is.matrix(w)){
for(i in 1:nk1){d1trw[,i] = d1tr[,i]*sqrt(w)}
} else {
d1trw = w %*% d1trw
}
ans1 = coneB(ytil, d1trw)
num = sum((d1trw%*%ans1$coef)^2)
## do weighted projection of xi=z, weights w, onto big cone
delw = del
#new
if(!is.matrix(w)){
for(i in 1:m){delw[,i] = del[,i]*sqrt(w)}
} else {
delw = w %*% delw
}
ans2 = coneB(ytil,delw[,1:(m-np)],delw[,(m-np+1):m])
coef0 = ans2$coef
coef = coef0
coef[1:(m-np)] = coef0[(np+1):m]
coef[(m-np+1):m] = coef0[1:np]
ss2 = sum((ytil-delw%*%coef)^2)
#ss2 = sum((ytil-delw[,1:(m-np)]%*%ans2$coef[(np+1):m]-delw[,(m-np+1):m]*ans2$coef[1:np])^2)
df2 = n-sum(abs(ans2$coef)>1e-8)
#df2 = n - m
bstat = num/(num+ss2)
## get mixing distn
mdist = 0:nk1*0
for(isims in 1:nsims){
ysim = rnorm(n)
anss = coneB(ysim, d1trw)
d = sum(anss$coef>1e-8)
mdist[d+1] = mdist[d+1]+1
}
mdist = mdist/nsims
pval = mdist[1]
for(i in 1:nk1){
pval = pval+pbeta(bstat,i/2,df2/2)*mdist[i+1]
}
pv = 1-pval
} else {
#print (dim(del))
del2 = del
#new
if(!is.matrix(w)){
for(i in 1:m){del2[,i] = del2[,i] * sqrt(w)}
} else {
del2 = w %*% del2
}
nk = ncol(del1)
ans2 = coneB(ytil, del2[,1:nk], deltil)
chat2 = ans2$coefs
#nd = np?
nd = ncol(deltil)
that1 = deltil%*%chat2[1:nd]+del2[,1:nk]%*%chat2[(nd+1):m]
ss1 = sum((ytil-that1)^2)
ss0 = sum((ytil-deltil%*%chat)^2)
bstat = (ss0-ss1)/ss0
## get mixing distribution
mdist = 0:nk*0
keepd = 1:nsims
for(isims in 1:nsims){
ysim = rnorm(n)
anss = coneB(ysim, del2[,1:nk], deltil)
d = sum(abs(round(anss$coef,8))>0)
#mdist[d-2] = mdist[d-2]+1
mdist[d+1-np] = mdist[d+1-np]+1
#mdist[d] = mdist[d]+1
keepd[isims] = d
if(d < 3){zkeep=ysim}
}
mdist = mdist/nsims
pval = mdist[1]
for(i in 1:nk) {
pval = pval + pbeta(bstat,i/2,(n-np-i)/2)*mdist[i+1]
}
pv = 1-pval
}
} else {
#print (head(del0))
### null hyp fit
eta0 = 1:n*0
z = 1:n
#mu0 = muhat.fun(eta0, fml=family$family)
mu0 = 1:n*0 + 1/2
mu1 = mu0
if (is.null(weights)) {
weights = 1:n*0 + 1
}
prior.w = weights
end = FALSE; nrep = 0; face = NULL
while (!end & nrep < 100) {
nrep = nrep+1
if (family$famil == "binomial") {
ch = mu0>1e-5 & mu0<1-1e-5
}
if (family$famil == "poisson") {
ch = mu0>1e-5
}
z[ch] = eta0[ch] + (y[ch]-mu0[ch]) * deriv.fun(mu0[ch], fml = family$family)
z[!ch] = eta0[!ch]
w = as.vector(prior.w * (deriv.fun(mu0, fml = family$family))^(-1))
#w = mu0*(1-mu0)
#to avoid deltil to be singular; test!
w[which(round(w, 7) == 0)] = 1e-7
ztil = z*sqrt(w)
deltil = del0
#print (m0)
#print (any(round(w, 7) == 0))
#print (w[round(w, 7) == 0])
for(i in 1:m0){deltil[,i] = deltil[,i]*sqrt(w)}
if (m0 > np) {
#print ('True')
#print (qr(crossprod(deltil))$rank)
umat = chol(crossprod(deltil))
uinv = solve(umat)
ztiltil = t(uinv) %*% crossprod(deltil, ztil)
atil = amat0 %*% uinv
#if (nrep > 1) {
ans = coneA(ztiltil, atil, face=face)
#} else {
# ans = coneA(ztiltil, atil)
# face = ans$face
#if (nrep == 107 | nrep == 108) {
# print (face)
#}
#}
chat = uinv %*% ans$thetahat
} else {
#cvec = t(deltil) %*% ztil
#chat = solve(crossprod(deltil), cvec)
chat = solve(t(deltil)%*%deltil)%*%t(deltil)%*%ztil
}
eta1 = del0 %*% chat
mu1 = muhat.fun(eta1, fml=family$family)
#tb=eta1>50
#mu1=eta1
#mu1[!tb]=exp(eta1[!tb])/(1+exp(eta1[!tb]))
#mu1[tb]=1
ch2 = mu1 > 2*max(y)
if (length(ch2) >= 1) {
mu1[ch2] = 2*max(y)
}
dist = sqrt(sum(mu0-mu1)^2/sum(mu0^2))
#print (dist)
if (dist < 1e-5){end = TRUE} else {eta0=eta1;mu0=mu1}
}
#print (head(mu1,10))
#if m0 > np, del0 is a cone containing a linear space
if (m0 > np) {
d0 = t(delta[varlist != test_id, ])
#pr0 = -d0%*%solve(crossprod(d0), t(d0))
#for(i in 1:n){pr0[i,i] = 1+pr0[i,i]}
#d1tr = pr0%*%del1
## do weighted projection of xi=z, weights w, onto d1tr cone
#d1trw = d1tr
#nk1 = nkts[test_id]
#for(i in 1:nk1){d1trw[,i] = d1tr[,i]*sqrt(w)}
#to make sure edges are orthogonal:
m0a = dim(d0)[2]
d0w = d0
for(i in 1:m0a){d0w[,i] = d0[,i]*sqrt(w)}
pr0 = -d0w %*% solve(t(d0w) %*% d0w) %*% t(d0w)
for(i in 1:n){pr0[i,i]=1+pr0[i,i]}
#}
del1w = del1
nk1 = nkts[test_id]
for(i in 1:nk1){del1w[,i] = del1[,i]*sqrt(w)}
#if (capl > 1) {
d1trw = pr0%*%del1w
#} else {
#d1trw = del1w
ans1 = coneB(ztil, d1trw)
num = sum((d1trw %*% ans1$coef)^2)
## do weighted projection of xi=z, weights w, onto big cone
delw = del
for(i in 1:m){delw[,i] = del[,i]*sqrt(w)}
ans2 = coneB(ztil,delw[,1:(m-np)],delw[,(m-np+1):m])
coef0 = ans2$coef
coef = coef0
coef[1:(m-np)] = coef0[(np+1):m]
coef[(m-np+1):m] = coef0[1:np]
#ss2 = sum((ztil-delw[,1:(m-np)]%*%ans2$coef[(np+1):m]-delw[,(m-np+1):m]*ans2$coef[1:np])^2)
ss2 = sum((ztil-delw%*%coef)^2)
#df2=n-sum(abs(ans2$coef)>1e-8)
df2 = n - m
bstat = num/(num+ss2)
#print (bstat)
#print (dim(amat))
#print (dim(amat0))
mdist = 0:nk1*0
for(isims in 1:nsims){
zsim = rnorm(n)
anss = coneB(zsim, d1trw)
d = sum(anss$coef>1e-8)
mdist[d+1] = mdist[d+1]+1
}
mdist = mdist/nsims
pval = mdist[1]
for(i in 1:nk1){
pval = pval+pbeta(bstat,i/2,df2/2)*mdist[i+1]
}
pv = 1-pval
} else {
#print (head(del))
#only one x and >= one z; del2 is a copy of del
del2 = del
#print (head(del))
#print (head(w))
for(i in 1:m){del2[,i] = del2[,i]*sqrt(w)}
nk = ncol(del1)
#print (nk)
#print (head(del2))
#print (nk)
#print (head(deltil))
#print (nrep)
#print (head(ztil))
#print (head(del2))
ans2 = coneB(ztil, del2[,1:nk], deltil)
chat2 = ans2$coefs
#print (chat2)
#nd = np?
nd = ncol(deltil)
that1 = deltil%*%chat2[1:nd]+del2[,1:nk]%*%chat2[(nd+1):m]
ss1 = sum((ztil - that1)^2)
ss0 = sum((ztil - deltil %*% chat)^2)
#print (ss0)
#print (ss1)
bstat = (ss0 - ss1)/ss0
#print (bstat)
## get mixing distribution
#set.seed(123)
mdist = 0:nk*0
keepd = 1:nsims
for(isims in 1:nsims){
zsim = rnorm(n)
ans = coneB(zsim, del2[,1:nk], deltil)
d = sum(abs(round(ans$coef,8))>0)
#mdist[d-2] = mdist[d-2]+1
mdist[d+1-np] = mdist[d+1-np]+1
#mdist[d] = mdist[d]+1
keepd[isims] = d
if(d < 3){zkeep=zsim}
}
mdist = mdist/nsims
pval = mdist[1]
for(i in 1:nk) {
pval = pval + pbeta(bstat,i/2,(n-np-i)/2)*mdist[i+1]
}
pv = 1-pval
#print (pv)
}
}
ans = list(pv = pv, edf = sum(abs(ans2$coef)>1e-8), coef=ans2$coef, bstat=bstat)
return (ans)
}
############################################################
#cgam.pvz is to test categorical predictors, not every level
#for mixed-effect model, use uinv_mat as w
############################################################
cgam.pvz = function(y, bigmat, df_obs, sse1 = NULL, np = 1, zid = 1, zid1 = 1, zid2 = 1, muhat = NULL,
etahat = NULL, coefskeep = NULL, wt.iter=FALSE, family=gaussian(), weights=NULL,
uinv_mat=NULL) {
n = length(y)
cicfamily = CicFamily(family)
llh.fun = cicfamily$llh.fun
#new: use log link in gamma
linkfun = cicfamily$linkfun
etahat.fun = cicfamily$etahat.fun
gr.fun = cicfamily$gr.fun
wt.fun = cicfamily$wt.fun
zvec.fun = cicfamily$zvec.fun
muhat.fun = cicfamily$muhat.fun
ysim.fun = cicfamily$ysim.fun
deriv.fun = cicfamily$deriv.fun
dev.fun = cicfamily$dev.fun
m = nrow(bigmat)
df_full = min(m, 1.2*df_obs)
if (is.null(weights)) {
weights = 1:n*0 + 1
}
prior.w = weights
#n = ncol(bigmat)
lz = length(zid)
#we only need to get ssers in the following code
pvs = ssers = ssefs = fstats = edfs = rep(0, lz)
#sse_f = NULL
for(iz in 1:lz){
pos1 = zid1[iz]
pos2 = zid2[iz]
bigmat0 = bigmat[-c((pos1+1):(pos2+1)), ,drop = FALSE]
#np0 is the # of columns remaining in the vmat; it's for H_0
np0 = np - (pos2-pos1+1)
#lvs is the # of levels in a z, including the reference level
lvs = (pos2-pos1+1)
edfs[iz] = lvs
#initialize
cvec = NULL
etahat = NULL
if (wt.iter) {
etahat = etahat.fun(n, y, fml = family$family)
gr = gr.fun(y, etahat, weights, fml = family$family)
wt = wt.fun(y, etahat, n, weights, fml = family$family)
cvec = wt * etahat - gr
} else {wt = wt.fun(y, etahat, n, weights, fml = family$family)}
#new:
if(is.null(uinv_mat)){
zvec = zvec.fun(cvec, wt, y, fml = family$family)
gmat = t(bigmat0)
for (i in 1:n) {gmat[i,] = bigmat0[,i] * sqrt(wt[i])}
} else {
#only used for gaussian
zvec = uinv_mat %*% y
gmat = t(bigmat0)
gmat = uinv_mat %*% gmat
}
dsend = gmat[, -c(1:np0), drop = FALSE]
zsend = gmat[,1:np0 , drop = FALSE]
ans = coneB(zvec, dsend, zsend)
face = ans$face
etahat = t(bigmat0) %*% ans$coefs
#coefs = ans$coefs
#muhat = t(bigmat0) %*% coefs
muhat = etahat
if(is.null(uinv_mat)){
sse_r = sum(prior.w * (y - muhat)^2)
}else {
sse_r = sum(uinv_mat %*% (y - muhat)^2)
}
sse_f = sse1
fstati = (sse_r - sse_f) / lvs / sse_f*(n-df_full)
#print (sse_r)
#print (sse_f)
#print (lvs)
#print (n-df_full)
#print (dim(bigmat0))
#print (dim(bigmat))
pvi = 1 - pf(fstati, lvs, n-df_full)
if (wt.iter) {
sm = 1e-7
muhat = muhat.fun(etahat, fml = family$family)
diff = 1
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
nrep = 0
##########
#iterate!#
##########
while (diff > sm & mdiff & nrep < n^2){
oldmu = muhat
nrep = nrep + 1
gr = gr.fun(y, etahat, weights, fml = family$family)
wt = wt.fun(y, etahat, n, weights, fml = family$family)
cvec = wt * etahat - gr
#zvec <- cvec / sqrt(wt)
zvec = zvec.fun(cvec, wt, y, fml = family$family)
#gmat <- t(bigmat %*% sqrt(diag(wt)))
gmat = t(bigmat0)
for (i in 1:n) {gmat[i,] = bigmat0[,i] * sqrt(wt[i])}
dsend = gmat[, -c(1:np0), drop = FALSE]
zsend = gmat[,1:np0 , drop = FALSE]
#ans <- coneB(zvec, t(dsend), zsend)
ans = coneB(zvec, dsend, zsend, face = face)
etahat = t(bigmat0) %*% ans$coefs
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
mdiff = abs(max(muhat) - 1)
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
}
z = 1:n*0
if (family$famil == "binomial") {
ch = muhat>1e-7 & muhat<1-1e-7
}
if (family$famil == "poisson") {
ch = muhat>1e-7
}
z[ch] = etahat[ch] + (y[ch]-muhat[ch]) * deriv.fun(muhat[ch], fml = family$family)
z[!ch] = etahat[!ch]
w = as.vector(prior.w * (deriv.fun(muhat, fml = family$family))^(-1))
#to avoid deltil to be singular
w[which(round(w, 7) == 0)] = 1e-7
ztil = z*sqrt(w)
deltil = t(bigmat0)
m0 = nrow(bigmat0)
for(i in 1:m0){deltil[,i] = deltil[,i]*sqrt(w)}
sse_r = sum((ztil - deltil %*% ans$coefs)^2)
deltil = t(bigmat)
m = nrow(bigmat)
for(i in 1:m){deltil[,i] = deltil[,i]*sqrt(w)}
umat = chol(t(deltil)%*%deltil)
#umat = chol(crossprod(deltil))
uinv = solve(umat)
ztiltil = t(uinv) %*% t(deltil) %*% ztil
#amat = matrix(0, nrow = m, ncol = m)
#nk = m - np
#for(ik in 1:nk){amat[ik,ik] = 1}
amat = diag(m-np)
zerom = matrix(0, nrow=nrow(amat), ncol=np)
amat = cbind(zerom, amat)
atil = amat %*% uinv
ans = coneA(ztiltil, atil)
sse_f = sum((ztil - deltil %*% uinv %*% ans$thetahat)^2)
df_full = min(m, 1.2*ans$df)
fstati = (sse_r - sse_f) / lvs / sse_f*(n-df_full)
pvi = 1 - pf(fstati, lvs, n-df_full)
}
ssers[iz] = sse_r
ssefs[iz] = sse_f
fstats[iz] = fstati
#pvi = 1 - pf(fstati, lvs, n-df_full)
pvs[iz] = pvi
}
rslt = list(pvs = pvs, ssers = ssers, ssefs = ssefs, fstats = fstats, edfs = edfs, mu1 = muhat)
return (rslt)
}
#############
#anova.cgam#
############
anova.cgam <- function(object,...){
family <- object$family
call <- object$call
pvs <- object$pvs
pvsz <- object$pvsz
capl <- object$capl
capk <- object$capk
s.edf <- object$s.edf
z.edf <- object$z.edf
bstats <- object$bstats
fstats <- object$fstats
zid <- object$zid
#zid1 <- object$zid1 - 1 - length(shapes)
#zid2 <- object$zid2 - 1 - length(shapes)
#new: zid1, zid2 just index zmat not bigmat
zid1 <- object$zid1
zid2 <- object$zid2
tms <- object$tms
is_param <- object$is_param
is_fac <- object$is_fac
vals <- object$vals
#new:
rslt1 <- pTerms.pv <- NULL
if (!is.null(pvsz)) {
rslt1 <- data.frame("df" = z.edf, "F-stat" = round(fstats, 4), "p.value" = round(pvsz, 4))
lzid <- length(zid1)
for (i in 1:lzid) {
rownames(rslt1)[i] <- attributes(tms)$term.labels[zid[i] - 1]
}
rslt1 <- as.matrix(rslt1)
pTerms.pv <- pvsz
#rownames(pTerms.pv) <- rownames(rslt1)
}
rslt2 <- s.pv <- NULL
if (!is.null(pvs)) {
rslt2 <- data.frame("edf" = round(s.edf, 4), "mixture of Beta" = round(bstats, 4), "p.value" = round(pvs, 4))
#rownames(rslt2) <- attributes(tms)$term.labels
#debugged: check more
if (!is.null(zid)) {
if(inherits(object, "cgamm")){
rownames(rslt2) <- rev(rev((attributes(tms)$term.labels)[-(zid-1)])[-1])
} else {
rownames(rslt2) <- (attributes(tms)$term.labels)[-(zid-1)]
}
} else {
if(inherits(object, "cgamm")){
rownames(rslt2) <- rev(rev((attributes(tms)$term.labels))[-1])
} else{
rownames(rslt2) <- (attributes(tms)$term.labels)
}
}
s.pv <- pvs
#rownames(s.pv) <- rownames(rslt2)
}
ans <- list(call = call, coefficients1 = rslt1, coefficients2 = rslt2, family = family, s.pv = s.pv, pTerms.pv = pTerms.pv)
class(ans) <- "anova.cgam"
return(ans)
}
print.anova.cgam <- function(x,...){
print(x$family)
cat("Formula:\n")
print(x$call)
if (!is.null(x$coefficients1)) {
cat("\n")
cat("Parametric terms:\n")
printCoefmat(x$coefficients1, P.values = TRUE, has.Pvalue = TRUE)
}
#cat("\n")
if (!is.null(x$coefficients2)) {
cat("\n")
cat("Approximate significance of smooth terms: \n")
printCoefmat(x$coefficients2, P.values = TRUE, has.Pvalue = TRUE)
}
}
###############################################
#subroutines for monotonic variance estimation
###############################################
varest = function(y, x, muhat=NULL, shape=9, var.knots=0, db.exp=FALSE){
n = length(y)
order.id = order(x)
#new:rk to order var back
#rk = rank(x)
#x = x[order.id]
xs = sort(x)
y = y[order.id]
ndegree = 2
#if (length(muhat) == 1){
# muhat = rep(0,n)
#}
#if (length(muhat) == n){
# muhat = muhat
#}
if (n < 20) {
print("ERROR: must have at least 20 observations")
}
if (length(x) != length(y)) {
print("ERROR: length of x must be length of y")
}
if (length(var.knots) > 1) {
var.kint = var.knots[-c(1, length(var.knots))]
} else {
br = c(30, 100, 200, 400, 700, 1000, 1e+10)
obs = 1:7
var.nk = min(obs[n < br]) + 2
var.knots = 0:(var.nk - 1)/(var.nk - 1) * (max(x) - min(x)) + min(x)
var.kint = var.knots[-c(1, length(var.knots))]
}
nknots = length(var.kint)
nk = nknots + 2 + 1
#initial coefficients
theta0 = seq(1, 0.5, length = nk)
dif.theta = 1
amat = matrix(0, ncol = nk, nrow = nk)
#if (increasing == 1){
if (shape == 9) {
for (i in 1:(nk - 1)) {
amat[i, i] = 1
amat[i, i + 1] = -1
}
amat[nk, nk] = 1
}
#if (increasing == 2){
if (shape == 10) {
for (i in 1:(nk - 1)) {
amat[i, i] = -1
amat[i, i + 1] = 1
}
amat[nk, 1] = 1
}
bvec = c(rep(0,nk-1), 10^-10)
Bint = splines::bs(xs, knots = var.kint, degree = 2, intercept = T)
if (!is.null(muhat)) {
r = y - muhat
} else {
r = y
}
sm = 1e-6
nrep = 0
while (dif.theta > sm) {
nrep = nrep + 1
dl = db.penal(theta0, Bint, r, db.exp)
d2l = ddb.penal(theta0, Bint)
res = qprog(d2l, c(t(theta0) %*% d2l) - dl, amat, bvec)
#if (class(res) == "try-error") {
# break
#}
theta1.new = res$thetahat
var1 = 1/(Bint %*% theta1.new)
var0 = 1/(Bint %*% theta0)
dif.theta = sum(abs(var1 - var0))/sum(abs(var0))
theta0 = theta1.new + 1e-10
#print (dif.theta)
}
res0 = theta1.new
if (!db.exp) {
vhat = 1/Bint %*% theta1.new
} else if (db.exp) {
vhat = (1/Bint %*% theta1.new)^2
}
#new
#print (vhat)
#vhat = vhat[rk]
#print (vhat)
vhat=vhat[rank(x)]
res = list(vhat = vhat, muhat = muhat, x = x, y = y, var.knots = var.knots)
return(res)
}
#functions used in the varest function for normal errors
db.penal <- function(betas,B,r, db.exp=FALSE){
nk= ncol(B)
dl=vector()
if (!db.exp) {
for (i in 1:nk){
dl[i]=sum(-(1/(B%*%betas))*B[,i] + (r^2)*B[,i])
}
} else {
for (i in 1:nk){
dl[i]=sum(-(1/(B%*%betas))*B[,i] + sqrt(2)*abs(r)*B[,i])
}
}
return(dl)
}
ddb.penal <- function(betas,B){
nk=ncol(B)
d2l=diag(0,nk)
for (i in 1:nk){
for (j in 1:nk){
d2l[i,j]= sum((1/((B%*%betas)^2))*(B[,i]*B[,j]))
}
}
return(d2l)
}
ddb.penal_dexp <- function(betas,B){
nk=ncol(B)
d2l=diag(0,nk)
for (i in 1:nk){
for (j in 1:nk){
d2l[i,j] = sum((1/((B%*%betas)^2))*(B[,i]*B[,j]))
}
}
return(d2l)
}
#---------------------------------------------------------------------------------------------------------------
# linear monotone/quadratic vs smooth constrained test
#---------------------------------------------------------------------------------------------------------------
testpar <- function(formula0, formula, data, family = gaussian(link = "identity"), ps = NULL, edfu = NULL,
nsim = 200, multicore = TRUE, method = "testpar.fit",
arp = FALSE, p = NULL, space = "Q",...) {
cl <- match.call()
if (is.character(family))
family <- get(family, mode = "function", envir = parent.frame())
if (is.function(family))
family <- family()
if (is.null(family$family))
stop("'family' not recognized!")
mf <- match.call(expand.dots = FALSE)
if(missing(data))
data <- environment(formula)
m <- match(c("formula0", "formula", "data"), names(mf), 0L)
#----------------------------------------------------------------------------------------------------------------------
#formula0 is not very useful; we just need it to see if H0 is linear or quadratic, or a linear plane/interaction plane?
#----------------------------------------------------------------------------------------------------------------------
form0_expr <- deparse(mf[c(1L, m[1])])
expr_inside <- sub(".*\\((.*)\\)", "\\1", form0_expr)
expr_parts <- strsplit(expr_inside, " \\+ ")[[1]]
expr_parts <- lapply(expr_parts, function(x) trimws(gsub("[()]", "", x)))
parametric <- lapply(expr_parts, function(x) {dplyr::case_when(grepl("\\*", x) ~ "warped_plane",
grepl("\\^2", x) ~ "quadratic",
grepl("\\^1", x) ~ "linear",
TRUE ~ "linear")}) |> unlist()
form_expr <- deparse(mf[c(1L, m[2])])
#----------------------------------------------------------
#check attributes in cgam formula; get shapes and x's and y
#----------------------------------------------------------
mf <- mf[c(1L, m[-1])] #used formula
mf[[1L]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
ynm <- names(mf)[1]
mt <- attr(mf, "terms")
y <- model.response(mf, "any")
#------------------------
#extract x, y, z, etc...
#------------------------
#mf is a data frame and can be treated as a list
mf_xz <- mf[, -1, drop = FALSE]
x_or_z <- lapply(mf_xz, function(e) attr(e, "categ"))
is_z <- sapply(x_or_z, is.null)
nvars <- nz <- sum(is_z)
zmat <- x <- shp <- shp_pr <- NULL
if(any(is_z)){
znm_in_form <- names(x_or_z)[which(is_z)]
z_ps_in_param <- sapply(expr_parts, function(e) e == znm_in_form)
parametric <- parametric[-which(z_ps_in_param)]
z <- mf_xz[, is_z, drop = FALSE]
is_fac <- sapply(z, function(e) is.factor(e))
if(any(is_fac)){
#test more
if(sum(!is_fac) > 0){
zmat <- as.matrix(z[, !is_fac, drop = FALSE])
} else {zmat <- NULL}
#add znm later
dd <- model.matrix(~ z[, is_fac], drop = FALSE)[, -1, drop = FALSE]
zmat <- cbind(zmat, dd)
} else {
zmat <- as.matrix(z)
}
}
if(any(!is_z)){
x <- mf_xz[, !is_z, drop = FALSE]
add_or_wps <- lapply(x, function(e) attr(e, "categ")) |> simplify2array()
nx <- length(add_or_wps)
X <- vector("list", length = nx)
if(any(add_or_wps == "warp")){
parametric2 <- rep("linear", length = nx)
rp_ps <- which(parametric != "linear")
rp_ps0 <- rp_ps
if(any(rp_ps > nx)){
rp_ps <- rp_ps - (rp_ps - nx)
}
parametric2[rp_ps] <- parametric[rp_ps0]
if(any(parametric == "warped_plane")){
wp_ps <- which(parametric == "warped_plane")
if(length(wp_ps) == 1){
if(wp_ps > nx){
shift <- max(wp_ps) - nx
parametric2[wp_ps - shift] <- "warped_plane"
} else {
parametric2[wp_ps] <- "warped_plane"
}
}
if(length(wp_ps) > 1){
diff_wp_ps <- diff(wp_ps)
if(any(diff_wp_ps > 2)) {
diff_wp_ps[which(diff_wp_ps > 2)] <- 2
}
min_wp_ps <- wp_ps[1]
new_wp_ps <- c(min_wp_ps, rep(min_wp_ps, length(wp_ps)-1) + diff_wp_ps)
if(any(new_wp_ps > nx)){
shift <- max(new_wp_ps) - nx
new_wp_ps <- new_wp_ps - shift
}
parametric2[new_wp_ps] <- "warped_plane"
}
}
parametric <- parametric2
}
for(ix in 1:nx){
X[[ix]] <- x[, ix]
shape_ix <- attr(X[[ix]], "shape")
if(add_or_wps[ix] == "additive"){
if(!shape_ix %in% c(9, 10)){
attr(X[[ix]], "type") <- "convex"
attr(X[[ix]], "parametric") <- parametric[ix]
} else if(shape_ix %in% c(9, 10)){
attr(X[[ix]], "type") <- "monotone"
#attr(X[[ix]], "parametric") <- "linear"
attr(X[[ix]], "parametric") <- parametric[ix]
}
}
if(add_or_wps[ix] == "warp"){
attr(X[[ix]], "type") <- "monotone_plane"
#temp
attr(X[[ix]], "parametric") <- parametric[ix]
#print (parametric[ix])
}
}
}
#----------------------------------------------------------
#call testpar.fit
#----------------------------------------------------------
fit <- testpar.fit(X=X, y=y, zmat=zmat, family=family, ps=ps, edfu=edfu, nsim=nsim, multicore=multicore,
GCV=FALSE, lams=NULL, arp=arp, p=p, space=space, parametric=parametric)
rslt <- structure(c(fit, list(X = X, zmat = zmat, call = cl, formula0 = formula0, formula = formula, terms = mt, data = data, parametric=parametric, family = family)))
#class(rslt) <- "cgam"
return(rslt)
}
#----------------------------------------------------------
testpar.fit = function(X, y, zmat = NULL, family = gaussian(link="identity"),
ps = NULL, edfu = NULL, nsim = 200, multicore = TRUE,
GCV = FALSE, lams = NULL,
arp = FALSE, p = NULL, space = "Q",...)
{
#print (head(y))
wt.iter = ifelse(family$family == "gaussian", FALSE, TRUE)
extras = list(...)
#new:
#capl = NCOL(x)
capl = length(X)
n = length(y)
k1 = k2 = NULL
p_optim = 0
if(arp){
#if the user didn't provide p, then choose p from 0:3
if(is.null(p)){
p = 0:2
} else if (p < 0 || p > 2) {
warning("The order in AR(p) must be an integer >= 0 and <= 2!")
p = 1
}
} else {
p = 0
}
#-------------------
#get xm, amat, dmat
#-------------------
mult = 2
nz = 0
if(!is.null(zmat)){
nz = NCOL(zmat)
}
xm0 = NULL #combine dd columnwise
amat_lst = vector("list", length = capl)
awmat_lst = vector("list", length = capl)
dmat_lst = vector("list", length = capl)
dd_lst = kts_lst = vector("list", length = capl)
edfu_vec = numeric(capl)
var_track = var_track_param = NULL
iadd = ipr = 0
for(icomp in 1:capl){
x = X[[icomp]] #|> as.matrix()
if(NCOL(x) == 1){
iadd = iadd + 1
xu = unique(x)
n1 = length(xu)
type = attr(x, "type")
nkts = mult * switch(type, monotone = trunc(n1^(1/5)) + 6, convex = trunc(n1^(1/7)) + 6)
if(space == "Q"){
kts = quantile(xu, probs = seq(0, 1, length = nkts), names = FALSE)
}
if(space == "E"){
kts = 0:(nkts - 1) / (nkts - 1) * (max(x) - min(x)) + min(x)
#kts = seq.int(min(x), max(x), length = nkts)
}
kts_lst[[icomp]] = kts
#new: make delta here; combine it into xm
spl_degree = switch(type, monotone = 2L, convex = 3L)
spl_ord = spl_degree + 1
#dd_ans = bqspl(x, m=NULL, knots=kts)
#dd = dd_ans$bmat
dd = bSpline(x, knots = kts[-c(1, nkts)], degree = spl_degree, intercept = TRUE)
#dd = bs(x, knots = kts[-c(1, nkts)], degree = spl_degree, intercept = TRUE)
#xm = cbind(xm, dd)
#test!
if(icomp > 1){
dd = dd[, -1]
}
dd_lst[[icomp]] = dd
var_track = c(var_track, rep(icomp, NCOL(dd)))
#check more
#if(is.null(edfu)){
edfu = switch(type, monotone = (nkts/mult) , convex = (nkts/mult + 1))
edfu_vec[icomp] = edfu #+ nz
#}
shp = attr(x, "shape")
parametric = attr(x, "parametric")
#new: make amat here; add it to amat_lst
amat = makeamat_1D(shp=shp, spl_ord=spl_ord, kts=kts, x=x, x1=min(x), xn=max(x))
#check more
#if(iadd > 1) {
if(icomp > 1){
amat = amat[, -1]
}
amat_lst[[icomp]] = amat
#new: make awmat in case we have plane comps.
#new: make dmat here; add it to dmat_lst
nc = NCOL(dd)
dmat = makedmat_1D(nc, q = spl_ord)
dmat_lst[[icomp]] = dmat
#dv_lst[[icomp]] = crossprod(dmat)
#make xm0 here
#xm0 = switch(attr(x, "parametric"), linear = cbind(1, x), quadratic = cbind(1, x, x^2))
xm0_icomp = switch(parametric, linear = cbind(1, x), quadratic = cbind(1, x, x^2))
#check more
#if(iadd > 1 |ipr > 1) {
if(icomp > 1){
xm0_icomp = xm0_icomp[, -1]
}
xm0 = cbind(xm0, xm0_icomp)
var_track_param = c(var_track_param, rep(icomp, NCOL(xm0_icomp)))
#ddwm_lst[[icomp]] = xm0_icomp
#print (shp)
awmat = makeamat_1D_param(shp = shp, parametric = parametric, x1=min(x), xn=max(x))
#if(ipr > 1 | iadd > 1){
if(icomp > 1){
awmat = awmat[, -1]
}
awmat_lst[[icomp]] = awmat
}
use_constreg = FALSE
if(NCOL(x) == 2){
use_constreg = TRUE
shp = shp_pr = attr(x, "shape")
#print (shp_pr)
parametric = attr(x, "parametric")
ipr = ipr + 1
x1 = x[, 1]
x2 = x[, 2]
xu1 = unique(x1)
xu2 = unique(x2)
m1 = round(5*n^(1/6))
m2 = round(5*n^(1/6))
x1sc = (x1 - min(x1)) / (max(x1) - min(x1))
x2sc = (x2 - min(x2)) / (max(x2) - min(x2))
if(parametric == "linear"){
if(space == "Q"){
k1 = quantile(x1, probs = seq(0, 1, length = m1), names = FALSE)
k2 = quantile(x2, probs = seq(0, 1, length = m2), names = FALSE)
}
if(space == "E"){
k1 = 0:(m1 - 1) / (m1 - 1) * (max(x1) - min(x1)) + min(x1)
k2 = 0:(m2 - 1) / (m2 - 1) * (max(x2) - min(x2)) + min(x2)
}
}
if(parametric == "warped_plane"){
if(space == "Q"){
k1 = quantile(x1sc, probs = seq(0, 1, length = m1), names = FALSE)
k2 = quantile(x2sc, probs = seq(0, 1, length = m2), names = FALSE)
}
if(space == "E"){
k1 = 0:(m1 - 1) / (m1 - 1) * (max(x1sc) - min(x1sc)) + min(x1sc)
k2 = 0:(m2 - 1) / (m2 - 1) * (max(x2sc) - min(x2sc)) + min(x2sc)
}
}
#if(is.null(edfu)){
edfu = 3*(n^(1/3))
edfu_vec[icomp] = edfu
#}
#new: make delta here; combine it into xm
if(parametric == "linear"){
sp = space
dd_ans = makedelta_wps(x1, x2, space = c(sp, sp), k1 = k1, k2 = k2, decreasing = c(FALSE, FALSE))
}
if(parametric == "warped_plane"){
sp = space
dd_ans = makedelta_wps(x1sc, x2sc, space = c(sp, sp), k1 = k1, k2 = k2, decreasing = c(FALSE, FALSE))
}
dd = dd_ans$delta
if(icomp > 1){
dd = dd[, -1]
}
dd_lst[[icomp]] = dd
var_track = c(var_track, rep(icomp, NCOL(dd)))
#new: need to re-define k1 and k2; some cells might be empty
k1 = dd_ans$k1
k2 = dd_ans$k2
kts = list(k1 = k1, k2 = k2)
kts_lst[[icomp]] = kts
m1 = length(k1)
m2 = length(k2)
use_constreg = TRUE
#new: make amat here; add it to amat_lst
amat = makeamat_nonadd(k1, k2, shp_pr)
#check more
if(icomp > 1){
amat = amat[, -1]
}
amat_lst[[icomp]] = amat
#new: make dmat here; add it to dmat_lst
dmat = makedmat_2D(k1, k2)
#check more
if(icomp > 1){
dmat = dmat[, -1]
}
dmat_lst[[icomp]] = dmat
#dv_lst[[icomp]] = crossprod(dmat)
#make xm0 here
xm0_icomp = switch(parametric, linear = cbind(1, x1, x2), warped_plane = cbind(1, x1sc, x2sc, x1sc*x2sc))
#check more
if(icomp > 1){
xm0_icomp = xm0_icomp[, -1]
}
xm0 = cbind(xm0, xm0_icomp)
var_track_param = c(var_track_param, rep(icomp, NCOL(xm0_icomp)))
#print (shp)
awmat = makeamat_1D_param(shp, parametric = parametric)
if(icomp > 1){
awmat = awmat[, -1]
}
awmat_lst[[icomp]] = awmat
}
#make xm0 here
#xm0 = switch(attr(x, "parametric"), linear = cbind(1, x), quadratic = cbind(1, x, x^2), linear_plane = cbind(1, x1, x2), warped_plane = cbind(1, x1sc, x2sc, x1sc*x2sc))
}
amat = Matrix::bdiag(amat_lst) |> as.matrix()
dmat = Matrix::bdiag(dmat_lst) |> as.matrix()
#dv = Matrix::bdiag(dv_lst) |> as.matrix()
dd = do.call(cbind, dd_lst)
#dd = Matrix(dd, sparse = TRUE)
nr_am = NROW(amat)
#----------------------
#create bvec for qprog
#----------------------
bvec = rep(0, nr_am) #will be different when using constreg
#----------------------------------------------------------------------------
#2.get H1 fit: cone \ L satisfying some shape constraint
#write a new function: fit.alt
#----------------------------------------------------------------------------
nc = nc_noz = NCOL(dd)
if(nz > 0){
dd_1 = dd_lst[[1]]
dd_1 = cbind(zmat, dd_1)
dd_lst[[1]] = dd_1
dm_1 = dmat_lst[[1]]
dm1_zero = matrix(0, nrow = nrow(dm_1), ncol = nz)
dm_1 = cbind(dm1_zero, dm_1)
dmat_lst[[1]] = dm_1
dd = cbind(zmat, dd)
dmat_zero = matrix(0, nrow = nrow(dmat), ncol = nz)
dmat = cbind(dmat_zero, dmat)
amat_zero = matrix(0, nrow = nrow(amat), ncol = nz)
amat = cbind(amat_zero, amat)
}
dv = crossprod(dmat)
#new:
qv0 = crossprod(dd)
#dv = Matrix(dv, sparse = TRUE)
#qv0 = Matrix(qv0, sparse = TRUE)
nc_am = NCOL(amat)
imat = diag(nc_am)
if(GCV){
#temp:
edfu = sum(edfu_vec)
edfu_grid = c(edfu-1, edfu, edfu + (1:2) * 3)
if(is.null(lams)){
lams = sapply(edfu_grid, function(e){uniroot(f = .search_ps, qv0 = qv0, dv = dv, dd = dd, edfu = e, interval = c(1e-10, 2e+2), tol=1e-6)$root})
lams = c(1e-3, rev(lams))
if(arp){
#test!
lams = 2^(2:8)
#lams = 2^(1:7)
lams = lams/2^7/n^(2*spl_ord/(2*spl_ord+1))
# lams = 2^(1:8)
# lams = lams/2^8/n^(3/4)
}
gcvs_rslt = parallel::mclapply(lams, function(e) fit.hypo(p=p, dd=dd, y=y, amat=amat, bvec=bvec,
dv=dv, family=family, arp=arp, ps=e), mc.cores = (8L))
gcvs = sapply(gcvs_rslt, function(rslti) rslti$gcv, simplify = TRUE)
edfs = sapply(gcvs_rslt, function(rslti) rslti$edf, simplify = TRUE)
choice_id = which(gcvs == min(gcvs))
ps = lams[choice_id]
p_optim = p
c(sse1, etahat, ahatc, face, qv, edf, edfs, gcv, gcvs, sighat, edfu_use, covmat, covmat_inv, phi1, mat1) %<-% gcvs_rslt[[choice_id]][1:15]
}
etahat = as.matrix(etahat)
muhat = family$linkinv(etahat)
#only for H1 fit
} else {
#lams = ps
if(is.null(ps)){
#edfu = sum(edfu_vec) + nz
edfu = edfu_vec
if(nz > 0){
edfu[1] = edfu_vec[1] + nz
}
#if(!arp){
if(capl == 1){
#ps = uniroot(f = .search_ps, qv0 = qv0, dv = dv, dd = dd, edfu = edfu, interval = c(1e-10, 2e+2), tol = .Machine$double.eps^0.32)$root
ps = uniroot(f = .search_ps, qv0 = qv0, dv = dv, dd = dd, edfu = edfu, interval = c(1e-10, 2e+2), tol=1e-6)$root
#test!
#if(arp & p >= 1){
#print (ps)
#ps = ps * 0.6 #1/2 (2/3) will be unbiased for p=2 but inflated for p=1, 2/3 is inflated for p=1
#print (ps)
#}
} else if (capl > 1) {
ps = NULL
for(ic in 1:capl){
dd_ic = dd_lst[[ic]]
qv0_ic = crossprod(dd_ic)
dm_ic = dmat_lst[[ic]]
dv_ic = crossprod(dm_ic)
#psi = uniroot(f = .search_ps, qv0 = qv0_ic, dv = dv_ic, dd = dd_ic, edfu = edfu[ic], interval = c(1e-10, 2e+2), tol = .Machine$double.eps^0.32)$root
psi = uniroot(f = .search_ps, qv0 = qv0_ic, dv = dv_ic, dd = dd_ic, edfu = edfu[ic], interval = c(1e-10, 2e+2), tol=1e-6)$root
ps = c(ps, psi)
}
#ps = sapply(1:capl, function(ic)uniroot(f = .search_ps, qv0 = crossprod(dd_lst[[ic]]), dv = crossprod(dmat_lst[[ic]]), dd = dd_lst[[ic]], edfu = edfu[ic], interval = c(1e-10, 2e+2), tol = .Machine$double.eps^0.32)$root)
}
#}else{
#ps = 2/n^(2*spl_ord/(2*spl_ord+1)) #seems working
# ps = 1/n^(2*spl_ord/(2*spl_ord+1)) #a little inflated
#}
}
lams = ps
covmat = covmat_inv = phi = NULL
#new:
if(length(ps) >= 1){
for(ic in 1:capl){
dmat_lst[[ic]] = sqrt(ps[ic]) * dmat_lst[[ic]]
}
#already add zmat in the 1st element of dmat_lst
dmat = Matrix::bdiag(dmat_lst) |> as.matrix()
#recreate dmat
# if(nz > 0){
# dmat_zero = matrix(0, nrow = nrow(dmat), ncol = nz)
# dmat = cbind(dmat_zero, dmat)
# }
dv = crossprod(dmat)
}
if(length(p) == 1){
#arp with user-defined order, or !arp and p=0
#cat('call arp with user-defined order, ps=', ps, '\n')
ansc = fit.hypo(p=p, dd=dd, y=y, amat=amat, bvec=bvec, dv=dv, family=family, ps=ps, arp=arp)
c(sse1, etahat, ahatc, face, qv, edf, edfs, gcv, gcvs, sighat, edfu_use, covmat, covmat_inv, phi1, mat1) %<-% ansc[1:15]
p_optim = p
} else{
#p = 0:2
#new: test p=0 first
ansc = fit.hypo(p=0, dd=dd, y=y, amat=amat, bvec=bvec, dv=dv, family=family, ps=ps, arp=FALSE)
if(ansc$pval.ts > 0.05){
c(sse1, etahat, ahatc, face, qv, edf, edfs, gcv, gcvs, sighat, edfu_use, covmat, covmat_inv, phi1, mat1) %<-% ansc[1:15]
p_optim = 0
}else{
aic_rslt = parallel::mclapply(p[-1], fit.hypo, dd=dd, y=y, amat=amat, bvec=bvec, dv=dv, family=family, ps=ps, arp=arp, mc.cores=(8L))
aics = sapply(aic_rslt, function(rslti) rslti$aic, simplify = TRUE)
#print (aics)
choice_id = which(aics == min(aics))
p_optim = (p[-1])[choice_id]
c(sse1, etahat, ahatc, face, qv, edf, edfs, gcv, gcvs, sighat, edfu_use, covmat, covmat_inv, phi1, mat1) %<-% (aic_rslt[[choice_id]])[1:15]
}
}
muhat = family$linkinv(etahat)
}
#----------------------------------------------------------------------------
#1.get H0 fit: linear space satisfying some shape constraint
#use sparse matrix later
#write a new function: fit.null
#----------------------------------------------------------------------------
wmat = x1m0 = x1m = NULL
if(!use_constreg){
pm0 = xm0 %*% solve(crossprod(xm0), t(xm0))
#x1m0 = dd - pm0 %*% dd
# nc = ncol(dd)
# qr_dd = qr(dd)
# dd_r = qr_dd$rank
# if(dd_r < nc){
# dd_2 = qr.Q(qr_dd, complete = TRUE)[, 1:dd_r]
# rm_id = qr_dd$pivot[(dd_r+1):nc]
# x1m0 = dd_2 - pm0 %*% dd_2
# }else{
x1m0 = dd - pm0 %*% dd
#}
qr_x1m = qr(x1m0)
x1m = qr.Q(qr_x1m, complete = TRUE)[, 1:qr_x1m$rank]
# if(dd_r < nc){
# xm1tb = crossprod(x1m, dd_2)
# } else {
xm1tb = crossprod(x1m, dd)
#}
qr_xm1tb = qr(t(xm1tb))
wmat = qr.Q(qr_xm1tb, complete = TRUE)[, -c(1:qr_xm1tb$rank), drop = FALSE]
# if(dd_r < nc){
# ddwm = dd_2 %*% wmat
# awmat = amat[,-rm_id] %*% wmat
# }else {
ddwm = dd %*% wmat
awmat = amat %*% wmat
#}
} else {
ddwm = xm0
awmat = Matrix::bdiag(awmat_lst) |> as.matrix()
}
if(nz > 0){
#add z before splines
ddwm = cbind(zmat, ddwm)
awmat_zero = matrix(0, nrow = nrow(awmat), ncol = nz)
awmat = cbind(awmat_zero, awmat)
}
ansl = fit.hypo(p=p_optim, dd=ddwm, y=y, amat=awmat, bvec=rep(0, nrow(awmat)), dv=NULL, family=family, ps=0, arp=arp)
sse0 = ansl$dev
etahat0 = ansl$etahat
muhat0 = family$linkinv(etahat0)
ahatl = ansl$ahat
qvl = ansl$qv
#cat(arp, '\n')
#----------------------------------------------------------------------------
#test: H0 vs H1
#----------------------------------------------------------------------------
if(wt.iter){
bval = (sse0 - sse1) / n #sse0 is llh0; sse1 is llh1
} else {
bval = (sse0 - sse1) / sse0
}
#temp
sm=1e-7
#sm = 1e-9
if (bval > sm) {
if (multicore) {
bdist = parallel::mclapply(1:nsim, .compute_bstat, etahat0=etahat0, n=n, sighat=sighat,
dd=dd, ddwm=ddwm, qv=NULL, qvl=NULL, amat=amat, awmat=awmat,
bvec=bvec, imat=imat, dv=dv, lams=ps, w=NULL, arp=arp, p=p_optim, phi=phi1,
family=family, mc.cores=(4L))
} else {
bdist = lapply(1:nsim, .compute_bstat, etahat0=etahat0, n=n, sighat=sighat, dd=dd, ddwm=ddwm, qv=NULL, qvl=NULL,
amat=amat, awmat=awmat, bvec=bvec, imat=imat, dv=dv, lams=ps, w=NULL, arp=arp, p=p_optim, phi=phi1, family=family)
}
bdist = simplify2array(bdist)
pval = sum(bdist > bval) / nsim
} else {
pval = 1
}
#----------------------
#for visualization
#----------------------
etacomps = etacomps0 = vector("list", length = capl)
etahat0_surf = etahat_surf = NULL
muhat0_surf = muhat_surf = NULL
ahatc_noz = round(ahatc, 6) |> as.matrix()
ahatl_noz = round(ahatl, 6) |> as.matrix()
#print (ahatc_noz)
#print (nz)
if(nz > 0){
#print (dim(ahatc_noz))
ahatc_noz = ahatc_noz[-c(1:nz), ,drop=F] #|> as.vector()
ahatl_noz = ahatl_noz[-c(1:nz), ,drop=F] #|> as.vector()
#new:
dd_1 = dd_lst[[1]]
dd_1 = dd_1[, -c(1:nz), drop=F]
dd_lst[[1]] = dd_1
}
for(icomp in 1:capl){
x = X[[icomp]]
if(NCOL(x) == 1){
#print (dim(dd_lst[[icomp]]))
#print (dim(ahatc_noz[var_track == icomp]))
etahat_icomp = dd_lst[[icomp]] %*% ahatc_noz[var_track == icomp,,drop=F]
#print (dim(etahat_icomp))
etacomps[[icomp]] = etahat_icomp
}
if(NCOL(x) == 2){
kts = kts_lst[[icomp]]
k1 = kts$k1
k2 = kts$k2
newd = expand.grid(k1, k2)
newd = as.matrix(newd)
#H0 surface
x1p = newd[,1]
x2p = newd[,2]
if(attr(x, "parametric") == "warped_plane"){
xm0p = cbind(1, x1p, x2p, x1p*x2p)
if(icomp > 1){
xm0p = xm0p[, -1]
}
}
if(attr(x, "parametric") == "linear"){
xm0p = cbind(1, x1p, x2p)
if(icomp > 1){
xm0p = xm0p[, -1]
}
}
#if(nz == 0){
#print (dim(xm0p))
#print (length(ahatl_noz))
#print (icomp)
psurf0 = xm0p %*% ahatl_noz[var_track_param == icomp,,drop=F]
# } else if (nz > 0){
# psurf0 = xm0p %*% ahatl[-((ncol(xm0p) + 1):(ncol(xm0p) + nz))]
# }
etahat0_surf = matrix(psurf0, m1, m2)
muhat0_surf = family$linkinv(etahat0_surf)
#H1 surface
pans = makedelta_wps(newd[,1], newd[,2], k1 = k1, k2 = k2, decreasing = c(FALSE, FALSE))
ddp = pans$delta
if(icomp > 1){
ddp = ddp[, -1]
}
#if(nz == 0){
psurf = ddp %*% ahatc_noz[var_track == icomp,,drop=F]
# } else {
# psurf = ddp %*% ahatc[-((nc_noz + 1):(nc_noz + nz))]
# }
etahat_surf = matrix(psurf, m1, m2)
muhat_surf = family$linkinv(etahat_surf)
etacomps[[icomp]] = etahat_surf
etacomps0[[icomp]] = etahat0_surf
}
}
rslt = list(pval = pval, bval = bval, knots = kts, k1=k1, k2=k2, bmat = dd, wmat = wmat, dmat = dmat, ps = ps,
xm0 = xm0, x1m = x1m, amat = amat, awmat = awmat, face = face, etahat = etahat, etahat0 = etahat0,
etahat0_surf = etahat0_surf, etahat_surf = etahat_surf, muhat0_surf = muhat0_surf, muhat_surf = muhat_surf,
sighat = sighat, edf = edf, edfu = edfu_use, lams = lams, gcvs = gcvs, edfs = edfs, ahatl = ahatl, ahatc = ahatc,
phi = phi1, covmat = covmat, covmat_inv = covmat_inv, etacomps = etacomps, p_optim = p_optim, kts_lst = kts_lst,
var_track = var_track, var_track_param = var_track_param, etacomps0 = etacomps0)
if(nz >= 1){
#assume y is iid with common sig2
if(!wt.iter){
#should work for ar(p)?
if(!arp || arp & p_optim == 0){
covmat0 = sighat^2 * mat1 %*% t(mat1)
} else {
#print (sig2hat_z)
#covmat0 = sig2hat_z * mat1 %*% t(mat1)
covmat0 = mat1 %*% t(mat1) #seems working with unscaled covariance
#covmat0 = sighat^2 * mat1 %*% t(mat1)
}
} else {
wt = wt.fun(y, etahat, n, weights = rep(1, n), fml = family$family)
covmat0 = mat1 %*% diag(wt) %*% t(mat1)
}
covmat = covmat0[(1):(nz), (1):(nz), drop=FALSE]
sez = sqrt(diag(covmat))
zcoefs = ahatc[(1):(nz)]
tz = zcoefs / sez
cpar = 1.2
#test more!
if(!wt.iter){
if ((n - cpar * edf) <= 0) {
pz = 2*(1 - pt(abs(tz), edf))
} else {
#why not pnorm?
pz = 2*(1 - pt(abs(tz), n - cpar * edf))
}
} else {
#why not pnorm?
pz = 2*(1 - pnorm(abs(tz)))
}
rslt$sez = sez
rslt$pz = pz
rslt$tz = tz
rslt$zcoefs = zcoefs
} else {rslt$sez = NULL; rslt$pz = NULL; rslt$tz = NULL; rslt$zcoefs = NULL}
return(rslt)
}
Try the cgam package in your browser
Any scripts or data that you put into this service are public.
cgam documentation built on June 8, 2025, 1:45 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions testpar.fit testpar ddb.penal_dexp ddb.penal db.penal varest print.anova.cgam anova.cgam cgam.pvz cgam.pv getbin getvars makebin Ord fwt_a fgr_a fwt fgr ddfun dfun pfun polr_getedf predict_polr dev_fun print.summary.cgam.polr summary.cgam.polr cgam.polr.fit cgam.polr cpfun sameside intri plotpersp.trisplp plotpersp.trispl s.conc.conc s.conv.conv makedelta_tri tri_getedf trispl.fit irls plot.shapeselect CharToShape ShapeToChar ConstrALL ConstrGA make_form in.or.out shapes best.fit ShapeSelect fitted.cgam.polr fitted.trispl fitted.wps fitted.cgam coef.cgam.polr coef.trispl coef.wps coef.cgam makeamat_wps make_pen makedelta_wps s.decr.decr s.decr.incr s.incr.decr s.incr.incr wps.fit wps_getedf plotpersp.wpsp plotpersp.wps plotpersp.cgamp plotpersp.cgam plotpersp_control plotpersp makedelta_tri predict.trispl predict.wps pred_del predict.cgam print.summary.wps print.summary.cgam summary.wps summary.cgam incconcave incconvex concave convex mondecr monincr make_delta_add makedelta umbrella.fun umbrella tree.fun tree s s.decr.conc s.decr.conv s.incr.conc s.incr.conv s.conc s.conv s.decr s.incr decr.conc incr.conc decr.conv incr.conv conc conv decr incr get_varname CicFamily CicFamily cgam.fit bmat.fun amat.fun cgam
Documented in best.fit cgam conc conv decr decr.conc decr.conv incr incr.conc incr.conv in.or.out Ord plotpersp plotpersp_control predict.cgam s s.conc s.conc.conc s.conv s.conv.conv s.decr s.decr.conc s.decr.conv s.decr.decr s.decr.incr shapes ShapeSelect s.incr s.incr.conc s.incr.conv s.incr.decr s.incr.incr testpar tree umbrella
######
#cgam#
######
cgam <- function(formula, cic = FALSE, nsim = 100, family = gaussian, cpar = 1.5, data = NULL, weights = NULL, sc_x = FALSE, sc_y = FALSE, pnt = TRUE, pen = 0, var.est = NULL, gcv = FALSE, pvf = TRUE)
{
cl <- match.call()
if (is.character(family))
family <- get(family, mode = "function", envir = parent.frame())
if (is.function(family))
family <- family()
if (is.null(family$family))
stop("'family' not recognized!")
if (family$family == "ordered") {
rslt <- cgam.polr(formula, data = data, weights = weights, family = family, nsim = nsim, cpar = cpar)
rslt$call <- cl
return (rslt)
} else {
labels <- NULL
mf <- match.call(expand.dots = FALSE)
m <- match(c("formula", "data"), names(mf), 0L)
mf <- mf[c(1L, m)]
mf[[1L]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
ynm <- names(mf)[1]
mt <- attr(mf, "terms")
y <- model.response(mf, "any")
if (family$family == "binomial") {
#if (class(y) == "factor") {
if(inherits(y, "factor")){
y <- ifelse(y == levels(y)[1], 0, 1)
}
}
#additive
shapes1_add <- NULL; shapes2_add <- NULL; shapes_add <- NULL
xmat_add <- NULL; xnms_add <- NULL
tr <- NULL; pl <- NULL; umb <- NULL
tree.delta <- NULL; umbrella.delta <- NULL
tid1 <- NULL; tid2 <- NULL; tpos2 <- 0
uid1 <- NULL; uid2 <- NULL; upos2 <- 0
nums_add <- NULL; ks_add <- list(); sps_add <- NULL; xid_add <- 1
zmat <- NULL; zid <- NULL; zid0 <- NULL; zid1 <- NULL; zid2 <- NULL; znms <- NULL; is_param <- NULL; is_fac <- NULL; vals <- NULL; st <- 1; ed <- 1
ztb <- list(); iztb <- 1
iadd <- 0
varlist_add <- NULL
xmat0_add <- NULL
#warp
warp.delta <- NULL
nums_wp <- NULL; ks_wp <- list(); ks_wps <- list(); sps_wp <- NULL
xmat_wp <- NULL; x1_wp <- NULL; x2_wp <- NULL; xnms_wp <- NULL; nks0_wp <- NULL; ks0_wp <- NULL; dc <- NULL
x1_wps <- NULL; x2_wps <- NULL; dcss <- list()
#zmat <- NULL; zid <- NULL; zid1 <- NULL; zid2 <- NULL; znms <- NULL; is_fac <- NULL; is_param <- NULL; vals <- NULL; st <- 1; ed <- 1
iwps <- 0
varlist_wps <- NULL
#tri
tri.delta <- NULL
nums_tri <- NULL; ks_tri <- list(); ks_tris <- list(); nks_tris <- list(); sps_tri <- NULL
xmat_tri <- NULL; x1_tri <- NULL; x2_tri <- NULL; xnms_tri <- NULL; nks0_tri <- NULL; ks0_tri <- NULL; cvs <- NULL
x1_tris <- NULL; x2_tris <- NULL; cvss <- list()
#zmat <- NULL; zid <- NULL; zid1 <- NULL; zid2 <- NULL; znms <- NULL; is_fac <- NULL; is_param <- NULL; vals <- NULL; st <- 1; ed <- 1
#print (dim(mf))
itri <- 0
#print (head(mf))
for (i in 2:ncol(mf)) {
#additive
#print (attributes(mf[,i])$class)
if (!is.null(attributes(mf[,i])$categ)) {
if (is.numeric(attributes(mf[,i])$shape) & (attributes(mf[,i])$categ == "additive")) {
labels <- c(labels, "additive")
shapes1_add <- c(shapes1_add, attributes(mf[,i])$shape)
xmat_add <- cbind(xmat_add, mf[,i])
xnms_add <- c(xnms_add, attributes(mf[,i])$nm)
nums_add <- c(nums_add, attributes(mf[,i])$numknots)
sps_add <- c(sps_add, attributes(mf[,i])$space)
ks_add[[xid_add]] <- attributes(mf[,i])$knots
xid_add <- xid_add + 1
}
if (is.character(attributes(mf[,i])$shape) & (attributes(mf[,i])$categ == "additive")) {
labels <- c(labels, "additive")
shapes2_add <- c(shapes2_add, attributes(mf[,i])$shape)
if (attributes(mf[,i])$shape == "tree") {
pl <- c(pl, attributes(mf[,i])$pl)
treei <- tree.fun(mf[,i], attributes(mf[,i])$pl)
tree.delta <- rbind(tree.delta, treei)
tpos1 <- tpos2 + 1
tpos2 <- tpos2 + nrow(treei)
tid1 <- c(tid1, tpos1)
tid2 <- c(tid2, tpos2)
tr <- cbind(tr, mf[,i])
}
if (attributes(mf[,i])$shape == "umbrella") {
umbi <- umbrella.fun(mf[,i])
umbrella.delta <- rbind(umbrella.delta, umbi)
upos1 <- upos2 + 1
upos2 <- upos2 + nrow(umbi)
uid1 <- c(uid1, upos1)
uid2 <- c(uid2, upos2)
umb <- cbind(umb, mf[,i])
}
}
#warp
#if (is.character(attributes(mf[, i])$shape) & (attributes(mf[,i])$categ == "warp")) {
#test more! shape is not pairs like c(1,1)
if ((attributes(mf[,i])$categ == "warp")) {
iwps <- iwps + 1
labels <- c(labels, rep(paste("warp", iwps, sep = "_"), 2))
sps_wp <- attributes(mf[, i])$space
dcs <- attributes(mf[, i])$decreasing
dcss[[iwps]] <- dcs
ks0_wp <- attributes(mf[, i])$knots
nks0_wp <- attributes(mf[, i])$numknots
x1_wp <- (mf[, i])[, 1]
x1_wps <- cbind(x1_wps, x1_wp)
x2_wp <- (mf[, i])[, 2]
x2_wps <- cbind(x2_wps, x2_wp)
xmat_wp <- cbind(xmat_wp, mf[, i])
xnms_wp <- c(xnms_wp, attributes(mf[, i])$name)
#print (xnms_wp)
#print (dim(xmat_wp))
#print (nks0_wp)
#print (ks0_wp)
#print (sps_wp)
ans_warp <- makedelta_wps(x1t = x1_wp, x2t = x2_wp, m1_0 = nks0_wp[1], m2_0 = nks0_wp[2], k1 = ks0_wp$k1, k2 = ks0_wp$k2, space = sps_wp, decreasing = dcs)
warp.delta0 <- ans_warp$delta
k1 <- ans_warp$k1
k2 <- ans_warp$k2
#print (k1)
#print (k2)
ks_wp[[1]] <- k1
ks_wp[[2]] <- k2
ks_wps[[iwps]] <- ks_wp
if (iwps > 1) {
warp.delta0 <- warp.delta0[,-1]
}
varlist_wps <- c(varlist_wps, 1:ncol(warp.delta0)*0 + iwps)
warp.delta <- cbind(warp.delta, warp.delta0)
#save(warp.delta, file='warpd.Rda')
#print (dim(warp.delta))
#print (ks_wps)
}
#tri
if (is.character(attributes(mf[, i])$shape) & (attributes(mf[,i])$categ == "tri")) {
itri <- itri + 1
labels <- c(labels, rep(paste("tri", itri, sep = "_"), 2))
sps_tri <- attributes(mf[, i])$space
cvs <- attributes(mf[, i])$cvs
cvss[[itri]] <- cvs
ks0_tri <- attributes(mf[, i])$knots
nks0_tri <- attributes(mf[, i])$numknots
ks_tris[[itri]] <- ks0_tri
nks_tris[[itri]] <- nks0_tri
x1_tri <- (mf[, i])[, 1]
x1_tris <- cbind(x1_tris, x1_tri)
x2_tri <- (mf[, i])[, 2]
x2_tris <- cbind(x2_tris, x2_tri)
#xmat_tri <- cbind(x1_tri, x2_tri)
xmat_tri <- cbind(xmat_tri, mf[, i])
xnms_tri <- c(xnms_tri, attributes(mf[, i])$name)
}
#print (class((mf[, i])))
}
if (is.null(attributes(mf[,i])$shape)) {
if (!is.null(names(mf)[i])) {
znms <- c(znms, names(mf)[i])
}
if (!is.matrix(mf[,i])) {
zid <- c(zid, i)
is_param <- c(is_param, TRUE)
if (is.factor(mf[,i])) {
is_fac <- c(is_fac, TRUE)
ch_char <- suppressWarnings(is.na(as.numeric(levels(mf[, i]))))
if (any(ch_char)) {
vals <- c(vals, unique(levels(mf[, i]))[-1])
} else {
vals <- c(vals, as.numeric(levels(mf[, i]))[-1])
}
nlvs <- length(attributes(mf[,i])$levels)
ed <- st + nlvs - 2
zid1 <- c(zid1, st)
zid2 <- c(zid2, ed)
st <- st + nlvs - 1
zmat0 <- model.matrix(~ mf[, i])[, -1, drop = FALSE]
zmat <- cbind(zmat, zmat0)
ztb[[iztb]] <- mf[,i]
iztb <- iztb + 1
} else {
is_fac <- c(is_fac, FALSE)
zmat <- cbind(zmat, mf[, i])
ztb[[iztb]] <- mf[,i]
iztb <- iztb + 1
ed <- st
zid1 <- c(zid1, st)
zid2 <- c(zid2, ed)
st <- st + 1
vals <- c(vals, "")
}
} else {
is_param <- c(is_param, FALSE)
is_fac <- c(is_fac, FALSE)
zmat0 <- mf[, i]
mat_cols <- ncol(zmat0)
mat_rm <- NULL
#rm_num <- 0
for (irm in 1:mat_cols) {
if (all(round(diff(zmat0[, irm]), 8) == 0)) {
mat_rm <- c(mat_rm, irm)
}
}
if (!is.null(mat_rm)) {
zmat0 <- zmat0[, -mat_rm, drop = FALSE]
#rm_num <- rm_num + length(mat_rm)
}
zmat <- cbind(zmat, zmat0)
ztb[[iztb]] <- mf[,i]
iztb <- iztb + 1
vals <- c(vals, 1)
zid <- c(zid, i)
nlvs <- ncol(zmat0) + 1
ed <- st + nlvs - 2
zid1 <- c(zid1, st)
zid2 <- c(zid2, ed)
st <- st + nlvs - 1
}
}
}
dimnames(zmat)[[2]] <- NULL
if (family$family == "binomial" | family$family == "poisson" | family$family == "Gamma") {
wt.iter = TRUE
} else {wt.iter = FALSE}
#attr(xmat, "shape") <- shapes1
#print (labels)
if (any(labels == "additive") | !is.null(zmat)) {
xmat0_add <- xmat_add; shapes0_add <- shapes1_add; nums0_add <- nums_add; ks0_add <- ks_add; sps0_add <- sps_add; xnms0_add <- xnms_add; idx_s <- NULL; idx <- NULL
if (any(shapes1_add == 17)) {
kshapes <- length(shapes1_add)
obs <- 1:kshapes
idx_s <- obs[which(shapes1_add == 17)]; idx <- obs[which(shapes1_add != 17)]
xmat0_add[ ,1:length(idx_s)] <- xmat_add[ ,idx_s]
shapes0_add[1:length(idx_s)] <- shapes1_add[idx_s]
nums0_add[1:length(idx_s)] <- nums_add[idx_s]
sps0_add[1:length(idx_s)] <- sps_add[idx_s]
ks0_add[1:length(idx_s)] <- ks_add[idx_s]
xnms0_add[1:length(idx_s)] <- xnms_add[idx_s]
if (length(idx) > 0) {
xmat0_add[ ,(1 + length(idx_s)):kshapes] <- xmat_add[ ,idx]
shapes0_add[(1 + length(idx_s)):kshapes] <- shapes1_add[idx]
nums0_add[(1 + length(idx_s)):kshapes] <- nums_add[idx]
sps0_add[(1 + length(idx_s)):kshapes] <- sps_add[idx]
ks0_add[(1 + length(idx_s)):kshapes] <- ks_add[idx]
xnms0_add[(1 +length(idx_s)):kshapes] <- xnms_add[idx]
}
#xmat <- xmat0; nums <- nums0; ks <- ks0; sps <- sps0; xnms <- xnms0
}
shapes_add <- c(shapes1_add, shapes2_add)
}
#print (labels)
xnms <- c(xnms_wp, xnms_add, xnms_tri)
xmat <- cbind(xmat_wp, xmat_add, xmat_tri)
colnames(xmat) <- xnms
#boolz <- is.null(labels) & !is.null(zmat)
if (all(labels == "additive")) {
if (is.null(shapes_add)) {
nsim <- 0
}
ans <- cgam.fit(y = y, xmat = xmat0_add, zmat = zmat, shapes = shapes0_add, numknots = nums0_add, knots = ks0_add, space = sps0_add, nsim = nsim, family = family, cpar = cpar, wt.iter = wt.iter, umbrella.delta = umbrella.delta, tree.delta = tree.delta, weights = weights, zid = zid, zid1 = zid1, zid2 = zid2, sc_x = sc_x, sc_y = sc_y, idx_s = idx_s, idx = idx, var.est = var.est, data = data)
if (!is.null(uid1) & !is.null(uid2)) {
uid1 <- uid1 + ans$d0 + ans$capm
uid2 <- uid2 + ans$d0 + ans$capm
}
if (!is.null(tid1) & !is.null(tid2)) {
tid1 <- tid1 + ans$d0 + ans$capm + ans$capu
tid2 <- tid2 + ans$d0 + ans$capm + ans$capu
}
#new:
knots_add <- ans$knots
numknots_add <- ans$numknots
#new:
if (length(knots_add) > 0) {
names(knots_add) <- xnms_add
}
rslt <- list(etahat = ans$etahat, muhat = ans$muhat, vcoefs = ans$vcoefs,
xcoefs = ans$xcoefs, zcoefs = ans$zcoefs, ucoefs = ans$ucoefs,
tcoefs = ans$tcoefs, coefs = ans$coefs, cic = ans$cic, d0 = ans$d0,
edf0 = ans$edf0, etacomps = ans$etacomps, y = y,
xmat_add = xmat_add, zmat = zmat, ztb = ztb, tr = tr, umb = umb,
tree.delta = tree.delta, umbrella.delta = umbrella.delta, bigmat = ans$bigmat,
shapes = shapes_add, shapesx = shapes1_add, shapesx0 = shapes0_add,
prior.w = weights, wt = ans$wt, wt.iter = ans$wt.iter,
family = family, SSE0 = ans$sse0, SSE1 = ans$sse1,
pvals.beta = ans$pvals.beta, se.beta = ans$se.beta,
df.null = ans$df.null, df = ans$df, df.residual = ans$df.residual,
edf = ans$df_obs, null.deviance = ans$dev.null, deviance = ans$dev,
tms = mt, capm = ans$capm, capms = ans$capms, capk = ans$capk, capt = ans$capt,
capu = ans$capu, xid1 = ans$xid1, xid2 = ans$xid2, tid1 = tid1, tid2 = tid2,
uid1 = uid1, uid2 = uid2, zid = zid, vals = vals, zid1 = zid1, zid2 = zid2,
nsim = nsim, xnms_add = xnms_add, xnms = xnms, ynm = ynm, znms = znms,
is_param = is_param, is_fac = is_fac, knots = knots_add, numknots = numknots_add,
sps = sps_add, ms = ans$ms, cpar = ans$cpar, pl = pl, idx_s = idx_s, idx = idx,
xmat0 = ans$xmat2, knots0 = ans$knots2, numknots0 = ans$numknots2, sps0 = ans$sps2,
ms0 = ans$ms2, phihat = ans$phihat, pvs = ans$pvs,
s.edf = ans$s.edf, bstats = ans$bstats, pvsz = ans$pvsz,
z.edf = ans$z.edf, fstats = ans$fstats, vh = ans$vh, kts.var = ans$kts.var,
sc = ans$sc, sc_y = sc_y)
rslt$call <- cl
class(rslt) <- "cgam"
} else if (any(grepl("warp", labels, fixed = TRUE)) & !any(grepl("tri", labels, fixed = TRUE))) {
nprs <- sum(grepl("warp", labels, fixed = TRUE)) / 2
delta_add <- NULL
ms <- NULL
np_add <- 0
pb <- 0
knotsuse_add <- NULL
if (any(labels == "additive")) {
#delta_add <- NULL
if (length(shapes0_add) > 0) {
ans_add <- make_delta_add(xmat = xmat0_add, shapes = shapes0_add, numknots = nums0_add, knots = ks0_add, space = sps0_add)
delta_add <- ans_add$bigmat
ms <- ans_add$mslst
#np_add: smooth only, conv and conc
np_add <- ans_add$np
pb <- nrow(delta_add)
varlist_add <- ans_add$varlist
knotsuse_add <- ans_add$knotsuse
}
}
delta_ut <- NULL
if (!is.null(umbrella.delta)) {
delta_add <- rbind(delta_add, umbrella.delta)
delta_ut <- rbind(delta_ut, umbrella.delta)
}
if (!is.null(tree.delta)) {
delta_add <- rbind(delta_add, tree.delta)
delta_ut <- rbind(delta_ut, tree.delta)
}
ans <- wps.fit(x1t = x1_wps, x2t = x2_wps, y = y, zmat = zmat, xmat_add = xmat_add, delta_add = delta_add, delta_ut = delta_ut, varlist_add = varlist_add, shapes_add = shapes_add, np_add = np_add, w = weights, pen = pen, pnt = pnt, cpar = cpar, decrs = dcss, delta = warp.delta, kts = ks_wps, wt.iter = wt.iter, family = family, cic = cic, nsim = nsim, nprs = nprs, idx_s = idx_s, idx = idx, gcv = gcv, pvf = pvf)
rslt <- list(ks_wps = ans$kts, muhat = ans$muhat, SSE1 = ans$sse1, SSE0 = ans$sse0, edfc = ans$edf, edf0 = ans$edf0, delta = ans$delta, y = y, zmat = ans$zmat, ztb = ztb, zmat_0 = ans$zmat_0, xmat_wp = xmat_wp, xmat_add = xmat_add, xmat0_add = xmat0_add, xmat = xmat, shapes = shapes_add, coefs = ans$coefs, zcoefs = ans$zcoefs, pvals.beta = ans$pz,pval=ans$pval,bval=ans$bval, se.beta = ans$sez, gcv = ans$gcv, xnms_wp = xnms_wp, xnms_add = xnms_add, xnms = xnms, xid_add = xid_add, znms = znms, zid = zid, vals = vals, zid1 = zid1, zid2 = zid2, ynm = ynm, decrs = dcss, tms = mt, mf = mf, is_param = is_param, is_fac = is_fac, d0 = ans$d0, pb = pb, pen = ans$pen, cpar = ans$cpar, wt.iter = wt.iter, cic = ans$cic, family = family, nprs_wps = nprs, varlist_wps = varlist_wps, coef_wp = ans$coef_wp, varlist_add = varlist_add, np_add = np_add, coef_add = ans$coef_add, coef_ut = ans$coef_ut, etacomps = ans$etacomps, amat = ans$amat, dmat = ans$dmat, prior.w = weights, sig2hat = ans$sig2hat, ms = ms, knotsuse_add = knotsuse_add, vmat = ans$vmat)
class(rslt) <- "wps"
if (!is.null(delta_add)) {
class(rslt) <- c("wps", "cgam")
if (min(which(labels == "additive")) < min(which(grepl("warp", labels, fixed = TRUE)))) {
class(rslt) <- c("cgam", "wps")
}
}
} else if (any(grepl("tri", labels, fixed = TRUE))) {
nprs <- sum(grepl("tri", labels, fixed = TRUE)) / 2
nprs_wps <- sum(grepl("warp", labels, fixed = TRUE)) / 2
amat_wp <- NULL
dmat_wp <- NULL
delta_add <- NULL
knotsuse_add <- NULL
ms <- NULL
np_add <- 0
pb <- 0
if (any(labels == "additive")) {
if (length(shapes0_add) > 0) {
ans_add <- make_delta_add(xmat = xmat0_add, shapes = shapes0_add, numknots = nums0_add, knots = ks0_add, space = sps0_add)
delta_add <- ans_add$bigmat
np_add <- ans_add$np
pb <- nrow(delta_add)
varlist_add <- ans_add$varlist
ms <- ans_add$mslst
knotsuse_add <- ans_add$knotsuse
}
}
if (!is.null(umbrella.delta)) {
delta_add <- rbind(delta_add, umbrella.delta)
}
if (!is.null(tree.delta)) {
delta_add <- rbind(delta_add, tree.delta)
}
if (any(grepl("warp", labels, fixed = TRUE))) {
ans_wps <- makeamat_wps(ks_wps, nprs_wps)
amat_wp <- ans_wps$amat
dmat_wp <- ans_wps$dmat
valist_wps <- ans_wps$valist_wps
}
ans <- trispl.fit(x1t = x1_tris, x2t = x2_tris, y = y, zmat = zmat, xmat_add = xmat_add, delta_add = delta_add, varlist_add = varlist_add, shapes_add = shapes_add, np_add = np_add, xmat_wp = xmat_wp, delta_wp = warp.delta, varlist_wps = varlist_wps, amat_wp = amat_wp, dmat_wp = dmat_wp, w = weights, lambda = pen, pnt = TRUE, cpar = cpar, cvss = cvss, delta = tri.delta, kts = ks_tris, nkts = nks_tris, wt.iter = wt.iter, family = family, nsim = nsim, nprs = nprs)
rslt <- list(muhat = ans$muhat, etahat = ans$etahat, trimat = ans$trimat, y = y, zmat = ans$zmat, ztb = ztb, capk = ans$capk, xmat_tri = xmat_tri, xmat_add = xmat_add, xmat0_add = xmat0_add, xmat_wp = xmat_wp, xmat = xmat, shapes = shapes_add, coefs = ans$thhat, zcoefs = ans$zcoefs, se.beta = ans$se.beta, pvals.beta = ans$pvals.beta, gcv = ans$gcv, edf = ans$edf, edf0 = ans$edf0, cic = ans$cic, sse0 = ans$sse0, sse1 = ans$sse1, family = family, nprs = nprs, nprs_wps = nprs_wps, varlist_wps = varlist_wps, varlist_add = varlist_add, varlist_tri = ans$varlist, xnms_tri = xnms_tri, xnms_add = xnms_add, xnms_wp = xnms_wp, xnms = xnms, znms = znms, zid = zid, vals = vals, zid1 = zid1, zid2 = zid2, ynm = ynm, decrs = dcss, cvss = cvss, tms = mt, is_param = is_param, is_fac = is_fac, d0 = ans$d0, pen = ans$pen, cpar = cpar, wt.iter = wt.iter, np_add = np_add, pb = pb, coef_add = ans$coef_add, coef_tri = ans$coef_tri, coef_wp = ans$coef_wp, etacomps = ans$etacomps, ks_wps = ks_wps, knots_lst = ans$knots_lst, m12_lst = ans$m12_lst, trimat_lst = ans$trimat_lst, bmat_lst = ans$bmat_lst, capk_lst = ans$capk_lst, prior.w = weights, dmatc = ans$dmatc, amatc = ans$amatc, pmatc = ans$pmatc, sig2hat = ans$sig2hat, knotsuse_add = knotsuse_add, ms = ms)
class(rslt) <- "trispl"
if (!is.null(delta_add) & is.null(warp.delta)) {
if (labels[1] == "additive") {
class(rslt) <- c("cgam", "trispl")
} else {class(rslt) <- c("trispl", "cgam")}
}
if (!is.null(warp.delta) & is.null(delta_add)) {
#if (labels[1] == "warp") {
if (grepl("warp", labels[1], fixed = TRUE)) {
class(rslt) <- c("wps", "trispl")
} else {class(rslt) <- c("trispl", "wps")}
}
if (!is.null(warp.delta) & !is.null(delta_add)) {
if (labels[1] == "additive") {
class(rslt) <- c("cgam", "trispl", "wps")
} else if (grepl("warp", labels[1], fixed = TRUE)) {
class(rslt) <- c( "wps", "trispl", "cgam")
} else {class(rslt) <- c("trispl", "cgam", "wps")}
}
}
}
rslt$call <- cl
rslt$labels <- labels
return (rslt)
}
###############
#amat function#
###############
amat.fun <- function(x)
{
obs <- 1:length(x)
amat <- NULL
xu <- unique(x)
nx <- sort(xu)
hd <- head(nx, 1)
tl <- nx
while (length(tl) > 1) {
hd <- head(tl, 1)
tl <- tl[-1]
paired <- 0
for (i in 1:length(tl)) {
a1 <- 1:length(x)*0
if (hd * tl[i] > 0) {
if (hd < 0) {
if (tl[i] > hd) {
a1[min(obs[which(x == hd)])] <- -1; a1[min(obs[which(x == tl[i])])] <- 1
} else {
a1[min(obs[which(x == hd)])] <- 1; a1[min(obs[which(x == tl[i])])] <- -1
}
}
if (hd > 0) {
if (tl[i] < hd) {
a1[min(obs[which(x == hd)])] <- -1; a1[min(obs[which(x == tl[i])])] <- 1
} else {
a1[min(obs[which(x == hd)])] <- 1; a1[min(obs[which(x == tl[i])])] <- -1
}
}
#if (!all(a1 == 0) & paired == 0 ) {amat <- rbind(amat, a1); paired <- 1}
}
if (hd * tl[i] == 0) {
if (hd == 0) {
#if (tl[i] > 0) {
a1[min(obs[which(x == hd)])] <- 1; a1[min(obs[which(x == tl[i])])] <- -1
#}
} else {
a1[min(obs[which(x == hd)])] <- -1; a1[min(obs[which(x == tl[i])])] <- 1
}
}
if (!all(a1 == 0) & paired == 0 ) {amat <- rbind(amat, a1); paired <- 1}
}
}
dimnames(amat) <- NULL
amat
}
###############
#bmat function#
###############
bmat.fun <- function(x)
{
obs <- 1:length(x)
bmat <- NULL
hd <- head(x, 1)
tl <- x
j <- 0
while (length(tl) > 1) {
hd <- head(tl, 1)
tl <- tl[-1]
paired <- 0
j <- j + 1
for (i in 1:length(tl)) {
b1 <- 1:length(x)*0
if (hd == tl[i]) {b1[j] <- -1; b1[j + i] <- 1}
if (!all(b1 == 0) & paired == 0 ) {bmat <- rbind(bmat, b1); paired <- 1}
}
}
dimnames(bmat) <- NULL
bmat
}
##########
#cgam.fit#
##########
cgam.fit <- function(y, xmat, zmat, shapes, numknots, knots, space, nsim, family = gaussian(), cpar = 1.2, wt.iter = FALSE, umbrella.delta = NULL, tree.delta = NULL, weights = NULL, zid = zid, zid1 = zid1, zid2 = zid2, sc_x = FALSE, sc_y = FALSE, idx_s = NULL, idx = NULL, var.est = NULL, data = NULL) {
cicfamily <- CicFamily(family)
llh.fun <- cicfamily$llh.fun
#new: use log link in gamma
linkfun <- cicfamily$linkfun
etahat.fun <- cicfamily$etahat.fun
gr.fun <- cicfamily$gr.fun
wt.fun <- cicfamily$wt.fun
zvec.fun <- cicfamily$zvec.fun
muhat.fun <- cicfamily$muhat.fun
ysim.fun <- cicfamily$ysim.fun
deriv.fun <- cicfamily$deriv.fun
dev.fun <- cicfamily$dev.fun
n <- length(y)
sm <- 1e-7
#sm <- 1e-5
capl <- length(xmat) / n
if (capl < 1) {capl <- 0}
if (round(capl, 8) != round(capl, 1)) {stop ("Incompatible dimensions for xmat!")}
#new:
if (capl > 0 & sc_x) {
for (i in 1:capl) {xmat[,i] <- (xmat[,i] - min(xmat[,i])) / (max(xmat[,i]) - min(xmat[,i]))}
#for (i in 1:capl) {xmat[,i] <- (xmat[,i] - mean(xmat[,i])) / sd(xmat[,i])}
#for (i in 1:capl) {xmat[,i] <- xmat[,i] / sd(xmat[,i])}
}
#new:
sc <- 1
if (sc_y) {
sc <- sd(y)
y <- y / sc
}
capk <- length(zmat) / n
if (capk < 1) {capk <- 0}
if (round(capk, 8) != round(capk, 1)) {stop ("Incompatible dimensions for zmat!")}
#new:
capls <- sum(shapes == 17)
####################################################
#get basis functions for the constrained components#
####################################################
delta <- NULL
varlist <- NULL
xid1 <- NULL; xid2 <- NULL; xpos2 <- 0
knotsuse <- list(); numknotsuse <- NULL
mslst <- list()
#new:
capm <- 0
capms <- 0
if (capl - capls > 0) {
del1_ans <- makedelta(xmat[, 1], shapes[1], numknots[1], knots[[1]], space = space[1])
del1 <- del1_ans$amat
knotsuse[[1]] <- del1_ans$knots
mslst[[1]] <- del1_ans$ms
if(shapes[1] >= 9 & shapes[1] <= 17) {
numknotsuse <- c(numknotsuse, length(del1_ans$knots))
} else {
numknotsuse <- c(numknotsuse, nrow(del1))
}
m1 <- length(del1) / n
#new code: record the number of columns of del1 if shapes0[1] == 17:
if (shapes[1] == 17) {capms <- capms + m1}
var1 <- 1:m1*0 + 1
xpos1 <- xpos2 + 1
xpos2 <- xpos2 + m1
xid1 <- c(xid1, xpos1)
xid2 <- c(xid2, xpos2)
if (capl == 1) {
delta <- del1
varlist <- var1
} else {
for (i in 2:capl) {
#new code:
del2_ans <- makedelta(xmat[,i], shapes[i], numknots[i], knots[[i]], space = space[i])
del2 <- del2_ans$amat
knotsuse[[i]] <- del2_ans$knots
mslst[[i]] <- del2_ans$ms
if(shapes[i] >= 9 & shapes[i] <= 17) {
numknotsuse <- c(numknotsuse, length(del2_ans$knots))
} else {
numknotsuse <- c(numknotsuse, nrow(del2))
}
#numknotsuse <- c(numknotsuse, length(del2_ans$knots))
m2 <- length(del2) / n
#new code: record the number of columns of del2 if shapes0[i] == 17:
if (shapes[i] == 17) {capms <- capms + m2}
xpos1 <- xpos2 + 1
xpos2 <- xpos2 + m2
xid1 <- c(xid1, xpos1)
xid2 <- c(xid2, xpos2)
delta <- rbind(del1, del2)
varlist <- 1:(m1 + m2)*0
varlist[1:m1] <- var1
varlist[(m1 + 1):(m1 + m2)] <- (1:m2)*0 + i
var1 <- varlist
m1 <- m1 + m2
del1 <- delta
}
}
if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0 & capk > 0) {
bigmat <- rbind(1:n*0 + 1, t(zmat), t(xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13]), delta)
np <- 1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0 & capk == 0) {
bigmat <- rbind(1:n*0 + 1, t(xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13]), delta)
np <- 1 + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0 & capk > 0) {
bigmat <- rbind(1:n*0 + 1, t(zmat), delta)
np <- 1 + capk + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0 & capk == 0) {
bigmat <- rbind(1:n*0 + 1, delta)
np <- 1 + capms
} else {
print ("error in capk, shapes!")
}
#new:
capm <- length(delta) / n - capms
} else {
if (capk + capls > 0) {
#new:
if (capls < 1 & capk > 0) {
bigmat <- rbind(1:n*0 + 1, t(zmat))
np <- 1 + capk
} else if (capls > 0) {
delta <- NULL; varlist <- NULL
del1_ans <- makedelta(xmat[,1], 17, numknots[1], knots[[1]], space = space[1])
del1 <- del1_ans$amat
knotsuse[[1]] <- del1_ans$knots
mslst[[1]] <- del1_ans$ms
numknotsuse <- c(numknotsuse, length(del1_ans$knots))
m1 <- length(del1) / n
var1 <- 1:m1*0 + 1
xpos1 <- xpos2 + 1
xpos2 <- xpos2 + m1
xid1 <- c(xid1, xpos1)
xid2 <- c(xid2, xpos2)
if (capls == 1) {
delta <- del1
varlist <- var1
} else {
for (i in 2:capls) {
del2_ans <- makedelta(xmat[,i], 17, numknots[i], knots[[i]], space = space[i])
del2 <- del2_ans$amat
knotsuse[[i]] <- del2_ans$knots
mslst[[i]] <- del2_ans$ms
numknotsuse <- c(numknotsuse, length(del2_ans$knots))
m2 <- length(del2) / n
xpos1 <- xpos2 + 1
xpos2 <- xpos2 + m2
xid1 <- c(xid1, xpos1)
xid2 <- c(xid2, xpos2)
delta <- rbind(del1, del2)
varlist <- 1:(m1 + m2)*0
varlist[1:m1] <- var1
varlist[(m1 + 1):(m1 + m2)] <- (1:m2)*0 + i
var1 <- varlist
m1 <- m1 + m2
del1 <- delta
}
}
if (capk < 1){
bigmat <- rbind(1:n*0 + 1, delta)
capms <- length(delta) / n
np <- 1 + capms
} else {
bigmat <- rbind(1:n*0 + 1, t(zmat), delta)
capms <- length(delta) / n
np <- 1 + capk + capms
}
}
} else {bigmat <- matrix(1:n*0 + 1, nrow = 1); capm <- 0; capms <- 0; np <- 1}
}
if (!is.null(umbrella.delta)) {
bigmat <- rbind(bigmat, umbrella.delta)
capu <- length(umbrella.delta) / n
} else {capu <- 0}
if (!is.null(tree.delta)) {
bigmat <- rbind(bigmat, tree.delta)
capt <- length(tree.delta) / n
} else {capt <- 0}
if (!is.null(umbrella.delta) | !is.null(tree.delta))
delta_ut <- rbind(umbrella.delta, tree.delta)
if (capl + capk + capu + capt > 0) {
# if (capl + capu + capt > 0) {
#new:
if (capl - capls + capu + capt > 0) {
#new:initialize cvec
cvec <- NULL
#new: initialize face
face <- NULL
if (wt.iter) {
etahat <- etahat.fun(n, y, fml = family$family)
gr <- gr.fun(y, etahat, weights, fml = family$family)
wt <- wt.fun(y, etahat, n, weights, fml = family$family)
cvec <- wt * etahat - gr
} else {wt <- wt.fun(y, etahat, n, weights, fml = family$family)}
zvec <- zvec.fun(cvec, wt, y, fml = family$family)
# gmat <- t(bigmat %*% sqrt(diag(wt)))
#new: avoid memory allocation error
gmat <- t(bigmat)
for (i in 1:n) {gmat[i,] <- bigmat[,i] * sqrt(wt[i])}
dsend <- gmat[, (np + 1):(np + capm + capu + capt), drop = FALSE]
zsend <- gmat[, 1:np, drop = FALSE]
#ans <- coneB(zvec, t(dsend), zsend)
ans <- coneB(zvec, dsend, zsend)
face <- ans$face
etahat <- t(bigmat) %*% ans$coefs
#new: for monotinic variance estimation
vh <- NULL
kts.var <- NULL
if (!is.null(var.est)) {
#x.var <- var.est
#test more:
if (!is.null(data)) {
nms <- names(data)
nm <- attributes(var.est)$nm
if (nm %in% nms) {
x.var <- data[[nm]]
attributes(x.var) <- attributes(var.est)
}
} else {x.var <- var.est}
db.exp <- attributes(x.var)$db.exp
kts.var <- attributes(x.var)$var.knots
shape.var <- attributes(x.var)$shape
iter <- 0
diff.var <- 100
oldeta <- etahat
evec0 <- y - etahat
#bigwt <- 10*max(evec0)
bigwt <- 1000
while(diff.var > 1e-8 & iter < 10) {
iter <- iter + 1
evec <- y - etahat
fit.var <- varest(evec, x.var, shape=shape.var, var.knots=kts.var, db.exp=db.exp)
v1 <- fit.var$vhat
wt0 <- 1/v1
wt0[wt0 > bigwt] <- bigwt
wt <- wt.fun(y, etahat, n, weights = wt0, fml = family$family)
zvec <- zvec.fun(cvec, wt, y, fml = family$family)
gmat <- t(bigmat)
for (i in 1:n) {gmat[i,] <- bigmat[,i] * sqrt(wt[i])}
dsend <- gmat[, (np + 1):(np + capm + capu + capt), drop = FALSE]
zsend <- gmat[, 1:np, drop = FALSE]
ans <- coneB(zvec, dsend, zsend)
etahat <- t(bigmat) %*% ans$coefs
diff.var <- mean((etahat - oldeta)^2)
oldeta <- etahat
}
kts.var <- fit.var$var.knots
vh <- v1
}
if (wt.iter) {
muhat <- muhat.fun(etahat, fml = family$family)
diff <- 1
if (family$family == "binomial") {
mdiff <- abs(max(muhat) - 1) > sm
} else {mdiff <- TRUE}
nrep <- 0
##########
#iterate!#
##########
while (diff > sm & mdiff & nrep < n^2){
oldmu <- muhat
nrep <- nrep + 1
gr <- gr.fun(y, etahat, weights, fml = family$family)
wt <- wt.fun(y, etahat, n, weights, fml = family$family)
cvec <- wt * etahat - gr
#zvec <- cvec / sqrt(wt)
zvec <- zvec.fun(cvec, wt, y, fml = family$family)
# gmat <- t(bigmat %*% sqrt(diag(wt)))
gmat <- t(bigmat)
for (i in 1:n) {gmat[i,] <- bigmat[,i] * sqrt(wt[i])}
dsend <- gmat[, (np + 1):(np + capm + capu + capt), drop = FALSE]
zsend <- gmat[, 1:np, drop = FALSE]
#ans <- coneB(zvec, t(dsend), zsend)
ans <- coneB(zvec, dsend, zsend, face = face)
etahat <- t(bigmat) %*% ans$coefs
muhat <- muhat.fun(etahat, fml = family$family)
diff <- mean((muhat - oldmu)^2)
mdiff <- abs(max(muhat) - 1)
if (family$family == "binomial") {
mdiff <- abs(max(muhat) - 1) > sm
} else {mdiff <- TRUE}
}
}
yhat <- ans$yhat
coefskeep <- ans$coefs
########################
#if capk >= 0, we have:#
########################
zcoefs <- coefskeep[1:(capk + 1)]
######################
#we will always have:#
######################
vcoefs <- coefskeep[1:np]
#######################
#if capm > 0, we have:#
#######################
xcoefs <- NULL
#if (capm > 0) {
# xcoefs <- coefskeep[(np + 1):(np + capm)]
#}
#new:
if (capl > 0) {
xcoefs <- coefskeep[(np - capms + 1):(np + capm)]
}
#######################
#if capu > 0, we have:#
#######################
ucoefs <- NULL
if (capu > 0) {
ucoefs <- coefskeep[(np + 1 + capm):(np + capm + capu)]
}
#######################
#if capt > 0, we have:#
#######################
tcoefs <- NULL
if (capt > 0) {
tcoefs <- coefskeep[(np + 1 + capm + capu):(np + capm + capu + capt)]
}
#########################################################
#if we have at least one constrained predictor, we have:#
#########################################################
thvecs <- NULL
if (capl > 0) {
#new code:
dcoefs <- coefskeep[(np - capms + 1):(np + capm)]
#dcoefs <- coefskeep[(np + 1):(np + capm)]
#####################################################
#thvecs is f(x), where x has one of the eight shapes#
#####################################################
thvecs <- matrix(nrow = capl, ncol = n)
ncon <- 1
for (i in 1:capl) {
thvecs[i,] <- t(delta[varlist == i,]) %*% dcoefs[varlist == i]
#new:
#if (shapes[i] > 2 & shapes[i] < 5) {
if (shapes[i] > 2 & shapes[i] < 5 | shapes[i] > 10 & shapes[i] < 13) {
ncon <- ncon + 1
#thvecs[i,] <- thvecs[i,] + zcoefs[ncon] * xmat[,i]
thvecs[i,] <- thvecs[i,] + vcoefs[capk + ncon] * xmat[,i]
}
}
}
#new:order thvecs back
#print (idx_s)
#print (idx)
#if (!is.null(idx_s)) {
if (length(idx_s) > 0) {
thvecs0 <- thvecs
thvecs0[idx_s,] <- thvecs[1:length(idx_s), ]
#if (!is.null(idx)) {
if (length(idx) > 0) {
thvecs0[idx,] <- thvecs[(1+length(idx_s)):capl, ]
}
thvecs <- thvecs0
}
thvecs_ut <- NULL
if (capu + capt > 0) {
thvecs_ut <- t(delta_ut) %*% coefskeep[(np + 1 + capm):(np + capm + capu + capt)]
}
if (!is.null(thvecs_ut)) {
thvecs <- rbind(thvecs, t(thvecs_ut))
}
#new: problem when not gaussian
if (sc_y) {
y <- y*sc
etahat <- etahat*sc
for (i in 1:nrow(thvecs)) {
thvecs[i,] <- thvecs[i,] * sc
}
}
etakeep <- etahat
muhatkeep <- muhat.fun(etakeep, fml = family$family)
wtkeep <- wt
df_obs <- sum(abs(coefskeep) > 0)
#llh <- llh.fun(y, muhat, etahat, n, weights, fml = family$family)
if (family$family == "Gamma") {
if ((n - cpar * df_obs) <= 0) {
phihat <- sum(((y - muhatkeep) / muhatkeep)^2) / df_obs
} else {
phihat <- sum(((y - muhatkeep) / muhatkeep)^2) / (n - cpar * df_obs)
}
} else {phihat <- NULL}
#print (phihat)
llh <- llh.fun(y, muhatkeep, etakeep, phihat, n, weights, fml = family$family)
if (family$family == "poisson") {
mu0 <- mean(y)
eta0 <- log(mu0)
} else {mu0 <- NULL}
#new: get p-values for smooth components
pvs <- NULL
s.edf <- NULL
bstats <- NULL
if (is.numeric(shapes)) {
#changed to include shape==17
#if (all(shapes >= 9 & shapes <= 17)) {
if (any(shapes >= 9 & shapes <= 17)) {
for (i in 1:capl) {
if (shapes[i] >= 1 & shapes[i] <= 17 ){
ansi <- cgam.pv(y=y, xmat=xmat, zmat=zmat, shapes=shapes, delta=delta, np=np, capms=capms, numknotsuse=numknotsuse, varlist=varlist, family=family, weights=weights, test_id=i, nsims=100)
pvi <- ansi$pv
edfi <- 1.5*sum(xcoefs[varlist == i] > 1e-8)
bstati <- ansi$bstat
pvs <- c(pvs, pvi)
s.edf <- c(s.edf, edfi)
bstats <- c(bstats, bstati)
}
#print (pvs)
}
}
}
#new: get p-values for categorical predictors, not for each level
pvsz <- NULL
z.edf <- NULL
fstats <- NULL
#temp: use cgam.pvz only when there's smooth component
if (is.numeric(shapes)) {
#changed to include shape==17
if (all(shapes >= 9 & shapes <= 17)) {
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
prior.w <- weights
if (capk > 0) {
sse1 <- sum(prior.w * (y - muhatkeep)^2)
ansi <- cgam.pvz(y=y, bigmat=bigmat, df_obs=df_obs, sse1=sse1, np=np, zid=zid, zid1=zid1, zid2=zid2, muhat = muhatkeep, etahat = etakeep, coefskeep = coefskeep, wt.iter=wt.iter, family=family, weights=weights)
pvsz <- ansi$pvs
z.edf <- ansi$edfs
fstats <- ansi$fstats
}
}
}
} else if (capk + capls > 0 & capl - capls + capt + capu == 0) {
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
prior.w <- weights
vmat <- t(bigmat[1:np, , drop = FALSE])
if (wt.iter) {
nrep <- 0
muhat <- mean(y) + 1:n*0
etahat <- linkfun(muhat)
diff <- 1
if (family$family == "binomial") {
mdiff <- abs(max(muhat) - 1) > sm
} else {mdiff <- TRUE}
while (diff > sm & mdiff & nrep < n^2) {
nrep <- nrep + 1
oldmu <- muhat
zhat <- etahat + (y - muhat) * deriv.fun(muhat, fml = family$family)
#w <- diag(as.vector(prior.w / deriv.fun(muhat)))
#w <- diag(as.vector(prior.w * (deriv.fun(muhat, fml = family$family))^(-1)))
#b <- solve(t(vmat) %*% w %*% vmat) %*% t(vmat) %*% w %*% zhat
w <- as.vector(prior.w * (deriv.fun(muhat, fml = family$family))^(-1))
tvmat <- t(vmat)
for (i in 1:n) {tvmat[,i] <- tvmat[,i] * w[i]}
#print (tvmat)
b <- solve(tvmat %*% vmat) %*% tvmat %*% zhat
etahat <- vmat %*% b
muhat <- muhat.fun(etahat, fml = family$family)
diff <- mean((muhat - oldmu)^2)
mdiff <- abs(max(muhat) - 1)
if (family$family == "binomial") {
mdiff <- abs(max(muhat) - 1) > sm
} else {mdiff <- TRUE}
}
zcoefs <- b[1:(capk + 1)]
#se.beta <- sqrt(diag(solve(t(vmat) %*% w %*% vmat)))[1:(capk + 1)]
se.beta <- sqrt(diag(solve(tvmat %*% vmat)))[1:(capk + 1)]
zstat <- zcoefs / se.beta
pvals.beta <- 1 - pchisq(zstat^2, df = 1)
#new: gamma only
if (family$family == "Gamma") {
phihat <- sum(((y - muhatkeep) / muhatkeep)^2) / (n - np)
} else {phihat <- NULL}
} else {
#w <- diag(prior.w)
#b <- solve(t(vmat) %*% w %*% vmat) %*% t(vmat) %*% w %*% y
w <- prior.w
tvmat <- t(vmat)
for (i in 1:n) {tvmat[,i] <- tvmat[,i] * w[i]}
b <- solve(tvmat %*% vmat) %*% tvmat %*% y
etahat <- vmat %*% b
muhat <- muhat.fun(etahat, fml = family$family)
sdhat2 <- sum(prior.w * (y - muhat)^2) / (n - np)
zcoefs <- b[1:(capk + 1)]
se.beta <- sqrt(diag(solve(tvmat %*% vmat) * sdhat2))[1:(capk + 1)]
tstat <- zcoefs / se.beta
pvals.beta <- (1 - pt(abs(tstat), df = n - np)) * 2
#new: for var estimation
vh <- NULL
kts.var <- NULL
if (!is.null(var.est)) {
x.var <- var.est
db.exp <- attributes(x.var)$db.exp
kts.var <- attributes(x.var)$var.knots
shape.var <- attributes(x.var)$shape
iter <- 0
diff.var <- 100
oldeta <- etahat
evec0 <- y - oldeta
#bigwt <- 10*max(evec0)
bigwt <- 1000
while(diff.var > 1e-8 & iter < 10) {
iter <- iter + 1
evec <- y - etahat
fit.var <- varest(evec, x.var, shape=shape.var, var.knots=kts.var, db.exp=db.exp)
v1 <- fit.var$vhat
#w <- 1/v1
w0 <- 1/v1
w0[w0 > bigwt] <- bigwt
w <- w0
tvmat <- t(vmat)
for (i in 1:n) {tvmat[,i] <- tvmat[,i] * w[i]}
b <- solve(tvmat %*% vmat) %*% tvmat %*% y
etahat <- vmat %*% b
diff.var <- mean((etahat - oldeta)^2)
oldeta <- etahat
#print (diff.var)
}
kts.var <- fit.var$var.knots
vh <- v1
}
}
#add thvecs if capls > 0:
thvecs <- NULL
if (capls > 0) {
thvecs <- matrix(nrow = capls, ncol = n)
dcoefs <- b[(capk + 2):np]
for (i in 1:capls) {
thvecs[i,] <- t(delta[varlist == i,]) %*% dcoefs[varlist == i]
}
}
#new:
if (sc_y) {
y <- y*sc
etahat <- etahat*sc
muhat <- muhat.fun(etahat, fml = family$family)
for (i in 1:nrow(thvecs)) {
thvecs[i,] = thvecs[i,] * sc
}
}
llh <- llh.fun(y, muhat, etahat, phihat, n, weights, fml = family$family)
df_obs <- np
dfmean <- np
rslt <- new.env()
rslt$family <- family
rslt$wt.iter <- wt.iter
#rslt$wt <- diag(w)
rslt$wt <- w
rslt$bigmat <- bigmat
rslt$etahat <- etahat
rslt$muhat <- muhat
rslt$d0 <- np
rslt$capm <- 0
rslt$capms <- capms
rslt$capk <- capk
rslt$capu <- capu
rslt$capt <- capt
rslt$xid1 <- xid1 + np - capms
rslt$xid2 <- xid2 + np - capms
rslt$dfmean <- dfmean
rslt$edf0 <- dfmean
#rslt$llh <- llh
#if (nsim > 0) {
if (family$family == "binomial") {
nobs <- sum(prior.w)
} else {nobs <- n}
if ((nobs - np - cpar * (dfmean - np)) <= 0) {
rslt$cic <- llh + log(1 + 2 * dfmean / (dfmean - np))
} else {
#new:
if (n<=200){cpar=1.5}
rslt$cic <- llh + log(1 + 2 * dfmean / (nobs - np - cpar * (dfmean - np)))
}
#rslt$cic <- llh + log(1 + 2 * dfmean / (n - np - 1.5 * (dfmean - np)))
#}
rslt$zcoefs <- zcoefs
rslt$coefs <- b
rslt$vcoefs <- b
rslt$xcoefs <- b[(capk + 2):np]
rslt$se.beta <- se.beta
rslt$pvals.beta <- pvals.beta
rslt$dev <- dev.fun(y, muhat, etahat, weights, fml = family$family)$dev
rslt$dev.null <- dev.fun(y, muhat, etahat, weights, fml = family$family)$dev.null
rslt$df <- n - np
rslt$df.null <- n - 1
#rslt$df.residual <- n - np - 1.5 * (df_obs - np)
rslt$df.residual <- n - cpar * df_obs
rslt$vhat <- etahat
rslt$vmat <- vmat
rslt$etacomps <- thvecs
rslt$knots <- knotsuse
rslt$numknots <- numknotsuse
rslt$ms <- mslst
#new: used for predict when there are only shape == 17 x's
#rslt$xmat <- xmat
rslt$xmat2 <- xmat
rslt$knots2 <- knotsuse
rslt$numknots2 <- numknotsuse
rslt$ms2 <- mslst
rslt$vh <- vh
rslt$kts.var <- kts.var
return (rslt)
}
##########
#get cic#
##########
if (capl - capls + capu + capt > 0 & nsim > 0) {
dfs <- 1:nsim
#new: initialize face
face <- NULL
for (isim in 1:nsim) {
#set.seed(123)
ysim <- ysim.fun(n, mu0, fml = family$family)
if (wt.iter) {
etahat <- etahat.fun(n, ysim, fml = family$family)
gr <- gr.fun(ysim, etahat, weights, fml = family$family)
wt <- wt.fun(ysim, etahat, n, weights, fml = family$family)
cvec <- wt * etahat - gr
} else {wt <- wt.fun(ysim, etahat, n, weights, fml = family$family)}
zvec <- zvec.fun(cvec, wt, ysim, fml = family$family)
# gmat <- t(bigmat %*% sqrt(diag(wt)))
gmat <- t(bigmat)
for (i in 1:n) {gmat[i,] <- bigmat[,i] * sqrt(wt[i])}
dsend <- gmat[, (np + 1):(np + capm + capu + capt), drop = FALSE]
zsend <- gmat[, 1:np, drop = FALSE]
#ans <- try(coneB(zvec, t(dsend), zsend))
ans <- try(coneB(zvec, dsend, zsend))
face <- ans$face
#if (class(ans) == "try-error") next
if(inherits(ans, "try-error")) next
if (wt.iter) {
etahat <- t(bigmat) %*% ans$coefs
muhat <- muhat.fun(etahat, fml = family$family)
diff <- 1
if (family$family == "binomial") {
mdiff <- abs(max(muhat) - 1) > sm
} else {mdiff <- TRUE}
##########
#iterate!#
##########
nrep <- 0
while (diff > sm & nrep < n^2 & mdiff > sm) {
nrep <- nrep + 1
oldmu <- muhat
gr <- gr.fun(ysim, etahat, weights, fml = family$family)
wt <- wt.fun(ysim, etahat, n, weights, fml = family$family)
cvec <- wt * etahat - gr
#zvec <- cvec / sqrt(wt)
zvec <- zvec.fun(cvec, wt, y, fml = family$family)
# gmat <- t(bigmat %*% sqrt(diag(wt)))
gmat <- t(bigmat)
for (i in 1:n) {gmat[i,] <- bigmat[,i] * sqrt(wt[i])}
dsend <- gmat[, (np + 1):(np + capm + capu + capt), drop = FALSE]
zsend <- gmat[, 1:np, drop = FALSE]
#ans <- try(coneB(zvec, t(dsend), zsend))
ans <- try(coneB(zvec, dsend, zsend, face=face))
#if (class(ans) == "try-error") next
if(inherits(ans, "try-error")) next
etahat <- t(bigmat) %*% ans$coefs
muhat <- muhat.fun(etahat, fml = family$family)
diff <- mean((muhat - oldmu)^2)
if (family$family == "binomial") {
mdiff <- abs(max(muhat) - 1) > sm
} else {mdiff <- TRUE}
}
}
dfs[isim] <- sum(abs(ans$coefs) > 0)
}
dfmean <- mean(dfs)
#print (dfmean)
} else if (capl - capls + capu + capt > 0 & nsim == 0) {
dfmean <- NULL
}
###################################################
#if the user does not give any predictor, we have:#
###################################################
} else {
rslt <- new.env()
rslt$family <- family
rslt$wt.iter <- wt.iter
rslt$muhat <- 1:n*0 + mean(y)
rslt$etahat <- linkfun(muhat)
rslt$dfmean <- 1
print ("No predictor is provided")
return (rslt)
}
if (capl - capls + capu + capt > 0) {
#new:
#exclude the case we only have z or unrestricted smooth
xid1 <- xid1 + np - capms
xid2 <- xid2 + np - capms
#xid1 <- xid1 + np
#xid2 <- xid2 + np
rslt <- new.env()
rslt$phihat <- phihat
rslt$family <- family
rslt$wt.iter <- wt.iter
rslt$wt <- wtkeep
rslt$bigmat <- bigmat
rslt$etahat <- etakeep
rslt$muhat <- muhatkeep
rslt$d0 <- np
rslt$capm <- capm
rslt$capms <- capms
rslt$capk <- capk
rslt$capu <- capu
rslt$capt <- capt
rslt$xid1 <- xid1
rslt$xid2 <- xid2
rslt$coefs <- coefskeep
rslt$vcoefs <- vcoefs
rslt$xcoefs <- xcoefs
rslt$zcoefs <- zcoefs
rslt$ucoefs <- ucoefs
rslt$tcoefs <- tcoefs
rslt$dfmean <- dfmean
#rslt$llh <- llh
#if (nsim > 0) {
if (!is.null(dfmean)) {
#check!
#new: use dfmean - np if n - np - 1.5 * (dfmean - np) < 0
if ((n - np - cpar * (dfmean - np)) <= 0) {
rslt$cic <- llh + log(1 + 2 * dfmean / (dfmean - np))
} else {
#new:
if (n<=200){cpar=1.5}
rslt$cic <- llh + log(1 + 2 * dfmean / (n - np - cpar * (dfmean - np)))
}
} else {rslt$cic <- NULL}
rslt$edf0 <- dfmean
rslt$etacomps <- thvecs
vmat <- t(bigmat[1:np, , drop = FALSE])
rslt$vmat <- vmat
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
prior.w <- weights
#w <- diag(as.vector(prior.w / deriv.fun(muhatkeep, fml = family$family)))
w <- as.vector(prior.w / deriv.fun(muhatkeep, fml = family$family))
###############################################
#the case capk = 0 and capk >= 0 are combined:#
###############################################
#debugged: vhat -> muhat.fun(vhat)
vhat <- vmat %*% vcoefs
muvhat <- muhat.fun(vhat, fml = family$family)
#debugged: yhat -> muhatkeep
sse1 <- sum(prior.w * (y - muhatkeep)^2)
sse0 <- sum(prior.w * (y - muvhat)^2)
#new:
#if ((n - np - cpar * df_obs) <= 0) {
if ((n - cpar * df_obs) <= 0) {
#sdhat2 <- sse1 / (df_obs - np)
sdhat2 <- sse1 / df_obs
} else {
#sdhat2 <- sse1 / (n - np - 1.5 * (df_obs - np))
#sdhat2 <- sse1 / (n - np - cpar * df_obs)
sdhat2 <- sse1 / (n - cpar * df_obs)
}
#debugged: vmat -> vmat and duse
#new: coefskeep include zcoefs; bigmat include vmat
pmat <- vmat
capbm <- length(bigmat) / n
bigmat_nv <- bigmat[(np + 1):capbm, , drop = FALSE]
coefs_nv <- coefskeep[(np + 1):capbm]
duse <- coefs_nv > 1e-8
if (sum(duse) >= 1) {
pmat <- cbind(vmat, t(bigmat_nv[duse, , drop = FALSE]))
}
if (wt.iter) {
#new:
tpmat <- t(pmat)
for (i in 1:n) {tpmat[,i] <- tpmat[,i] * w[i]}
se2 <- solve(tpmat %*% pmat)
} else {
# se2 <- solve(t(pmat) %*% diag(prior.w) %*% pmat) * sdhat2
tpmat <- t(pmat)
for (i in 1:n) {tpmat[,i] <- tpmat[,i] * prior.w[i]}
se2 <- solve(tpmat %*% pmat) * sdhat2
}
se.beta <- 1:(capk + 1)*0
tstat <- 1:(capk + 1)*0
pvals.beta <- 1:(capk + 1)*0
rslt$zcoefs <- zcoefs
for (i in 1:(capk + 1)) {
se.beta[i] <- sqrt(se2[i,i])
tstat[i] <- zcoefs[i] / se.beta[i]
#new code: n - np - 1.5 * (df_obs - np) must be positive
#if ((n - np - cpar * df_obs) <= 0) {
if ((n - cpar * df_obs) <= 0) {
pvals.beta[i] <- 2 * (1 - pt(abs(tstat[i]), df_obs))
warning ('Effective degrees of freedom is close to the number of observations! Inference about parametric covariates is not reliable!')
} else {
#pvals.beta[i] <- 2 * (1 - pt(abs(tstat[i]), n - np - cpar * df_obs))
pvals.beta[i] <- 2 * (1 - pt(abs(tstat[i]), n - cpar * df_obs))
}
}
rslt$se.beta <- se.beta
rslt$pvals.beta <- pvals.beta
rslt$sse1 <- sse1
rslt$sse0 <- sse0
rslt$dev <- dev.fun(y, muhatkeep, etakeep, weights, fml = family$family)$dev
rslt$dev.null <- dev.fun(y, muhatkeep, etakeep, weights, fml = family$family)$dev.null
rslt$df <- n - np
rslt$df.null <- n - 1
#rslt$df.residual <- n - np - cpar * df_obs
rslt$df.residual <- n - cpar * df_obs
rslt$df_obs <- df_obs
rslt$vhat <- vhat
if (length(knotsuse) == 0) {
knotsuse <- NULL
}
#new: order back
knotsuse2 <- knotsuse
numknotsuse2 <- numknotsuse
mslst2 <- mslst
xmat2 <- xmat
#if (!is.null(idx_s)) {
if (length(idx_s) > 0) {
knotsuse0 <- knotsuse
numknotsuse0 <- numknotsuse
mslst0 <- mslst
knotsuse0[idx_s] <- knotsuse[1:length(idx_s)]
numknotsuse0[idx_s] <- numknotsuse[1:length(idx_s)]
mslst0[idx_s] <- mslst[1:length(idx_s)]
#if (!is.null(idx)) {
if (length(idx) > 0) {
knotsuse0[idx] <- knotsuse[(1+length(idx_s)):capl]
numknotsuse0[idx] <- numknotsuse[(1+length(idx_s)):capl]
mslst0[idx] <- mslst[(1+length(idx_s)):capl]
}
knotsuse <- knotsuse0
numknotsuse <- numknotsuse0
mslst <- mslst0
}
# the following has shape = 17 at the beginning: knots2 etc
rslt$knots2 <- knotsuse2
rslt$numknots2 <- numknotsuse2
rslt$ms2 <- mslst2
rslt$xmat2 <- xmat2
rslt$knots <- knotsuse
rslt$numknots <- numknotsuse
rslt$ms <- mslst
rslt$capms <- capms
rslt$cpar <- cpar
rslt$pvs <- pvs
rslt$s.edf <- s.edf
rslt$bstats <- bstats
#new:
rslt$pvsz <- pvsz
rslt$z.edf <- z.edf
rslt$fstats <- fstats
rslt$vh <- vh
rslt$kts.var <- kts.var
rslt$sc <- sc
#rslt$sdhat2 <- sdhat2
return (rslt)
}
}
###########
#CicFamily#
###########
CicFamily <- function(object,...)UseMethod("CicFamily")
CicFamily <- function(object) {
#temp:
#if (object$family == "ordered") {
# object$family = "gaussian"
#}
#new:
if (object$family == "gaussian") {
linkfun <- function (mu) mu
}
if (object$family == "poisson") {
linkfun <- function (mu) log(mu)
}
if (object$family == "binomial") {
linkfun <- binomial()$linkfun
}
if (object$family == "Gamma") {
#linkfun <- function (mu) log(mu)
linkfun <- Gamma(link="log")$linkfun
}
llh.fun <- function(y, muhat = NULL, etahat = NULL, phihat = NULL, n = NULL, weights = NULL, fml = object$family){
sm <- 1e-7
#sm <- 1e-5
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
w <- weights
#new: avoid Inf
if (fml == "poisson") {
llh <- 2 * sum(w[w!=0] * (muhat[w!=0] - y[w!=0] * etahat[w!=0])) / n
}
if (fml == "binomial") {
llh <- 0
if (all(0 <= y) & all(y <= 1)) {
for (i in 1:n) {
if (muhat[i] > 0 & muhat[i] < 1) {
llh <- llh + w[i] * (y[i] * log(muhat[i]) + (1 - y[i]) * log(1 - muhat[i]))
}
}
llh <- (-2/n) * llh
} else {
stop ("y values must be 0 <= y <= 1!")
}
}
if (fml == "gaussian") {
if (all(w == 1)) {
llh <- log(sum((y - etahat)^2))
} else {
llh <- log(sum(w[w!=0] * (y[w!=0] - etahat[w!=0])^2)) - sum(log(w[w!=0])) / n
}
}
if (fml == "Gamma") {
vuhat <- 1 / phihat
#print (vuhat)
#llh <- 2 * sum(w[w!=0] * (etahat[w!=0] + y[w!=0] * exp(-etahat[w!=0]))) / n
llh <- 2 / n * (vuhat * sum(w[w!=0] * (etahat[w!=0] + y[w!=0] * exp(-etahat[w!=0]))) + n * (log(gamma(vuhat)) - vuhat * log(vuhat)) - (vuhat-1) * sum(log(y)))
#print (llh)
}
llh
}
etahat.fun <- function(n, y, fml = object$family){
if (fml == "poisson") {
etahat <- 1:n*0 + log(mean(y))
}
if (fml == "binomial") {
etahat <- 1:n*0
}
if (fml == "Gamma") {
etahat <- 1:n*0 + log(mean(y))
}
etahat
}
gr.fun <- function(y, etahat = NULL, weights = NULL, fml = object$family){
n <- length(y)
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
w <- weights
if (fml == "poisson") {
gr <- w * (exp(etahat) - y)
}
if (fml == "binomial") {
if (all(etahat == 0)) {
gr <- w * (1/2 - y)
} else {
gr <- 1:n*0
for (i in 1:n) {
if (etahat[i] > 100) {
gr[i] <- w[i] * (1 - y[i])
} else {gr[i] <- w[i] * (exp(etahat[i]) / (1 + exp(etahat[i])) - y[i])}
}
}
}
if (fml == "Gamma") {
gr <- w * (1 - y * exp(-etahat))
}
gr
}
wt.fun <- function(y, etahat = NULL, n = NULL, weights = NULL, fml = object$family){
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
w <- weights
if (fml == "poisson") {
wt <- w * exp(etahat)
}
if (fml == "binomial") {
if (all(etahat == 0)){
#wt <- 1:n*0 + 1/4
wt <- w * (1:n*0 + 1/4)
} else {
wt <- 1:n*0
for (i in 1:n) {
if (etahat[i] > 100) {
wt[i] <- 0
} else {
wt[i] <- w[i] * exp(etahat[i]) / ((1 + exp(etahat[i]))^2)
}
}
}
}
if (fml == "gaussian") {
wt <- w # (1:n*0 + 1) / w
}
if (fml == "Gamma") {
wt <- w * y * exp(-etahat)
}
wt <- as.vector(wt)
wt
}
zvec.fun <- function(cvec = NULL, wt = NULL, y, sm = 1e-7, fml = object$family) {
n <- length(y)
if (fml == "gaussian") {
#zvec <- y
zvec <- wt^(1/2) * y
}
if (fml == "poisson") {
#zvec <- cvec / wt
zvec <- cvec / sqrt(wt)
}
if (fml == "binomial") {
zvec = 1:n*0
zvec[wt == 0] <- 1 / sm
zvec[wt > 0] <- cvec[wt > 0] / sqrt(wt[wt > 0])
}
if (fml == "Gamma") {
zvec <- cvec / sqrt(wt)
}
zvec
}
muhat.fun <- function(etahat, wt = NULL, fml = object$family){
n <- length(etahat)
if (fml == "poisson") {
muhat <- exp(etahat)
}
if (fml == "binomial") {
muhat <- 1:n*0
id1 = which(etahat > 100)
id2 = which(etahat <= 100)
muhat[id1] = 1
muhat[id2] = exp(etahat[id2]) / (1 + exp(etahat[id2]))
#muhat[wt == 0] <- 1
#for (i in 1:n) {
# if (etahat[i] > 100) {
# muhat[i] <- 1
# } else {
# muhat[i] <- exp(etahat[i]) / (1 + exp(etahat[i]))
# }
#}
}
if (fml == "gaussian") {
muhat <- etahat
}
if (fml == "Gamma") {
muhat <- exp(etahat)
}
muhat
}
# ysim.fun <- function(n, mu0 = NULL, fml = object$family, shp0 = NULL) {
# if (fml == "binomial") {
# ysim <- 1:n*0
# ysim[runif(n) < .5] <- 1
# }
# if (fml == "poisson") {
# if (!is.null(mu0)) {
# ysim <- rpois(n, mu0)
# }
# }
# if (fml == "gaussian") {
# ysim <- rnorm(n)
# }
# if (fml == "Gamma") {
# ysim <- rgamma(n, shape=1)
# }
# ysim
# }
ysim.fun <- function(n, mu0 = NULL, fml = object$family, shp0 = NULL, sd = NULL, phi = NULL) {
if (fml == "binomial") {
if(is.null(mu0)){
ysim <- 1:n*0
ysim[runif(n) < .5] <- 1
} else {
ysim <- rbinom(n, size = 1, prob = mu0)
}
}
if (fml == "poisson") {
if (!is.null(mu0)) {
ysim <- rpois(n, mu0)
}
}
if (fml == "gaussian") {
if(!is.null(phi)){
ysim <- mu0 + arima.sim(n = n, list(ar = phi), sd = sd)
}else{
if(is.null(mu0)){
ysim <- rnorm(n)
} else {
ysim <- mu0 + rnorm(n)
}
}
}
if (fml == "Gamma") {
ysim <- rgamma(n, shape=1)
}
ysim
}
deriv.fun <- function(muhat, fml = object$family) {
if (fml == "binomial") {
deriv <- 1 / (muhat * (1 - muhat))
}
if (fml == "poisson") {
deriv <- 1 / muhat
}
if (fml == "gaussian") {
deriv <- 1
}
if (fml == "Gamma") {
deriv <- 1 / muhat
}
deriv
}
dev.fun <- function(y, muhat, etahat, weights, fml = object$family){
n <- length(y)
sm <- 1e-7
#sm <- 1e-5
if (is.null(weights)) {
weights <- 1:n*0 + 1
}
w <- weights
vmat <- matrix(1:n*0 + 1, ncol = 1)
if (fml == "poisson") {
#dev <- 2 * sum(w * (y * log(y / muhat) - y + muhat))
dev <- 0
for (i in 1:n) {
if (y[i] == 0) {
dev <- dev + 2 * w[i] * muhat[i]
} else {
dev <- dev + 2 * w[i] * (y[i] * log(y[i] / muhat[i]) - y[i] + muhat[i])
}
}
}
if (fml == "binomial") {
dev <- 0
for (i in 1:n) {
if (y[i] == 0 & w[i] != 0) {
dev <- dev + 2 * w[i] * log(w[i] / (w[i] - w[i] * muhat[i]))
} else if (y[i] == 1 & w[i] != 0) {
dev <- dev + 2 * w[i] * log(w[i] / (w[i] * muhat[i]))
} else if (0 < y[i] & y[i] < 1 & w[i] != 0) {
dev <- dev + 2 * w[i] * y[i] * log(w[i] * y[i] / (w[i] * muhat[i])) + 2 * (w[i] - w[i] * y[i]) * log((w[i] - w[i] * y[i]) / (w[i] - w[i] * muhat[i]))
} else {
stop ("y values must be 0 <= y <= 1!")
}
}
}
if (fml == "gaussian") {
dev <- sum(w * (y - muhat)^2)
}
if (fml == "Gamma") {
dev <- 0
for (i in 1:n) {
if (y[i] == 0) {
sm <- 1e-4
dev <- dev + 2 * w[i] * ((sm - muhat[i]) / muhat[i] - log(sm / muhat[i]))
} else {
dev <- dev + 2 * w[i] * ((y[i] - muhat[i]) / muhat[i] - log(y[i] / muhat[i]))
}
}
}
###################
#get null deviance#
###################
if (fml == "binomial" | fml == "poisson" | fml == "Gamma") {
diff <- 1
muhat0 <- mean(y) + 1:n*0
if (fml == "poisson") {
etahat0 <- log(muhat0)
}
if (fml == "binomial") {
etahat0 <- log(muhat0 / (1 - muhat0))
}
if (fml == "Gamma") {
etahat0 <- log(muhat0)
}
while (diff > sm) {
oldmu <- muhat0
zhat <- etahat0 + (y - muhat0) * deriv.fun(muhat0, fml = fml)
# wmat <- diag(as.vector(w / deriv.fun(muhat0, fml = fml)))
# b <- solve(t(vmat) %*% wmat %*% vmat) %*% t(vmat) %*% wmat %*% zhat
wm <- as.vector(w / deriv.fun(muhat0, fml = fml))
tvmat <- t(vmat)
for (i in 1:n) {tvmat[,i] <- tvmat[,i] * wm[i]}
b <- solve(tvmat %*% vmat) %*% tvmat %*% zhat
etahat0 <- vmat %*% b
muhat0 <- muhat.fun(etahat0, fml = fml)
diff <- mean((muhat0 - oldmu)^2)
}
if (fml == "poisson") {
#dev.null <- 2 * sum(w * (y * log(y / muhat0) - y + muhat0))
dev.null <- 0
for (i in 1:n) {
if (y[i] == 0) {
dev.null <- dev.null + 2 * w[i] * muhat0[i]
} else {
dev.null <- dev.null + 2 * w[i] * (y[i] * log(y[i] / muhat0[i]) - y[i] + muhat0[i])
}
}
}
if (fml == "binomial") {
dev.null <- 0
for (i in 1:n) {
if (y[i] == 0 & w[i] != 0) {
dev.null <- dev.null + 2 * w[i] * log(w[i] / (w[i] - w[i] * muhat0[i]))
} else if (y[i] == 1 & w[i] != 0) {
dev.null <- dev.null + 2 * w[i] * log(w[i] / (w[i] * muhat0[i]))
} else if (0 < y[i] & y[i] < 1 & w[i] != 0) {
dev.null <- dev.null + 2 * w[i] * y[i] * log(w[i] * y[i] / (w[i] * muhat0[i])) + 2 * (w[i] - w[i] * y[i]) * log((w[i] - w[i] * y[i]) / (w[i] - w[i] * muhat0[i]))
} else {
stop ("y values must be 0 <= y <= 1!")
}
}
}
if (fml == "Gamma") {
dev.null <- 0
for (i in 1:n) {
if (y[i] == 0) {
sm <- 1e-4
dev.null <- dev.null + 2 * w[i] * ((sm - muhat0[i]) / muhat0[i] - log(sm / muhat0[i]))
} else {
dev.null <- dev.null + 2 * w[i] * ((y[i] - muhat0[i]) / muhat0[i] - log(y[i] / muhat0[i]))
}
}
}
}
if (fml == "gaussian") {
# wmat <- diag(w)
# b <- solve(t(vmat) %*% wmat %*% vmat) %*% t(vmat) %*% wmat %*% y
tvmat <- t(vmat)
for (i in 1:n) {tvmat[,i] <- tvmat[,i] * w[i]}
b <- solve(tvmat %*% vmat) %*% tvmat %*% y
etahat0 <- vmat %*% b
muhat0 <- muhat.fun(etahat0, fml = fml)
dev.null <- sum(w * (y - muhat0)^2)
}
rslt <- new.env()
rslt$dev <- dev
rslt$dev.null <- dev.null
rslt
}
ans <- list(llh.fun = llh.fun, etahat.fun = etahat.fun, gr.fun = gr.fun, wt.fun = wt.fun, zvec.fun = zvec.fun, muhat.fun = muhat.fun, ysim.fun = ysim.fun, deriv.fun = deriv.fun, dev.fun = dev.fun, linkfun = linkfun)
class(ans) <- "CicFamily"
return (ans)
}
#######################
#eight shape functions#
#######################
#new: handle names like `Year of higest degree`
#test more!
get_varname <- function(expr) {
if (is.call(expr)) {
# Recursive extraction of the first symbol in a call
return(get_varname(expr[[2]]))
}
if (is.name(expr)) {
return(as.character(expr))
}
stop("Unsupported expression for variable name extraction.")
}
incr <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 1
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
decr <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 2
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
conv <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "nm") <- get_varname(pars$x)
attr(x, "shape") <- 3
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
conc <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "nm") <- get_varname(pars$x)
attr(x, "shape") <- 4
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
incr.conv <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "nm") <- get_varname(pars$x)
attr(x, "shape") <- 5
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
decr.conv <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "nm") <- get_varname(pars$x)
attr(x, "shape") <- 6
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
incr.conc <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "nm") <- get_varname(pars$x)
attr(x, "shape") <- 7
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
decr.conc <- function(x, numknots = 0, knots = 0, space = "E")
{
cl <- match.call()
pars <- match.call()[-1]
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "nm") <- get_varname(pars$x)
attr(x, "shape") <- 8
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
#s.incr <- function(x, numknots = 0, knots = 0, space = "E")
#{
# cl <- match.call()
# pars <- match.call()[-1]
# attr(x, "nm") <- deparse(pars$x)
# attr(x, "shape") <- 9
# attr(x, "numknots") <- numknots
# attr(x, "knots") <- knots
# attr(x, "space") <- space
# attr(x, "categ") <- "additive"
# #class(x) <- "additive"
# x
#}
#s.decr <- function(x, numknots = 0, knots = 0, space = "E")
#{
# cl <- match.call()
# pars <- match.call()[-1]
# attr(x, "nm") <- deparse(pars$x)
# attr(x, "shape") <- 10
# attr(x, "numknots") <- numknots
# attr(x, "knots") <- knots
# attr(x, "space") <- space
# attr(x, "categ") <- "additive"
# #class(x) <- "additive"
# x
#}
s.incr <- function(x, numknots = 0, knots = 0, var.knots = 0, space = "Q", db.exp = FALSE)
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 9
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
attr(x, "db.exp") <- db.exp
attr(x, "var.knots") <- var.knots
#class(x) <- "additive"
x
}
s.decr <- function(x, numknots = 0, knots = 0, var.knots = 0, space = "Q", db.exp = FALSE)
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 10
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
attr(x, "db.exp") <- db.exp
attr(x, "var.knots") <- var.knots
#class(x) <- "additive"
x
}
s.conv <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 11
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
s.conc <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 12
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
s.incr.conv <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 13
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
s.incr.conc <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 14
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
s.decr.conv <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 15
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
s.decr.conc <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 16
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
s <- function(x, numknots = 0, knots = 0, space = "Q")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- 17
attr(x, "numknots") <- numknots
attr(x, "knots") <- knots
attr(x, "space") <- space
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
######################################################
#tree function: give the tree shape to x and return x#
######################################################
tree <- function(x, pl = NULL)
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- "tree"
#stop (print (x))
#print (class(x))
if (is.null(pl)) {
if (is.numeric(x)) {
if (0%in%x) {
pl <- 0
} else {pl <- min(x)}
} else {
xu <- unique(x)
pl <- xu[1]
}
} else {
if (!(pl%in%x)) {
stop ("placebo level is not a level of the tree variable!")
}
}
attr(x, "pl") <- pl
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
##################################################
#tree.fun: make delta to a tree ordering variable#
##################################################
#tree.fun <- function(x)
#{
# if (min(x) != 0) {
# stop ("A tree ordering variable must have its placebo equal to 0!")
# }
# if (!all(round(x, 0) == x)) {
# stop ("All elements of a tree ordering variable must be integers!")
# }
# if (any(x < 0))
# stop ("All elements of a tree ordering variable must be positive!")
# nx <- x
# obs <- 1:length(x)
# delta <- matrix(0, nrow = length(attributes(factor(x))$levels) - 1, ncol = length(x))
# pl <- min(nx)
# for (i in 1:nrow(delta)) {
# nx <- nx[which(nx != pl)]
# pl <- min(nx)
# index <- obs[x == pl]
# delta[i, index] <- 1
# }
# attr(delta, "shape") <- "tree"
# delta
#}
tree.fun <- function(x, pl = NULL)
{
#if (pl %in% x) {
if (is.null(pl)) {
if (is.numeric(x)) {
if (0%in%x) {
pl <- 0
} else {pl <- min(x)}
} else {
xu <- unique(x)
pl <- xu[1]
}
} else {
if (!(pl%in%x)) {
stop ("placebo level is not a level of the tree variable!")
}
}
pos <- x %in% pl
xu <- unique(x)
nx <- xu[xu != pl]
delta <- matrix(0, nrow = (length(xu) - 1), ncol = length(x))
for (i in 1:nrow(delta)) {
xi = nx[i]
delta[i, !pos & x %in% xi] <- 1
pos <- pos | x %in% xi
}
#} else {stop ("placebo level is not a level of the tree variable!")}
attr(delta, "shape") <- "tree"
delta
}
##############################################################
#umbrella function: give the umbrella shape to x and return x#
##############################################################
umbrella <- function(x)
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- get_varname(pars$x)
#attr(x, "nm") <- deparse(pars$x)
#attr(x, "nm") <- deparse(substitute(pars$x))
attr(x, "shape") <- "umbrella"
attr(x, "categ") <- "additive"
#class(x) <- "additive"
x
}
###########################################################
#umbrella.fun: make delta to an umbrella ordering variable#
###########################################################
umbrella.fun <- function(x)
{
amat <- amat.fun(x)
bmat <- bmat.fun(x)
constr <- t(rbind(amat, bmat))
vmat <- qr.Q(qr(constr), complete = TRUE)[, -(1:(qr(constr)$rank)), drop = FALSE]
if (!is.null(bmat)) {
wperp <- t(rbind(t(vmat), bmat))
wmat <- qr.Q(qr(wperp), complete = TRUE)[, -(1:(qr(wperp)$rank)), drop = FALSE]
atil <- amat %*% wmat
delta <- t(wmat %*% t(atil) %*% solve(atil %*% t(atil)))
} else {
delta <- t(t(amat) %*% solve(amat %*% t(amat)))
}
attr(delta, "shape") <- "umbrella"
delta
}
###################################################
#find delta for a specific predictor x and a shape#
#use splines2 pkg
###################################################
# makedelta = function(x, sh, numknots = 0, knots = 0, space = "E", suppre = FALSE, interp = FALSE, shpselect = FALSE) {
# #if (!interp) {
# #x = (x - min(x)) / (max(x) - min(x))
# #}
# n = length(x)
# # find unique x values
# #round(x,8) will make 0 edge in amat!
# #xu = sort(unique(round(x, 8)))
# #new: center and scale to avoid numerical instability
# if(sh < 9){
# xu = sort(unique(x))
# } else {
# xu = unique(x)
# }
#
# n1 = length(xu)
# sm = 1e-7
# ms = NULL
# # increasing or decreasing
# if (sh < 3) {
# amat = matrix(0, nrow = n1 - 1, ncol = n)
# for (i in 1: (n1 - 1)) {
# amat[i, x > xu[i]] = 1
# }
# if (sh == 2) {amat = -amat}
# if (!interp) {
# # for (i in 1:(n1 - 1)) {
# # #new: use ms in predict.cgam
# # ms = c(ms, mean(amat[i, ]))
# # amat[i, ] = amat[i, ] - mean(amat[i, ])
# # }
# ms = apply(amat, 1, mean)
# amat = apply(amat, 1, function(e) scale(e, scale = FALSE))
# }
# } else if (sh == 3 | sh == 4) {
# # convex or concave
# amat = matrix(0, nrow = n1 - 2 ,ncol = n)
# #for (i in 1: (n1 - 2)) {
# # amat[i, x > xu[i]] = x[x > xu[i]] - xu[i]
# #}
# for (i in 1: (n1 - 2)) {
# amat[i, x > xu[i+1]] = x[x > xu[i+1]] - xu[i+1]
# }
# if (sh == 4) {amat = -amat}
# xm = cbind(1:n*0+1,x)
# xpx = solve(t(xm) %*% xm)
# pm = xm %*% xpx %*% t(xm)
# #new: use ms in predict.cgam
# if (!interp) {
# ms = amat %*% t(pm)
# #amat = amat - amat %*% t(pm)
# amat = amat - ms
# }
# } else if (sh > 4 & sh < 9) {
# amat = matrix(0, nrow = n1 - 1, ncol = n)
# if (sh == 5) { ### increasing convex
# for (i in 1:(n1 - 1)) {
# amat[i, x > xu[i]] = (x[x > xu[i]] - xu[i]) / (max(x) - xu[i])
# }
# if (!interp) {
# #for (i in 1:(n1 - 1)) {
# # ms = c(ms, mean(amat[i, ]))
# # amat[i,] = amat[i,] - mean(amat[i,])
# #}
# ms = apply(amat, 1, mean)
# amat = apply(amat, 1, function(e) scale(e, scale = FALSE))
# }
# } else if (sh == 6) { ## decreasing convex
# for (i in 1:(n1 - 1)) {
# amat[i, x < xu[i + 1]] = (x[x < xu[i + 1]] - xu[i + 1]) / (min(x) - xu[i + 1])
# }
# if (!interp) {
# #for (i in 1:(n1 - 1)) {
# # ms = c(ms, mean(amat[i, ]))
# # amat[i,] = amat[i,] - mean(amat[i, ])
# #}
# ms = apply(amat, 1, mean)
# amat = apply(amat, 1, function(e) scale(e, scale = FALSE))
# }
# #print (ms)
# } else if (sh == 7) { ## increasing concave
# for (i in 1:(n1 - 1)) {
# amat[i, x < xu[i + 1]] = (x[x < xu[i + 1]] - xu[i + 1]) / (min(x) - xu[i + 1])
# }
# if (!interp) {
# #for (i in 1:(n1 - 1)) {
# # ms = c(ms, mean(amat[i, ]))
# # amat[i,] = -amat[i,] + mean(amat[i,])
# #}
# ms = apply(amat, 1, mean)
# amat = apply(amat, 1, function(e) scale(e, scale = FALSE))
# amat = -amat
# }
# } else if (sh == 8) {## decreasing concave
# for (i in 1:(n1 - 1)) {
# amat[i, x > xu[i]] = (x[x > xu[i]] - xu[i]) / (max(x) - xu[i])
# }
# if (!interp) {
# #for (i in 1:(n1 - 1)) {
# # ms = c(ms, mean(amat[i, ]))
# # amat[i,] = -amat[i,] + mean(amat[i,])
# #}
# ms = apply(amat, 1, mean)
# amat = apply(amat, 1, function(e) scale(e, scale = FALSE))
# amat = -amat
# }
# }
# } else if (sh > 8 & sh < 18) {
# #new: add two knots
# #if (all(knots == 0) & numknots == 0) {
# if (length(knots) < 2 & numknots == 0) {
# if (sh == 9 | sh == 10) {#1 2
# #k = trunc(n1^(1/5)) + 4
# if (n1 <= 50) {
# k = 5
# } else if (n1>50 && n1<100) {
# k = 6
# } else if (n1>= 100 && n1<200) {
# k = 7
# } else {
# k = trunc(n1^(1/5)) + 6
# }
# } else {
# #k = trunc(n1^(1/7) + 4)
# if (n1 <= 50) {
# k = 5
# } else if (n1>50 && n1<100) {
# k = 6
# } else if (n1>= 100 && n1<200) {
# k = 7
# } else {
# k = trunc(n1^(1/7)) + 6
# }
# }
# if (space == "Q") {
# t = quantile(xu, probs = seq(0, 1, length = k), names = FALSE)
# }
# if (space == "E") {
# #t = 0:k / k * (max(x) - min(x)) + min(x)
# #t = 0:(k-1) / (k-1) * (max(x) - min(x)) + min(x)
# t = seq.int(min(x), max(x), length.out = k)
# }
# #} else if (any(knots != 0) & numknots == 0) {
# } else if (length(knots) >= 2 & numknots == 0) {
# t = knots
# #} else if (all(knots == 0) & numknots != 0) {
# } else if (length(knots) < 2 & numknots != 0) {
# if (space == "Q") {
# t = quantile(xu, probs = seq(0, 1, length = numknots), names = FALSE)
# }
# if (space == "E") {
# #k = numknots
# #new: numknots should be the # of all knots
# k = numknots - 1
# #if (sh == 9 | sh == 10) {#1 2
# # k = trunc(n1^(1/5)) + 4
# #} else {k = trunc(n1^(1/7) + 4)}
# #t = 0:k/k * (max(x) - min(x)) + min(x)
# t = seq.int(min(x), max(x), length.out = numknots)
# }
# #} else if (any(knots != 0) & numknots != 0) {
# } else if (length(knots) >= 2 & numknots != 0) {
# #t0 = quantile(xu, probs = seq(0, 1, length = numknots), names = FALSE)
# t = knots
# if (!suppre) {
# print("'knots' is used! 'numknots' is not used!")
# }
# #print ("'knots' is used!")
# #if (numknots != length(knots)) {
# # if (!suppre) {
# # print("length(knots) is not equal to 'numknots'! 'knots' is used!")
# # }
# #} else if (any(t0 != knots)) {
# # if (!suppre) {
# # print("equal x-quantiles knots != 'knots'! 'knots' is used! ")
# # }
# #}
# }
# if (sh == 9) {#1
# #amat_ans = monincr(x, t, interp)
# #amat = amat_ans$sigma |> t()
# #ms = amat_ans$ms
# #cat('use monincr!', '\n')
# #new: use splines2 pkg to make it faster
#
# nt = length(t)
# amat = iSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# # #cat('use splines2!', '\n')
# ms = colMeans(amat)
# #
# #make the basis orthogonal to 1
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 10) {#2
# #amat_ans = mondecr(x, t, interp)
# #amat = amat_ans$sigma |> t()
# #ms = amat_ans$ms
#
# nt = length(t)
# amat = -iSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# #cat('use splines2!', '\n')
# ms = colMeans(amat)
#
# #make the basis orthogonal to 1
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 11) {#3
# #amat_ans = convex(x, t, interp)
# #amat = amat_ans$sigma
# #amat = t(amat)
# #ms = amat_ans$ms
#
# nt = length(t)
# amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# #cat('use splines2!', '\n')
# ms = colMeans(amat)
#
# if(!interp){
# xm = cbind(1, x)
# pm = xm %*% solve(crossprod(xm), t(xm))
# amat = amat - pm %*% amat
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 12) {#4
# # amat_ans = concave(x, t, interp)
# # amat = amat_ans$sigma
# # amat = t(amat)
# # ms = amat_ans$ms
#
# nt = length(t)
# amat = -cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# #cat('use splines2!', '\n')
# #ms = colMeans(amat)
#
# if(!interp){
# xm = cbind(1, x)
# pm = xm %*% solve(crossprod(xm), t(xm))
# amat = amat - pm %*% amat
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 13) {#5
# #amat_ans = incconvex(x, t, interp)
# #amat = amat_ans$sigma
# #amat = t(amat)
# #ms = amat_ans$ms
#
# nt = length(t)
# amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# x_sc = (x - min(x)) / (max(x) - min(x))
# amat = cbind(amat, x_sc)
# #cat('use splines2!', '\n')
# ms = colMeans(amat)
#
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 14) {#6
# #amat_ans = incconcave(x, t, interp)
# #amat = amat_ans$sigma
# #ms = amat_ans$ms
# #amat = t(amat)
#
# nt = length(t)
# amat = -cSpline(-x, knots = -rev(t[-c(1, nt)]), Boundary.knots = -c(t[nt], t[1]), degree = 1)
# x_sc = (-x - min(-x)) / (max(-x) - min(-x))
# amat = cbind(-x_sc, amat)
# #cat('use splines2!', '\n')
# ms = colMeans(amat)
#
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 15) {#7
# #amat_ans = -incconcave(x, t, interp)
# # amat_ans = incconcave(x, t, interp)
# # amat = -amat_ans$sigma
# # if (!interp) {
# # ms = -amat_ans$ms
# # }
# # amat = t(amat)
#
# nt = length(t)
# amat = cSpline(-x, knots = -rev(t[-c(1, nt)]), Boundary.knots = -c(t[nt], t[1]), degree = 1)
# x_sc = (-x - min(-x)) / (max(-x) - min(-x))
# amat = cbind(x_sc, amat)
# #cat('use splines2!', '\n')
# ms = colMeans(amat)
#
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# # nt = length(t)
# # amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# # amat = cbind(amat, x)
# # cat('use splines2!', '\n')
# # ms = colMeans(amat)
# # nt = length(t)
# # amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# # amat = cbind(amat, -x)
# # cat('use splines2!', '\n')
# # ms = colMeans(amat)
#
# } else if (sh == 16) {#8
# #amat_ans = -incconvex(x, t, interp)
# # amat_ans = incconvex(x, t, interp)
# # amat = -amat_ans$sigma |> t()
# # if (!interp) {
# # ms = -amat_ans$ms
# # }
#
# nt = length(t)
# amat = -cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# x_sc = (x - min(x)) / (max(x) - min(x))
# amat = cbind(amat, -x_sc)
# #cat('use splines2!', '\n')
# if (!interp) {
# ms = colMeans(amat)
# }
#
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# } else if (sh == 17) {#unconstrained
# #amat_ans = incconvex(x, t, interp)
# #amat = amat_ans$sigma |> t()
# #ms = amat_ans$ms
#
# nt = length(t)
# amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# x_sc = (x - min(x)) / (max(x) - min(x))
# amat = cbind(amat, x_sc)
# #cat('use splines2!', '\n')
# ms = colMeans(amat)
#
# if(!interp){
# for(i in 1:ncol(amat)){
# amat[,i] = amat[,i] - ms[i]
# }
# }
#
# #if(shpselect) {
# amat = t(amat)
# #}
# #amat = -incconcave(x, t)
# #amat = rbind(x, t(bcspl(x, m = length(t), knots = t)$bmat))
# #amat = rbind(x, convex(x, t))
# }
# }
# #if (sh < 9) {
# # rslt = list(amat = amat, knots = 0, ms = ms)
# #} else {
# # rslt = list(amat = amat, knots = t, ms = ms)
# #}
# if (sh < 9) {t = 0}
# rslt = list(amat = amat, knots = t, ms = ms)
# rslt
# }
###################################################
#find delta for a specific predictor x and a shape#
###################################################
makedelta = function(x, sh, numknots = 0, knots = 0, space = "E", suppre = FALSE, interp = FALSE) {
#if (!interp) {
#x = (x - min(x)) / (max(x) - min(x))
#}
n = length(x)
# find unique x values
#round(x,8) will make 0 edge in amat!
#xu = sort(unique(round(x, 8)))
#new: center and scale to avoid numerical instabillity
xu = sort(unique(x))
n1 = length(xu)
sm = 1e-7
ms = NULL
# increasing or decreasing
if (sh < 3) {
amat = matrix(0, nrow = n1 - 1, ncol = n)
for (i in 1: (n1 - 1)) {
amat[i, x > xu[i]] = 1
}
if (sh == 2) {amat = -amat}
if (!interp) {
for (i in 1:(n1 - 1)) {
#new: use ms in predict.cgam
ms = c(ms, mean(amat[i, ]))
amat[i, ] = amat[i, ] - mean(amat[i, ])
}
}
} else if (sh == 3 | sh == 4) {
# convex or concave
amat = matrix(0, nrow = n1 - 2 ,ncol = n)
#for (i in 1: (n1 - 2)) {
# amat[i, x > xu[i]] = x[x > xu[i]] - xu[i]
#}
for (i in 1: (n1 - 2)) {
amat[i, x > xu[i+1]] = x[x > xu[i+1]] - xu[i+1]
}
if (sh == 4) {amat = -amat}
xm = cbind(1:n*0+1,x)
xpx = solve(t(xm) %*% xm)
pm = xm %*% xpx %*% t(xm)
#new: use ms in predict.cgam
if (!interp) {
ms = amat %*% t(pm)
#amat = amat - amat %*% t(pm)
amat = amat - ms
}
} else if (sh > 4 & sh < 9) {
amat = matrix(0, nrow = n1 - 1, ncol = n)
if (sh == 5) { ### increasing convex
for (i in 1:(n1 - 1)) {
amat[i, x > xu[i]] = (x[x > xu[i]] - xu[i]) / (max(x) - xu[i])
}
if (!interp) {
for (i in 1:(n1 - 1)) {
ms = c(ms, mean(amat[i, ]))
amat[i,] = amat[i,] - mean(amat[i,])
}
}
} else if (sh == 6) { ## decreasing convex
for (i in 1:(n1 - 1)) {
amat[i, x < xu[i + 1]] = (x[x < xu[i + 1]] - xu[i + 1]) / (min(x) - xu[i + 1])
}
if (!interp) {
for (i in 1:(n1 - 1)) {
ms = c(ms, mean(amat[i, ]))
amat[i,] = amat[i,] - mean(amat[i, ])
}
}
#print (ms)
} else if (sh == 7) { ## increasing concave
for (i in 1:(n1 - 1)) {
amat[i, x < xu[i + 1]] = (x[x < xu[i + 1]] - xu[i + 1]) / (min(x) - xu[i + 1])
}
if (!interp) {
for (i in 1:(n1 - 1)) {
ms = c(ms, mean(amat[i, ]))
amat[i,] = -amat[i,] + mean(amat[i,])
}
}
} else if (sh == 8) {## decreasing concave
for (i in 1:(n1 - 1)) {
amat[i, x > xu[i]] = (x[x > xu[i]] - xu[i]) / (max(x) - xu[i])
}
if (!interp) {
for (i in 1:(n1 - 1)) {
ms = c(ms, mean(amat[i, ]))
amat[i,] = -amat[i,] + mean(amat[i,])
}
}
}
} else if (sh > 8 & sh < 18) {
#new: add two knots
#if (all(knots == 0) & numknots == 0) {
if (length(knots) < 2 & numknots == 0) {
if (sh == 9 | sh == 10) {#1 2
#k = trunc(n1^(1/5)) + 4
if (n1 <= 50) {
k = 5
} else if (n1>50 && n1<100) {
k = 6
} else if (n1>= 100 && n1<200) {
k = 7
} else {
k = trunc(n1^(1/5)) + 6
}
} else {
#k = trunc(n1^(1/7) + 4)
if (n1 <= 50) {
k = 5
} else if (n1>50 && n1<100) {
k = 6
} else if (n1>= 100 && n1<200) {
k = 7
} else {
k = trunc(n1^(1/7)) + 6
}
}
if (space == "Q") {
t = quantile(xu, probs = seq(0, 1, length = k), names = FALSE)
}
if (space == "E") {
#t = 0:k / k * (max(x) - min(x)) + min(x)
t = 0:(k-1) / (k-1) * (max(x) - min(x)) + min(x)
}
#} else if (any(knots != 0) & numknots == 0) {
} else if (length(knots) >= 2 & numknots == 0) {
t = knots
#} else if (all(knots == 0) & numknots != 0) {
} else if (length(knots) < 2 & numknots != 0) {
if (space == "Q") {
t = quantile(xu, probs = seq(0, 1, length = numknots), names = FALSE)
}
if (space == "E") {
#k = numknots
#new: numknots should be the # of all knots
k = numknots - 1
#if (sh == 9 | sh == 10) {#1 2
# k = trunc(n1^(1/5)) + 4
#} else {k = trunc(n1^(1/7) + 4)}
t = 0:k / k * (max(x) - min(x)) + min(x)
}
#} else if (any(knots != 0) & numknots != 0) {
} else if (length(knots) >= 2 & numknots != 0) {
#t0 = quantile(xu, probs = seq(0, 1, length = numknots), names = FALSE)
t = knots
if (!suppre) {
print("'knots' is used! 'numknots' is not used!")
}
#print ("'knots' is used!")
#if (numknots != length(knots)) {
# if (!suppre) {
# print("length(knots) is not equal to 'numknots'! 'knots' is used!")
# }
#} else if (any(t0 != knots)) {
# if (!suppre) {
# print("equal x-quantiles knots != 'knots'! 'knots' is used! ")
# }
#}
}
if (sh == 9) {#1
#amat_ans = monincr(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = iSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
# #cat('use splines2!', '\n')
ms = colMeans(amat)
#make the basis orthogonal to 1
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 10) {#2
#amat_ans = mondecr(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = -iSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
#cat('use splines2!', '\n')
ms = colMeans(amat)
#make the basis orthogonal to 1
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 11) {#3
#amat_ans = convex(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
#cat('use splines2!', '\n')
ms = colMeans(amat)
if(!interp){
xm = cbind(1, x)
pm = xm %*% solve(crossprod(xm), t(xm))
amat = amat - pm %*% amat
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 12) {#4
#amat_ans = concave(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = -cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
#cat('use splines2!', '\n')
ms = colMeans(amat)
if(!interp){
xm = cbind(1, x)
pm = xm %*% solve(crossprod(xm), t(xm))
amat = amat - pm %*% amat
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 13) {#5
#amat_ans = incconvex(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
#will give NaN when predicting for a single data point!
#x_sc = (x - min(x)) / (max(x) - min(x))
x_sc = x
amat = cbind(amat, x_sc)
#cat('use splines2!', '\n')
ms = colMeans(amat)
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 14) {#6
#amat_ans = incconcave(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = -cSpline(-x, knots = -rev(t[-c(1, nt)]), Boundary.knots = -c(t[nt], t[1]), degree = 1)
#wrong!
#x_sc = (-x - min(-x)) / (max(-x) - min(-x))
x_sc = -x
amat = cbind(-x_sc, amat)
#cat('use splines2!', '\n')
ms = colMeans(amat)
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 15) {#7
##amat_ans = -incconcave(x, t, interp)
#amat_ans = incconcave(x, t, interp)
#amat = -amat_ans$sigma
#if (!interp) {
# ms = -amat_ans$ms
#}
nt = length(t)
amat = cSpline(-x, knots = -rev(t[-c(1, nt)]), Boundary.knots = -c(t[nt], t[1]), degree = 1)
#wrong!
#x_sc = (-x - min(-x)) / (max(-x) - min(-x))
x_sc = -x
amat = cbind(x_sc, amat)
#cat('use splines2!', '\n')
ms = colMeans(amat)
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 16) {#8
##amat_ans = -incconvex(x, t, interp)
#amat_ans = incconvex(x, t, interp)
#amat = -amat_ans$sigma
#if (!interp) {
# ms = -amat_ans$ms
#}
nt = length(t)
amat = -cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
#wrong!
#x_sc = (x - min(x)) / (max(x) - min(x))
x_sc = x
amat = cbind(amat, -x_sc)
#cat('use splines2!', '\n')
#if (!interp) {
ms = colMeans(amat)
#}
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
} else if (sh == 17) {#unconstrained
#amat_ans = incconvex(x, t, interp)
#amat = amat_ans$sigma
#ms = amat_ans$ms
nt = length(t)
amat = cSpline(x, knots = t[-c(1, nt)], Boundary.knots = c(t[1], t[nt]), degree = 1)
#wrong!
#x_sc = (x - min(x)) / (max(x) - min(x))
x_sc = x
amat = cbind(amat, x_sc)
#cat('use splines2!', '\n')
ms = colMeans(amat)
if(!interp){
for(i in 1:ncol(amat)){
amat[,i] = amat[,i] - ms[i]
}
}
#if(shpselect) {
amat = t(amat)
#}
}
}
#if (sh < 9) {
# rslt = list(amat = amat, knots = 0, ms = ms)
#} else {
# rslt = list(amat = amat, knots = t, ms = ms)
#}
if (sh < 9) {t = 0}
rslt = list(amat = amat, knots = t, ms = ms)
rslt
}
#####
#make basis for additive components
make_delta_add = function(xmat, shapes, numknots, knots, space) {
capl = ncol(xmat)
if (capl < 1) {capl = 0}
if (round(capl, 8) != round(capl, 1)) {stop ("Incompatible dimensions for xmat!")}
capls = sum(shapes == 17)
delta = NULL
varlist = NULL
knotsuse = list(); numknotsuse = NULL
mslst = list()
capm = 0
capms = 0
del1_ans = makedelta(xmat[, 1], shapes[1], numknots[1], knots[[1]], space = space[1], interp = FALSE)
del1 = del1_ans$amat
knotsuse[[1]] = del1_ans$knots
mslst[[1]] = del1_ans$ms
numknotsuse = c(numknotsuse, length(del1_ans$knots))
m1 = nrow(del1)
#new code: record the number of columns of del1 if shapes0[1] == 17:
if (shapes[1] == 17) {capms = capms + m1}
var1 = 1:m1*0 + 1
if (capl == 1) {
delta = del1
varlist = var1
} else {
for (i in 2:capl) {
del2_ans = makedelta(xmat[,i], shapes[i], numknots[i], knots[[i]], space = space[i], interp = FALSE)
del2 = del2_ans$amat
knotsuse[[i]] = del2_ans$knots
mslst[[i]] = del2_ans$ms
numknotsuse = c(numknotsuse, length(del2_ans$knots))
m2 = nrow(del2)
#new code: record the number of columns of del2 if shapes0[i] == 17:
if (shapes[i] == 17) {capms = capms + m2}
delta = rbind(del1, del2)
varlist = 1:(m1 + m2)*0
varlist[1:m1] = var1
varlist[(m1 + 1):(m1 + m2)] = (1:m2)*0 + i
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0) {
bigmat = rbind(t(xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13]), delta)
np = sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0) {
bigmat = delta
np = capms
}
rslt = list(bigmat=bigmat, np=np, varlist=varlist, knotsuse=knotsuse, mslst=mslst)
return(rslt)
}
# Monotone increasing
monincr = function(xs, t, interp = FALSE) {
n = length(xs)
#xs = (xs - min(xs)) / (max(xs) - min(xs))
x = sort(xs)
k = length(t) - 2
m = k + 2
sigma = matrix(0, nrow = m, ncol = n)
obs = 1:n
knt = 1:m
for (i in 1:(k+2)) {knt[i] = min(obs[abs(x - t[i]) == min(abs(x - t[i]))])}
for (j in 1:(k-1)) {
index = x >= t[1] & x <= t[j]
sigma[j, index] = 0
index = x > t[j] & x <= t[j+1]
sigma[j, index] = (x[index] - t[j])^2 / (t[j+2] - t[j]) / (t[j+1] - t[j])
index = x > t[j+1] & x <= t[j+2]
sigma[j, index] = 1 - (x[index] - t[j+2])^2 / (t[j+2] - t[j+1]) / (t[j+2] - t[j])
index = x > t[j+2] #& x <= t[m]
sigma[j, index] = 1
}
index = x >= t[1] & x <= t[k]
sigma[k, index] = 0
index = x > t[k] & x <= t[k+1]
sigma[k, index] = (x[index] - t[k])^2 / (t[k+2] - t[k]) / (t[k+1] - t[k])
index = x > t[k+1] & x <= t[k+2]
sigma[k, index] = 1 - (x[index] - t[k+2])^2 / (t[k+2] - t[k+1]) / (t[k+2] - t[k])
index = x >= t[1] & x <= t[2]
sigma[k+1, index] = 1 - (t[2] - x[index])^2 / (t[2] - t[1])^2
index = x > t[2]
sigma[k+1, index] = 1
index = x >= t[1] & x <= t[k+1]
sigma[k+2, index] = 0
index = x > t[k+1] & x <= t[k+2]
sigma[k+2, index] = (x[index] - t[k+1])^2 / (t[k+2] - t[k+1])^2
#new:
ms = NULL
if (!interp) {
ms = apply(sigma, 1, mean)
for (i in 1:m) {
sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
} else {
for (i in 1:m) {
#sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
}
rslt = list(sigma = sigma, ms = ms)
rslt
}
########################################################
# Monotone decreasing
mondecr = function(xs, t, interp = FALSE) {
#xs = (xs - min(xs)) / (max(xs) - min(xs))
x = sort(xs)
n = length(x)
k = length(t) - 2
m = k + 2
sigma = matrix(0, nrow = m, ncol = n)
obs = 1:n
#knt = 1:m
#for (i in 1:(k + 2)) {knt[i] = min(obs[abs(x - t[i]) == min(abs(x - t[i]))])}
#t = x[knt]
for (j in 1:(k - 1)) {
index = x >= t[1] & x <= t[j]
sigma[j, index] = 1
index = x > t[j] & x <= t[j+1]
sigma[j, index] = 1 - (x[index] - t[j])^2 / (t[j+2] - t[j]) / (t[j+1] - t[j])
index = x > t[j+1] & x <= t[j+2]
sigma[j, index] = (x[index] - t[j+2])^2 / (t[j+2] - t[j+1]) / (t[j+2] - t[j])
index = x > t[j+2]
sigma[j, index] = 0
}
index = x >= t[1] & x <= t[k]
sigma[k, index] = 1
index = x > t[k] & x <= t[k+1]
sigma[k, index] = 1 - (x[index] - t[k])^2 / (t[k+2] - t[k]) / (t[k+1] - t[k])
index = x > t[k+1] & x <= t[k+2]
sigma[k, index] = (x[index] - t[k+2])^2 / (t[k+2] - t[k+1]) / (t[k+2] - t[k])
index = x >= t[1] & x <= t[2]
sigma[k+1, index] = (t[2] - x[index])^2 / (t[2] - t[1])^2
index = x > t[2]
sigma[k+1, index] = 0
index = x >= t[1] & x <= t[k+1]
sigma[k+2, index] = 1
index = x > t[k+1] & x <= t[k+2]
sigma[k+2, index] = 1 - (x[index] - t[k+1])^2 / (t[k+2] - t[k+1])^2
ms = NULL
if (!interp) {
ms = apply(sigma, 1, mean)
for (i in 1:m) {
sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
} else {
for (i in 1:m) {
#sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
}
rslt = list(sigma = sigma, ms = ms)
rslt
}
########################################################
# Convex
convex = function(xs, t, interp = FALSE) {
#xs = (xs - min(xs)) / (max(xs) - min(xs))
x = sort(xs)
n = length(x)
k = length(t) - 2
m = k + 2
sigma = matrix(0, nrow = m, ncol = n)
obs = 1:n
#knt = 1:m
#for (i in 1:(k+2)) {knt[i] = min(obs[abs(x - t[i]) == min(abs(x - t[i]))])}
for (j in 1:(k-1)) {
index = x >= t[1] & x <= t[j]
sigma[j, index] = 0
index = x > t[j] & x <= t[j+1]
sigma[j, index] = (x[index] - t[j])^3 / (t[j+2] - t[j]) / (t[j+1] - t[j]) / 3
index = x > t[j+1] & x <= t[j+2]
sigma[j, index] = x[index] - t[j+1] - (x[index] - t[j+2])^3 / (t[j+2] - t[j]) / (t[j+2] - t[j+1]) / 3 + (t[j+1] - t[j])^2 / 3 /(t[j+2] - t[j]) - (t[j+2] - t[j+1])^2 / 3 / (t[j+2] - t[j])
index = x > t[j+2]
sigma[j, index] = (x[index] - t[j+1]) + (t[j+1] - t[j])^2 / 3 / (t[j+2] - t[j]) - (t[j+2] - t[j+1])^2 / 3 / (t[j+2] - t[j])
}
index = x >= t[1] & x <= t[k]
sigma[k, index] = 0
index = x > t[k] & x <= t[k+1]
sigma[k, index] = (x[index] - t[k])^3 / (t[k+2] - t[k]) / (t[k+1] - t[k]) / 3
index = x > t[k+1] & x <= t[k+2]
sigma[k, index] = x[index] - t[k+1] - (x[index] - t[k+2])^3 / (t[k+2] - t[k]) / (t[k+2] - t[k+1]) / 3 + (t[k+1] - t[k])^2 / 3 / (t[k+2] -t[k]) - (t[k+2] - t[k+1])^2 / 3 / (t[k+2] - t[k])
index = x >= t[1] & x <= t[2]
sigma[k+1, index] = x[index] - t[1] + (t[2] - x[index])^3 / (t[2] - t[1])^2 / 3 - (t[2] - t[1]) / 3 #-(t[2]-t[1])^3/(t[2]-t[1])^2/3 #
index = x > t[2]
sigma[k+1, index] = x[index] - t[1] - (t[2] - t[1]) / 3 #-(t[2]-t[1])^3/(t[2]-t[1])^2/3#
index = x >= t[1] & x <= t[k+1]
sigma[k+2, index] = 0
index = x > t[k+1] & x <= t[k+2]
sigma[k+2, index] = (x[index] - t[k+1])^3 / (t[k+2] - t[k+1])^2 / 3
ms = NULL
if (!interp) {
xm = cbind(1:n*0+1, x)
pm = xm %*% solve(t(xm) %*% xm) %*% t(xm)
ms = matrix(0, nrow = nrow(sigma), ncol = ncol(sigma))
for (i in 1:m) {
ms[i,] = pm %*% sigma[i,]
ms[i,] = ms[i, rank(xs)]
#rng=max(sigma[i,])
#sigma[i,]=sigma[i,]/rng
sigma[i,] = sigma[i,] - pm %*% sigma[i,]
sigma[i,] = sigma[i, rank(xs)]
}
} else {
for (i in 1:m) {
#sigma[i,] = sigma[i,] - pm %*% sigma[i,]
sigma[i,] = sigma[i, rank(xs)]
}
}
rslt = list(sigma = sigma, ms = ms)
rslt
}
########################################################
# Concave
concave = function(xs, t, interp = FALSE) {
#xs = (xs - min(xs)) / (max(xs) - min(xs))
x = sort(xs)
n = length(x)
k = length(t) - 2
m = k + 2
sigma = matrix(0, nrow = m, ncol = n)
obs = 1:n
#knt = 1:m
#for (i in 1:(k+2)) {knt[i] = min(obs[abs(x - t[i]) == min(abs(x - t[i]))])}
#t = x[knt]
for (j in 1:k) {
index = x >= t[1] & x <= t[j]
sigma[j, index] = x[index] - t[1]
index = x > t[j] & x <= t[j+1]
sigma[j, index] = t[j] - t[1] + ((t[j+1] - t[j])^3 - (t[j+1] - x[index])^3) / 3 / (t[j+1] - t[j]) / (t[j+2] - t[j]) + (x[index] - t[j]) * (t[j+2] - t[j+1]) / (t[j+2] - t[j])
index = x > t[j+1] & x <= t[j+2]
sigma[j, index] = t[j] - t[1] + (t[j+1] - t[j])^2 / 3 / (t[j+2] - t[j]) + (t[j+2] - t[j+1]) * (t[j+1] - t[j]) / (t[j+2] - t[j]) + ((t[j+2] - t[j+1])^3 - (t[j+2] - x[index])^3) / 3 / (t[j+2] - t[j+1]) / (t[j+2] - t[j])
index = x > t[j+2]
sigma[j, index] = t[j] - t[1] + (t[j+1] - t[j])^2 / 3 / (t[j+2] - t[j]) + (t[j+2] - t[j+1]) * (t[j+1] - t[j]) / (t[j+2] - t[j]) + (t[j+2] - t[j+1])^2 / 3 / (t[j+2] - t[j])
}
index = x >= t[1] & x <= t[2]
sigma[k+1, index] = -(t[2] - x[index])^3 / 3 / (t[2] - t[1])^2
index = x > t[2]
sigma[k+1, index] = 0
index = x >= t[1] & x <= t[k+1]
sigma[k+2, index] = x[index] - t[1]
index = x > t[k+1] & x <= t[k+2]
sigma[k+2, index] = t[k+1] - t[1] + ((t[k+2] - t[k+1])^2 * (x[index] - t[k+1]) - (x[index] - t[k+1])^3 / 3) / (t[k+2] - t[k+1])^2
ms = NULL
if (!interp) {
xm = cbind(1:n*0+1, x)
pm = xm %*% solve(t(xm) %*% xm) %*% t(xm)
ms = matrix(0, nrow = nrow(sigma), ncol = ncol(sigma))
for (i in 1:m) {
ms[i,] = pm %*% sigma[i,]
ms[i,] = ms[i, rank(xs)]
sigma[i,] = sigma[i,] - pm %*% sigma[i,]
sigma[i,] = sigma[i, rank(xs)]
}
} else {
for (i in 1:m) {
#sigma[i,] = sigma[i,] - pm %*% sigma[i,]
sigma[i,] = sigma[i, rank(xs)]
}
}
rslt = list(sigma = sigma, ms = ms)
rslt
}
########################################################
# Increasing and Convex
incconvex = function(xs, t, interp = FALSE) {
#xs = (xs - min(xs)) / (max(xs) - min(xs))
x = sort(xs)
n = length(x)
k = length(t) - 2
m = k + 3
sigma = matrix(0, nrow = m, ncol = n)
obs = 1:n
#knt = 1:(k+2)
#for (i in 1:(k+2)) {knt[i] = min(obs[abs(x - t[i]) == min(abs(x - t[i]))])}
for (j in 1:(k-1)) {
index = x >= t[1] & x <= t[j]
sigma[j, index] = 0
index = x > t[j] & x <= t[j+1]
sigma[j, index] = (x[index] - t[j])^3 / (t[j+2] - t[j]) / (t[j+1] - t[j]) / 3
index = x > t[j+1] & x <= t[j+2]
sigma[j, index] = x[index] - t[j+1] - (x[index] - t[j+2])^3 / (t[j+2] - t[j]) / (t[j+2] - t[j+1]) / 3 + (t[j+1] - t[j])^2 / 3 /(t[j+2] - t[j]) - (t[j+2] - t[j+1])^2 / 3 / (t[j+2] - t[j])
index = x > t[j+2]
sigma[j, index] = (x[index] - t[j+1]) + (t[j+1] - t[j])^2 / 3 / (t[j+2] - t[j]) - (t[j+2] - t[j+1])^2 / 3 / (t[j+2] - t[j])
}
index = x >= t[1] & x <= t[k]
sigma[k, index] = 0
index = x > t[k] & x <= t[k+1]
sigma[k, index] = (x[index] - t[k])^3 / (t[k+2] - t[k]) / (t[k+1] - t[k]) / 3
index = x > t[k+1] & x <= t[k+2]
sigma[k, index] = x[index] - t[k+1] - (x[index] - t[k+2])^3 / (t[k+2] - t[k]) / (t[k+2] - t[k+1]) / 3 + (t[k+1] - t[k])^2 / 3 / (t[k+2] - t[k]) - (t[k+2] - t[k+1])^2 / 3 / (t[k+2] - t[k])
index = x >= t[1] & x <= t[2]
sigma[k+1, index] = x[index] - t[1] + (t[2] - x[index])^3 / (t[2] - t[1])^2 / 3 - (t[2] - t[1]) / 3
index = x > t[2]
sigma[k+1, index] = x[index] - t[1] - (t[2] - t[1]) / 3
index = x >= t[1] & x <= t[k+1]
sigma[k+2, index] = 0
index = x > t[k+1] & x <= t[k+2]
sigma[k+2, index] = (x[index] - t[k+1])^3 / (t[k+2] - t[k+1])^2 / 3
sigma[k+3,] = x
ms = NULL
if (!interp) {
ms = apply(sigma, 1, mean)
for (i in 1:m) {
sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
} else {
for (i in 1:m) {
#sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
}
rslt = list(sigma = sigma, ms = ms)
rslt
}
########################################################
# Increasing and Concave
incconcave = function(xs, t, interp = FALSE) {
#xs = (xs - min(xs)) / (max(xs) - min(xs))
x = sort(xs)
n = length(x)
k = length(t) - 2
m = k + 3
sigma = matrix(0, nrow = m, ncol = n)
obs = 1:n
#knt = 1:(k+2)
#for(i in 1:(k+2)) {knt[i] = min(obs[abs(x - t[i]) == min(abs(x - t[i]))])}
for (j in 1:k) {
index = x >= t[1] & x <= t[j]
sigma[j, index] = x[index] - t[1]
index = x > t[j] & x <= t[j+1]
sigma[j, index] = t[j] - t[1] + ((t[j+1] - t[j])^3 - (t[j+1] - x[index])^3) / 3 / (t[j+1] - t[j]) / (t[j+2] - t[j]) + (x[index] - t[j]) * (t[j+2] - t[j+1]) / (t[j+2] - t[j])
index = x > t[j+1] & x <= t[j+2]
sigma[j, index] = t[j] - t[1] + (t[j+1] - t[j])^2 / 3 / (t[j+2] - t[j]) + (t[j+2] - t[j+1]) * (t[j+1] - t[j]) / (t[j+2] - t[j]) + ((t[j+2] - t[j+1])^3 - (t[j+2] - x[index])^3) / 3 / (t[j+2] - t[j+1]) / (t[j+2] - t[j])
index = x > t[j+2]
sigma[j, index] = t[j] - t[1] + (t[j+1] - t[j])^2 / 3 / (t[j+2] - t[j]) + (t[j+2] - t[j+1]) * (t[j+1] - t[j]) / (t[j+2] - t[j]) + (t[j+2] - t[j+1])^2 / 3 /(t[j+2] - t[j])
}
index = x >= t[1] & x <= t[2]
sigma[k+1, index] = -(t[2] - x[index])^3 / 3 / (t[2] - t[1])^2
index = x > t[2]
sigma[k+1, index] = 0
index = x >= t[1] & x <= t[k+1]
sigma[k+2, index] = x[index] - t[1]
index = x > t[k+1] & x <= t[k+2]
sigma[k+2, index] = t[k+1] - t[1] + ((t[k+2] - t[k+1])^2 * (x[index] - t[k+1]) - (x[index] - t[k+1])^3 / 3) / (t[k+2] - t[k+1])^2
sigma[k+3, ] = x
ms = NULL
if (!interp) {
ms = apply(sigma, 1, mean)
for (i in 1:m) {
sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
} else {
for (i in 1:m) {
#sigma[i,] = sigma[i,] - mean(sigma[i,])
sigma[i,] = sigma[i, rank(xs)]
}
}
rslt = list(sigma = sigma, ms = ms)
rslt
}
##############
#summary.cgam#
##############
summary.cgam <- function(object,...) {
if (!is.null(object$zcoefs)) {
family <- object$family
df.residual <- object$df.residual
wt.iter <- object$wt.iter
coefs <- object$zcoefs
se <- object$se.beta
tval <- coefs / se
pvalbeta <- object$pvals.beta
n <- length(coefs)
sse0 <- object$SSE0
sse1 <- object$SSE1
cic <- object$cic
deviance <- object$deviance
null.deviance <- object$null.deviance
df <- object$df
df.null <- object$df.null
zid <- object$zid
#zid1 <- object$zid1 - 1 - length(shapes)
#zid2 <- object$zid2 - 1 - length(shapes)
#new: zid1, zid2 just index zmat not bigmat
zid1 <- object$zid1
zid2 <- object$zid2
tms <- object$tms
is_param <- object$is_param
is_fac <- object$is_fac
vals <- object$vals
pvs <- object$pvs
s.edf <- object$s.edf
bstats <- object$bstats
if (wt.iter) {
rslt1 <- data.frame("Estimate" = round(coefs, 4), "StdErr" = round(se, 4), "z.value" = round(tval, 4), "p.value" = round(pvalbeta, 4))
rownames(rslt1)[1] <- "(Intercept)"
if (n > 1) {
lzid <- length(zid1)
for (i in 1:lzid) {
pos1 <- zid1[i]; pos2 <- zid2[i]
for (j in pos1:pos2) {
if (!is_param[i]) {
rownames(rslt1)[j + 1] <- paste(attributes(tms)$term.labels[zid[i] - 1], rownames(rslt1)[j + 1], sep = "")
} else {
rownames(rslt1)[j + 1] <- paste(attributes(tms)$term.labels[zid[i] - 1], vals[j], sep = "")
}
}
}
}
rslt1 <- as.matrix(rslt1)
#new:
rslt2 <- NULL
if (!is.null(pvs)) {
rslt2 <- data.frame("edf" = round(s.edf, 4), "mixture of Beta" = round(bstats, 4), "p.value" = round(pvs, 4))
#rownames(rslt2) <- attributes(tms)$term.labels
#debugged: check more
if (!is.null(zid)) {
rownames(rslt2) <- (attributes(tms)$term.labels)[-(zid-1)]
} else {
rownames(rslt2) <- (attributes(tms)$term.labels)
#if (any(object$shapes < 9) & length(pvs) < length(object$shapes)) {
#if (any(object$shapes < 9)) {
# rm_id = which(object$shapes < 9)
# rownames(rslt2) <- (attributes(tms)$term.labels)[-rm_id]
#} else {
# rownames(rslt2) <- (attributes(tms)$term.labels)
#}
}
}
} else {
rslt1 <- data.frame("Estimate" = round(coefs, 4), "StdErr" = round(se, 4), "t.value" = round(tval, 4), "p.value" = round(pvalbeta, 4))
rownames(rslt1)[1] <- "(Intercept)"
if (n > 1) {
lzid <- length(zid1)
for (i in 1:lzid) {
pos1 <- zid1[i]; pos2 <- zid2[i];
for (j in pos1:pos2) {
if (!is_param[i]) {
rownames(rslt1)[j + 1] <- paste(attributes(tms)$term.labels[zid[i] - 1], rownames(rslt1)[j + 1], sep = "")
} else {
rownames(rslt1)[j + 1] <- paste(attributes(tms)$term.labels[zid[i] - 1], vals[j], sep = "")
}
}
}
}
rslt1 <- as.matrix(rslt1)
rslt2 <- NULL
if (!is.null(pvs)) {
rslt2 <- data.frame("edf" = round(s.edf, 4), "mixture of Beta" = round(bstats, 4), "p.value" = round(pvs, 4))
#debugged: check more
if (!is.null(zid)) {
rownames(rslt2) <- (attributes(tms)$term.labels)[-(zid-1)]
} else {
#new: remove the group name for cgamm
if(inherits(object, "cgamm")){
rownames(rslt2) <- rev(rev((attributes(tms)$term.labels))[-1])
} else {
rownames(rslt2) <- (attributes(tms)$term.labels)
}
#if (any(object$shapes < 9) & length(pvs) < length(object$shapes)) {
#if (any(object$shapes < 9)) {
# rm_id = which(object$shapes < 9)
# rownames(rslt2) <- (attributes(tms)$term.labels)[-rm_id]
#} else {
# rownames(rslt2) <- (attributes(tms)$term.labels)
#}
}
}
}
#if (!is.null(sse0) & !is.null(sse1)) {
#rslt2 <- cbind(SSE.Linear = sse0, SSE.Full = sse1)
#new:
# rslt2 <- data.frame("SSE.Linear" = sse0, "SSE.Full" = sse1)
# rownames(rslt2)[1] <- ""
# ans <- list(call = object$call, coefficients = rslt1, residuals = rslt2, zcoefs = coefs, cic = cic, null.deviance = null.deviance, df.null = df.null, deviance = deviance, df = df, df.residual = df.residual, family = family)
# class(ans) <- "summary.cgam"
# ans
#} else {
ans <- list(call = object$call, coefficients = rslt1, coefficients2 = rslt2,
zcoefs = coefs, cic = cic, null.deviance = null.deviance, df.null = df.null,
deviance = deviance, df = df, df.residual = df.residual, family = family)
class(ans) <- "summary.cgam"
ans
#}
} else {
ans <- list(zcoefs = object$zcoefs)
class(ans) <- "summary.cgam"
ans
}
}
#############
#summary.wps#
#############
summary.wps <- function(object,...) {
rslt1 <- NULL
rslt2 <- NULL
cic <- NULL
is_param <- object$is_param
is_fac <- object$is_fac
vals <- object$vals
tms <- object$tms
if (!is.null(object$zmat)) {
coefs <- object$zcoefs
se <- object$se.beta
#tval <- object$tz
pvalbeta <- object$pvals.beta
tval <- coefs / se
n <- length(coefs)
#sse0 <- object$SSE0
#sse1 <- object$SSE1
zid <- object$zid
#new: zid1, zid2 just index zmat not bigmat
zid1 <- object$zid1
zid2 <- object$zid2
#tms <- object$tms
#zmat <- object$zmat
#is_mat <- object$is_mat
#new:
cic <- object$cic
rslt1 <- data.frame("Estimate" = round(coefs, 4), "StdErr" = round(se, 4), "t.value" = round(tval, 4), "p.value" = round(pvalbeta, 4))
#rownames(rslt1)[1] <- "(Intercept)"
if (n >= 1) {
lzid <- length(zid1)
for (i in 1:lzid) {
pos1 <- zid1[i]; pos2 <- zid2[i]
for (j in pos1:pos2) {
if (!is_param[i]) {
rownames(rslt1)[j] <- paste(attributes(tms)$term.labels[zid[i] - 1], rownames(rslt1)[j], sep = "")
} else {
rownames(rslt1)[j] <- paste(attributes(tms)$term.labels[zid[i] - 1], vals[j], sep = "")
}
}
}
}
rslt1 <- as.matrix(rslt1)
#ans <- list(call = object$call, coefficients = rslt1, coefficients2 = rslt2, zcoefs = coefs, cic = cic)
#class(ans) <- "summary.wps"
#ans
#}
}
if (!is.null(object$pval)) {
#new:
pval <- object$pval; bval <- object$bval; edf <- object$edfc
if (!is.null(pval)) {
rslt2 <- data.frame("edf" = round(edf, 4), "Beta" = round(bval, 4), "p.value" = round(pval, 4))
#debugged: check more
zid <- object$zid
if (!is.null(zid)) {
rownames(rslt2) <- (attributes(tms)$term.labels)[-(zid-1)]
} else {
rownames(rslt2) <- (attributes(tms)$term.labels)
}
}
}
ans <- list(call = object$call, coefficients = rslt1, coefficients2 = rslt2, cic = cic)
class(ans) <- "summary.wps"
ans
}
#####################
#print.cgam #
#####################
print.cgam = function (x, ...)
{
print(x$family)
cat("Call:\n")
print(x$call)
cat("\n")
if(!is.null(x$deviance)) {
cat("Null deviance: ",round(x$null.deviance,4), "", "on", x$df.null, "", "degrees of freedom", "\n")
cat("Residual deviance: ",round(x$deviance,4), "", "on", x$df.residual, "", "observed degrees of freedom", "\n")
}
if (!is.null(x$cic)) {
cat("CIC: ", round(x$cic,4))
}
invisible(x)
}
#####################
#print.summary.cgam #
#####################
print.summary.cgam <- function(x,...) {
if (!is.null(x$zcoefs)) {
#if (!is.null(x$se.beta)) {
cat("Call:\n")
print(x$call)
cat("\n")
cat("Coefficients:")
cat("\n")
printCoefmat(x$coefficients, P.values = TRUE, has.Pvalue = TRUE)
cat("\n")
if (x$family$family == "binomial") {
cat("(Dispersion parameter for binomial family taken to be 1)", "\n")
}
if (x$family$family == "poisson") {
cat("(Dispersion parameter for poisson family taken to be 1)", "\n")
}
if (x$family$family == "gaussian") {
cat("(Dispersion parameter for gaussian family taken to be ", round(x$deviance/x$df,4),")","\n", sep="")
}
cat("\n")
cat("Null deviance: ",round(x$null.deviance,4), "", "on", x$df.null, "", "degrees of freedom", "\n")
cat("Residual deviance: ",round(x$deviance,4), "", "on", x$df.residual, "", "observed degrees of freedom", "\n")
#if (is.null(x$cic)) {
# message("CIC value is not available when there is no shape-restricted predictor")
#} else {message("CIC: ", round(x$cic,4))}
if (!is.null(x$coefficients2)) {
cat("\n")
#cat("Approximate significance of smooth terms: \n")
cat("Approximate significance of constrained components: \n")
printCoefmat(x$coefficients2, P.values = TRUE, has.Pvalue = TRUE)
}
if (!is.null(x$cic)) {
cat("CIC: ", round(x$cic,4))
}
#if (!is.null(x$residuals)) {
# cat("==============================================================", "\n")
# cat("Call:\n")
# print(x$call)
# cat("\n")
# printCoefmat(x$residuals, P.values = TRUE, has.Pvalue = TRUE)
#}
} else {
print ("No linear predictor is defined")
#print ("Residual degree of freedom is negative!")
}
}
####################
#print.summary.wps #
####################
print.summary.wps <- function(x,...) {
if (!is.null(x$coefficients)) {
#if (!is.null(x$se.beta)) {
cat("Call:\n")
print(x$call)
cat("\n")
cat("Coefficients:")
cat("\n")
printCoefmat(x$coefficients, P.values = TRUE, has.Pvalue = TRUE)
cat("\n")
if (!is.null(x$cic)) {
cat("CIC: ", round(x$cic,4), "\n", sep = "")
}
}
if (!is.null(x$coefficients2)) {
cat("\n")
cat("Approximate significance of constrained surface component: \n")
printCoefmat(x$coefficients2, P.values = TRUE, has.Pvalue = TRUE)
}
}
##############
#predict.cgam#
##############
predict.cgam = function(object, newdata, interval = c("none", "confidence", "prediction"), type = c("response", "link"), level = 0.95, n.mix = 500,...) {
#print (is.data.frame(newData))
#print (newData)
#new:
#easy fix...avoid errors in this complicated function...
newData = newdata
family = object$family
cicfamily = CicFamily(family)
muhat.fun = cicfamily$muhat.fun
if (!inherits(object, "cgam")) {
warning("calling predict.cgam(<fake-cgam-object>) ...")
}
if (missing(newData) || is.null(newData)) {
#if (missing(newData)) {
etahat = object$etahat
muhat = muhat.fun(etahat, fml = family$family)
#ans = list(fit = muhat, etahat = etahat, newbigmat = object$bigmat)
ans = list(fit = muhat)
return (ans)
}
if (!is.data.frame(newData)) {
#newData = as.data.frame(newData)
stop ("newData must be a data frame!")
}
#shapes = object$shapes
#new: used for ci
prior.w = object$prior.w
vh = object$vh
y = object$y
#new: only use shapes for x != umb or tree
shapes = object$shapesx
np = object$d0; capm = object$capm; capms = object$capms; capk = object$capk; capt = object$capt; capu = object$capu
#new:
xid10 = object$xid1; xid20 = object$xid2;
uid1 = object$uid1; uid2 = object$uid2; tid1 = object$tid1; tid2 = object$tid2
#new:
xmat0 = object$xmat0; knots0 = object$knots0; numknots0 = object$numknots0; sps0 = object$sps0; ms0 = object$ms0
zmat = object$zmat; umb = object$umb; tr = object$tr
#new:
ztb = object$ztb; zid1 = object$zid1; zid2 = object$zid2; iz = 1
bigmat = object$bigmat; umbrella.delta = object$umbrella.delta; tree.delta = object$tree.delta
coefs = object$coefs; zcoefs = object$zcoefs; vcoefs = object$vcoefs; xcoefs0 = object$xcoefs; ucoefs = object$ucoefs; tcoefs = object$tcoefs
tt = object$tms
Terms = delete.response(tt)
#model.frame will re-organize newData in the original order in formula
m = model.frame(Terms, newData)
#print (m)
newdata = m
#print (head(newdata))
#new:
newx0 = NULL; newxv = NULL; newx = NULL; newx_s = NULL; newu = NULL; newt = NULL; newz = NULL; newv = NULL
#newz = list(); iz = 1;
rn = nrow(newdata)
#print (rn)
#new:
newetahat = 0; newmuhat = 0
#new: newx_sbasis
newxbasis = NULL; newx_sbasis = NULL; newubasis = NULL; newtbasis = NULL; newbigmat = NULL
#######################
#local helper function#
#######################
my_line = function(xp = NULL, y, x, end, start) {
slope = NULL
intercept = NULL
yp = NULL
slope = (y[end] - y[start]) / (x[end] - x[start])
intercept = y[end] - slope * x[end]
yp = intercept + slope * xp
ans = new.env()
ans$slope = slope
ans$intercept = intercept
ans$yp = yp
ans
}
#get shape attributes and elem out of newdata
for (i in 1:ncol(newdata)) {
if (is.null(attributes(newdata[,i])$shape)) {
if (is.factor(newdata[,i])) {
lvli = levels(newdata[,i])
ztbi = levels(ztb[[iz]])
newdatai = NULL
if (!any(lvli %in% ztbi)) {
stop ("new factor level must be among factor levels in the fit!")
} else {
id1 = which(ztbi %in% lvli)
#if (any(id1 > 1)) {
#delete the base level
klvls = length(ztbi)
if (klvls > 1) {
newimat = matrix(0, nrow = rn, ncol = klvls-1)
for (i1 in 1:rn) {
if (newdata[i1,i] != ztbi[1]) {
id_col = which(ztbi %in% newdata[i1,i]) - 1
newimat[i1,id_col] = 1
}
}
#for (i1 in 1: klvls) {
# which(levels(newdatai) == ztbi[i1])
# for (i2 in 1:rn) {
# if (levels(newdatai[i2, i1]) == lvli[i2]) {
# if (lvli[i2] != ztbi[1]) {
# newimat[i2, i1] = 1
# }
# }
# }
#}
#ztb_use = ztbi[-1]
#nc = length(id1[id1 > 1])
#newdatai = matrix(0, nrow = rn, ncol = nc)
#for (ic in 1:nc) {
# id2 = which(newdata[,i] == ztb_use[ic])
# newdatai[id2, ic] = 1
#}
newdatai = newimat
}
}
#if (length(levels(newdata[,i])) > 2) {
# klvls = length(levels(newdata[,i]))
# vals = as.numeric(levels(newdata[,i]))
# newimat = matrix(0, nrow = rn, ncol = klvls - 1)
# for (i1 in 1: (klvls - 1)) {
# for (i2 in 1:rn) {
# if (newdatai[i2] == vals[i1 + 1]) {
# newimat[i2, i1] = 1
# }
# }
# }
# newdatai = newimat
#}
} else {
newdatai = newdata[,i]
}
newz = cbind(newz, newdatai)
iz = iz + 1
#print (head(newz))
}
if (is.numeric(attributes(newdata[,i])$shape)) {
newx0 = cbind(newx0, newdata[,i])
if ((attributes(newdata[,i])$shape > 2 & attributes(newdata[,i])$shape < 5) | (attributes(newdata[,i])$shape > 10 & attributes(newdata[,i])$shape < 13)) {
newxv = cbind(newxv, newdata[,i])
}
}
if (is.character(attributes(newdata[,i])$shape)) {
if (attributes(newdata[,i])$shape == "tree") {
newt = cbind(newt, newdata[,i])
}
if (attributes(newdata[,i])$shape == "umbrella") {
newu = cbind(newu, newdata[,i])
}
}
}
#print (head(newt))
#print (head(newu))
#print (head(newx0))
#print (head(newxv))
#print (head(newz))
#print (head(newv))
#new: separate x and x_s, move shape 17 to the beginning
idx_s <- NULL
if (!is.null(shapes)) {
if (any(shapes == 17)) {
kshapes <- length(shapes)
obs <- 1:kshapes
idx_s <- obs[which(shapes == 17)]; idx <- obs[which(shapes != 17)]
newx1 <- newx0
shapes0 <- 1:kshapes*0
newx1[,1:length(idx_s)] <- newx0[,idx_s]
shapes0[1:length(idx_s)] <- shapes[idx_s]
if (length(idx) > 0) {
newx1[,(1 + length(idx_s)):kshapes] <- newx0[,idx]
shapes0[(1 + length(idx_s)):kshapes] <- shapes[idx]
}
newx0 <- newx1; shapes <- shapes0
}
#new:xmat is ordinal, xmat_s is smooth
xmat = xmat_s = NULL
newx = newx_s = NULL
knots = NULL
ms_x = ms = NULL
sh_x = sh = NULL
if (all(shapes < 9)) {
newx = newx0
xid1 = xid10; xid2 = xid20
xmat = xmat0
#new:
sh_x = shapes
ms_x = ms0
} else if (all(shapes > 8)) {
newx_s = newx0
xid1_s = xid10; xid2_s = xid20
xmat_s = xmat0
numknots = numknots0
knots = knots0
sps = sps0
sh = shapes
ms = ms0
} else if (any(shapes > 8) & any(shapes < 9)) {
newx = newx0[, shapes < 9, drop = FALSE]
xmat = xmat0[, shapes < 9, drop = FALSE]
#new:
sh_x = shapes[shapes < 9]
ms_x = ms0[shapes < 9]
xid1 = xid10[shapes < 9]; xid2 = xid20[shapes < 9]
newx_s = newx0[, shapes > 8, drop = FALSE]
xmat_s = xmat0[, shapes > 8, drop = FALSE]
sh = shapes[shapes > 8]
ms = ms0[shapes > 8]
xid1_s = xid10[shapes > 8]; xid2_s = xid20[shapes > 8]
numknots = numknots0[shapes > 8]
knots = knots0[shapes > 8]
sps = sps0[shapes > 8]
}
}
#if (!is.null(shapes) & any(shapes == 17)) {
if (!is.null(shapes)) {
vcoefs = vcoefs[1:(1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13))]
} else {vcoefs = vcoefs[1:(1 + capk)]}
if (capk > 0) {
vcoefs_nz = vcoefs[-c(2:(1 + capk))]
} else {vcoefs_nz = vcoefs}
newv = cbind(1:rn*0 + 1, newz, newxv)
newv_nz = cbind(1:rn*0 + 1, newxv)
#print (newv_nz)
#print (vcoefs)
#etahat_v = as.vector(newv %*% vcoefs)
etahat_v_nz = as.vector(newv_nz %*% vcoefs_nz)
#print (etahat_v_nz)
#new:
etahat_s = 1:rn*0; newx_sbasis = NULL; xs_coefs = NULL; var_xs = NULL
if (!is.null(newx_s)) {
ks = ncol(newx_s)
del = NULL
for (i in 1:ks) {
xi = xmat_s[,i]
nxi = newx_s[,i]
if (any(nxi > max(xi)) | any(nxi < min(xi))) {
stop ("No extrapolation is allowed in cgam prediction!")
}
#new: scale accordingly
#nxi = (nxi - min(xi)) / (max(xi) - min(xi))
pos1 = xid1_s[i] - (1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13))
pos2 = xid2_s[i] - (1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13))
xs_coefs = c(xs_coefs, xcoefs0[pos1:pos2])
msi = ms[[i]]
deli_ans = makedelta(nxi, sh[i], numknots[i], knots[[i]], space = sps[i], suppre = TRUE, interp = TRUE)
deli = deli_ans$amat
if (sh[i] > 10 & sh[i] < 13) {
#x = xmat_s[,i]
xs = sort(xi)
ord = order(xi)
nx = length(xi)
obs = 1:nx
nr = nrow(deli)
nc = length(nxi)
ms2 = matrix(0, nrow = nr, ncol = nc)
for (i1 in 1:nc) {
for (i2 in 1:nr) {
ms2[i2, i1] = my_line(xp = nxi[i1], y = msi[i2, ][ord], x = xs, end = nx, start = 1)$yp
}
}
deli = deli - ms2
} else {
deli = deli - msi
}
#new:
var_xs = c(var_xs, 1:nrow(deli)*0 + i)
del = rbind(del, deli)
}
newx_sbasis = t(del)
etahat_s = as.vector(newx_sbasis %*% xs_coefs)
}
etahat_x = 1:rn*0; newxbasis = NULL; xcoefs = NULL; var_x = NULL
if (!is.null(newx)) {
kx = ncol(xmat)
del = NULL
for (i in 1:kx) {
xi = xmat[,i]
#new:
nxi = newx[,i]
if (any(nxi > max(xi)) | any(nxi < min(xi))) {
stop ("No extrapolation is allowed in cgam prediction!")
}
#new: scale accordingly
#nxi = (nxi - min(xi)) / (max(xi) - min(xi))
shi = sh_x[i]
pos1 = xid1[i] - (1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13))
pos2 = xid2[i] - (1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13))
xcoefs = c(xcoefs, xcoefs0[pos1:pos2])
deli = pred_del(xi, shi, nxi, ms_x[[i]])
#new:
var_x = c(var_x, 1:nrow(deli)*0 + i)
del = rbind(del, deli)
}
#new:
newxbasis = t(del)
etahat_x = as.vector(newxbasis %*% xcoefs)
}
#new:
etahat_u = 1:rn*0; newuedge = NULL
if (!is.null(newu)) {
for (j in 1:ncol(umb)) {
u = umb[,j]
nu = length(u)
us = sort(u)
ord = order(u)
if (any(newu[,j] > max(u)) | any(newu[,j] < min(u))) {
stop ("no extrapolation is allowed in cgam!")
}
#u_edges = t(umbrella.fun(u))
pos1 = uid1[j]; pos2 = uid2[j]
u_edges = t(bigmat[pos1:pos2, , drop = FALSE])
nuedge = ncol(u_edges)
newuedge0 = matrix(0, nrow = rn, ncol = nuedge)
for (i in 1:nuedge) {
ue = u_edges[,i]; udist = round(diff(ue), 4); s = sign(udist)
ueord = ue[ord]; udistord = round(diff(ueord), 4); sord = sign(udistord)
obs = 1:(nu-1)
posin = obs[sord != 0] + 1
pos = unique(c(1, posin, nu))
uk = us[pos]
uek = ueord[pos]
npos = length(pos)
nd = length(newu[,j])
for (l in 1:(npos-1)) {
if (any(newu[,j] == uk[npos])) {
ids = which(newu[,j] == uk[npos])
newuedge0[ids,i] = uek[npos]
}
if (any(newu[,j] >= uk[l]) & any(newu[,j] < uk[l+1])) {
ids = which(newu[,j] >= uk[l] & newu[,j] < uk[l+1])
newuedge0[ids,i] = uek[l]
}
}
}
newuedge = cbind(newuedge, newuedge0)
}
newubasis = newuedge
etahat_u = as.vector(newubasis %*% ucoefs)
}
# we don't have a newtbasis
# estimate tree
etahat_t = 1:rn*0
#print (newt)
if (!is.null(newt)) {
#each column of tru is a "table" of all levels of a tree var
tru = unique(tr)#; placebo = min(tru)
#tr_etahat = 0
for (i in 1: ncol(newt)) {
pos1 = tid1[i] - np - capm - capu
pos2 = tid2[i] - np - capm - capu
newtu = unique(newt[,i])
#tcoefi = tcoefs[pos1:pos2]
#check! add 0 to be the coef for placebo
tcoefi = c(0, tcoefs[pos1:pos2])
if (!all(newtu %in% tru[,i])) {
stop ("new tree ordering factor must be among the old tree ordering factors!")
}
#placebo = min(tru[,i])
#new:
placebo = object$pl[i]
if (any(newtu != placebo)) {
#id_cf = which(tru[,i] %in% newtu) - 1 #no coef for placebo
#tr_etahat = tr_etahat + tcoefi[id_cf]
#id_cf = which(newtu > placebo)
id_cf = which(newtu != placebo)
t_use = newtu[id_cf]
nt = length(t_use)
for (it in 1:nt) {
etahat_t[newt[,i] == t_use[it]] = etahat_t[newt[,i] == t_use[it]] + tcoefi[tru[,i] == t_use[it]]
}
}
}
#etahat_t = tr_etahat
}
#print (etahat_v)
#print (etahat_s)
#print (etahat_x)
#print (etahat_u)
#print (etahat_t)
etahat_z = 1:rn*0; zcf = NULL
#print (newt)
#print (newdata)
if (!is.null(newz)) {
#delete the coef for 1
zcoefs = zcoefs[-1]
etahat_z = newz %*% zcoefs
#ztbu = unique(ztb)#; placebo = min(ztbu)
#lz = ncol(newz)
#for (i in 1:lz) {
# pos1 = zid1[i]
# pos2 = zid2[i]
# zcoefi = zcoefs[pos1:pos2]
# zlvi = zcoefs[pos1:pos2]
# etahat_z[newz[,i] == 1] = etahat_z[newz[,i] == 1] + zcoefi
#}
}
#print (etahat_z)
etahat_v = etahat_v_nz + etahat_z
newetahat = etahat_v + etahat_s + etahat_x + etahat_u + etahat_t
newmuhat = as.vector(muhat.fun(newetahat, fml = family$family))
if (!is.null(newt)) {
newtbasis = t(tree.delta[,1:nrow(newData),drop = FALSE])
}
#print (newv)
#newbigmat = t(cbind(newv, newx_sbasis, newxbasis, newubasis, newtbasis))
#ans = list(v = newv, xbs = newxbasis, x_sbs = newx_sbasis, ubs = newubasis, tbs = newtbasis, bigmat = newbigmat, vcoefs = vcoefs, xcoefs = xcoefs, xs_coefs = xs_coefs, ucoefs = ucoefs, etahat = newetahat, muhat = newmuhat)
#ans = list(muhat = newmuhat)
#muhat = newmuhat
if ("none" %in% interval) {
ans = list(fit = newmuhat, object = object)
#new: add prediction interval
} else if (interval == "confidence" | interval == "prediction") {
n = ncol(bigmat)
nc = ncol(xmat0)
spl = splpr = NULL
m_acc = 0
object$ms0 -> ms0
#sh = 17 first
object$shapesx0 -> shapes
#new:
varlist = NULL
for (i in 1:nc) {
msi = ms0[[i]]
shpi = shapes[i]
ki = knots0[[i]]
xi = xmat0[,i]
xipr = newx0[,i]
deli = makedelta(xi, shpi, knots = ki)
#print (i)
#if (i == 2) {
# stop (print (msi))
#}
spli = deli$amat
varlist = c(varlist, rep(i, nrow(spli)))
if (shpi >= 9) {
dpri = makedelta(xipr, shpi, knots = ki, suppre = TRUE, interp = TRUE)
splpri = dpri$amat
if (shpi > 10 & shpi < 13) {
xs = sort(xi)
ord = order(xi)
#nx = length(xi)
#nx is n
obs = 1:n
nr = nrow(splpri)
#nc = length(xipr)
#rn is the length of a new vector
ms2 = matrix(0, nrow = nr, ncol = rn)
for (i1 in 1:rn) {
for (i2 in 1:nr) {
ms2[i2, i1] = my_line(xp = xipr[i1], y = msi[i2, ][ord], x = xs, end = n, start = 1)$yp
}
}
splpri = splpri - ms2
} else {
splpri = splpri - msi
}
} else {splpri = pred_del(xi, shpi, xipr, msi)}
mi = dim(spli)[1]
m_acc = m_acc + mi
spl = rbind(spl, spli)
splpr = rbind(splpr, splpri)
}
capk = object$capk
p = 1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13)
zmat = t(bigmat[1:p, ,drop = FALSE])
if (family$family == "gaussian") {
#nloop = 1000
nloop = n.mix
#nsec will be too big for ordinal, ignore for now
nsec = 2^m_acc
#print (dim(zmat))
if (is.null(prior.w)) {
prior.w = rep(1, n)
}
if (!all(prior.w == 1)) {
for (i in 1:n) {
spl[,i] = spl[,i] * sqrt(prior.w[i])
zmat[i,] = zmat[i,] * sqrt(prior.w[i])
}
}
if (!is.null(vh)) {
wvec = 1/vh
} else if (is.null(vh) & !is.null(prior.w)) {
wvec = prior.w
} else if (is.null(vh) & is.null(prior.w)) {
wvec = rep(1, n)
}
if (!all(wvec == 1)) {
for (i in 1:n) {
spl[,i] = spl[,i] * sqrt(wvec[i])
zmat[i,] = zmat[i,] * sqrt(wvec[i])
}
}
yw = y * sqrt(wvec)
#ans1 = coneB(yw, spl, zmat)
ans1 = coneB(yw, t(spl), zmat)
face = ans1$face
muhat = ans1$yhat
#muhat = object$muhat
muhat0 = muhat / sqrt(wvec)
#muhat0 = object$muhat
#muhat = muhat0 * sqrt(prior.w)
#print (ans1$df)
#print (ans1$coef)
sighat = sqrt(sum((yw - muhat)^2) / (n - 1.5*ans1$df)) ## varest is too large but "conservative"
#sighat = sqrt(sum((yw - muhat)^2) / (n - 1.5*object$df_obs))
nv = p
## estimate sector probabilties
#set.seed(1)
#sector = Matrix(1:nsec*0,nrow=1)
#sector = big.matrix(1:nsec*0,nrow=1)
#sector = 1:nsec*0
#for (iloop in 1:nloop) {
# ysim = muhat0 + rnorm(n)*sighat
# ysim = ysim * sqrt(wvec)
# #ans = coneB(ysim, spl, zmat)
# ans = coneB(ysim, t(spl), zmat, face = face)
# cf = round(ans$coefs[(nv+1):(m_acc+nv)], 10)
# sec = 1:m_acc*0
# sec[cf > 0] = 1
# r = makebin(sec) + 1
# sector[r] = sector[r] + 1
#}
### calculate the mixture hat matrix:
#bsec = matrix(0, nrow=nsec,ncol=2)
#bsec[,1] = 1:nsec
#bsec[,2] = sector / nsec
#keep = sector > 0
#bsec = bsec[keep,]
#ns = dim(bsec)[1]
#bsec[,2] = bsec[,2] / sum(bsec[,2])
#new: not use sector = 1:nsec*0; simulate for 1,000 times and record the faces used more than once
# if times / nloop < 1e-3, then delete
sector = NULL
times = NULL
df = NULL
#first column shows sector; second column shows times
for (iloop in 1:nloop) {
ysim = muhat0 + rnorm(n)*sighat
ysim = ysim * sqrt(prior.w)
ans = coneB(ysim, t(spl), zmat, face = face)
cf = round(ans$coefs[(nv+1):(m_acc+nv)], 10)
sec = 1:m_acc*0
sec[cf > 0] = 1
sector = rbind(sector, sec)
r = makebin(sec) + 1
#sector[r] = sector[r] + 1
if (iloop == 1) {
df = rbind(df, c(r, 1))
} else {
if (r %in% df[,1]) {
ps = which(df[,1] %in% r)
df[ps,2] = df[ps,2] + 1
} else {
df = rbind(df, c(r, 1))
}
}
}
#remove times/sum(times) < 1e-3??
sm_id = which((df[,2]/nloop) < 1e-3)
if (any(sm_id)) {
df = df[-sm_id, ,drop=FALSE]
}
#new:
ns = nrow(df)
bsec = df
bsec[,2] = bsec[,2] / sum(bsec[,2])
ord = order(bsec[,1])
bsec = bsec[ord, ,drop=FALSE]
### calculate the mixture cov(alpha) matrix:
obs = 1:m_acc;oobs = 1:(m_acc+nv)
acov = matrix(0, nrow = m_acc+nv, ncol = m_acc+nv)
for (is in 1:ns) {
if (bsec[is,2] > 0) {
jvec = getbin(bsec[is,1], m_acc)
if (sum(jvec) == 1) {
smat = cbind(zmat, spl[which(jvec==1),])
} else if (sum(jvec) == 0) {
smat = zmat
} else {
smat = cbind(zmat, t(spl[which(jvec==1),]))
}
acov1 = bsec[is,2]*solve(t(smat)%*%smat)
acov2 = matrix(0,nrow=m_acc+nv,ncol=m_acc+nv)
jobs = 1:(m_acc+nv)>0
jm = 1:m_acc>0
jm[obs[jvec==0]] = FALSE
jobs[(nv+1):(m_acc+nv)] = jm
nobs = oobs[jobs==TRUE]
for (i in 1:sum(jobs)) {
acov2[nobs[i],jobs] = acov1[i,]
}
acov = acov+acov2
}
}
acov = acov*sighat^2
#only xmatpr and splpr have interpolation points
xmatpr = cbind(newv, t(splpr))
#muhatpr = xmatpr %*% ans1$coefs
#temp:
muhatpr = xmatpr %*% object$coefs[1:ncol(xmatpr), ,drop=FALSE]
#new: C.I. level
mult = qnorm((1 - level)/2, lower.tail=FALSE)
#hl = 2*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
if (interval == "confidence") {
hl = mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
}
if (interval == "prediction") {
hl = mult*sqrt(sighat^2+diag(xmatpr%*%acov%*%t(xmatpr)))
}
#ans = list(fit = muhatpr, lower = muhatpr - hl, upper = muhatpr + hl)
} else {
## initialize
m = nrow(bigmat)
#amat is different from the original code, because we put zmat at the first p columns in cgam
#amat = matrix(0, nrow = (m-p), ncol = m)
#for(i in (p+1):m){amat[i,i]=1}
#the constraint is amat%*%bh >= 0; not constrain vmat
amat = diag(m-p)
zerom = matrix(0, nrow=nrow(amat), ncol=p)
amat = cbind(zerom, amat)
#alp0 = 1:m*0
#eta0 = del%*%alp0
#eta0 = 1:n*0
#mu0 = 1:n*0 + 0.5
z = 1:n*0
## get the dimension of the face
deltil = t(bigmat)
w = object$wt
#print (any(w < 0))
for(i in 1:m){deltil[,i]=deltil[,i]*sqrt(w)}
umat = chol(crossprod(deltil))
uinv = solve(umat)
atil = amat%*%uinv
bh = coef(object)
#check
etahat = object$etahat
muhat = fitted(object)
#z = etahat + (y - muhat)/muhat/(1-muhat)
#ch = muhat > 1e-5 & muhat < 1-(1e-5)
#z[ch] = etahat[ch] + (y[ch]-muhat[ch])/muhat[ch]/(1-muhat[ch])
#z[!ch] = etahat[!ch]
#w[ch] = muhat[ch]*(1-muhat[ch])
#w[!ch] = 1e-5
#z=eta0+(y-mu0)/mu0/(1-mu0)
ch = muhat > 1e-5 & muhat < 1-(1e-5)
z[ch] = etahat[ch] + (y[ch]-muhat[ch])/muhat[ch]/(1-muhat[ch])
z[!ch] = etahat[!ch]
w[ch] = muhat[ch]*(1-muhat[ch])
w[!ch] = 1e-5
ztil = z*sqrt(w)
#z = etahat + (y - muhat) / family$variance(muhat)
#print (family$variance(muhat)): sometimes give a value that is almost zero and it creates NA in thhat
#ztil = z*sqrt(w)
rw = round(amat%*% bh, 6) == 0
#print (rw)
#print (sum(rw))
if(sum(rw) == 0){
raj = 0
edf = m
} else {
ajc = atil[rw,]
raj = rankMatrix(t(ajc))[1]
edf = min(m, 1.2*(m-raj))
}
## thhat is final cone projection
thhat = deltil %*% bh
#print (thhat)
#print (ztil)
#shat = sum((ztil - thhat)^2)/(n - edf)
#correction: 2/16/2025; shat is always 1.
shat = 1
#print (shat)
nloop = 100
cmat = matrix(0, nrow = m, ncol = m)
imat = diag(m)
for(iloop in 1:nloop){
zsim = thhat + rnorm(n)*shat
zsimtil = t(uinv) %*% t(deltil) %*% zsim
#if (iloop == 1) {
asim = coneA(zsimtil, atil)
# face = asim$face
#} else {
# if (length(face) >= 1) {
# asim = coneA(zsimtil, atil, face = face)
# } else{asim = coneA(zsimtil, atil)}
#}
## get the matrix wm: cols span row space orthogonal to rows of A_J^c
rw = round(atil %*% asim$thetahat, 6) == 0
#print (shat)
#print (rw)
if(sum(rw) == 0){
#pjmat = t(atil) %*% solve(atil %*% t(atil)) %*% atil
#pjmat = t(atil) %*% solve(tcrossprod(atil), atil)
#correction: 2/16/2025;
pjmat = imat
} else {
ajc = atil[rw,]
if(length(ajc) == m){
wm = ajc/sqrt(sum(ajc^2))
wm = matrix(wm, ncol=1)
}else{
aqr = qr(t(ajc))
wm = qr.Q(aqr)[,1:aqr$rank]
}
pjmat = -wm%*%t(wm)
for(i in 1:m){pjmat[i,i] = pjmat[i,i]+1}
}
cmat = cmat + uinv %*% pjmat %*% t(uinv)/nloop
}
cmat = cmat*shat
#coveta = diag(del%*%cmat%*%t(del))
xmatpr = cbind(newv, t(splpr))
#coveta = diag(del%*%cmat%*%t(del))
coveta = diag(xmatpr%*%cmat%*%t(xmatpr))
etapr = xmatpr%*%bh
#muhatpr = 1 - 1/(1+exp(etapr))
muhatpr = family$linkinv(etapr)
#new: C.I. level
mult = qnorm((1 - level)/2, lower.tail=FALSE)
#if (interval == "confidence") {
uppeta = etapr + mult*sqrt(coveta)
loweta = etapr - mult*sqrt(coveta)
uppmu = family$linkinv(uppeta)
lowmu = family$linkinv(loweta)
#uppmu = 1 - 1/(1+exp(uppeta))
#lowmu = 1 - 1/(1+exp(loweta))
#}
}
#new: thvs are for individual c.i. bands and surfaces
#smooth additive terms only, no umbrella or tree
if (family$family == "gaussian") {
dcoefs = object$coefs[(np - capms + 1):(np + capm),,drop=FALSE]
etacomps = object$etacomps
capl = nrow(etacomps)
thvs_upp = thvs_lwr = matrix(0, nrow = capl, ncol = rn)
ncon = 1
# temp: constrained smooth terms covariance
acov2 = acov[-c(1:np),-c(1:np)]
for (i in 1:capl) {
ddi = t(splpr[varlist == i, ,drop=FALSE])
acovi = acov2[varlist == i, varlist == i]
hli = mult*sqrt(diag(ddi %*% acovi %*% t(ddi)))
ei = ddi%*%dcoefs[varlist == i, ,drop=FALSE]
thvs_upp[i,] = ei + hli
thvs_lwr[i,] = ei - hli
}
# order thvs back
if (length(idx_s) > 0) {
thvs0_upp = thvs_upp
thvs0_upp[idx_s,] = thvs_upp[1:length(idx_s), ]
thvs0_lwr = thvs_lwr
thvs0_lwr[idx_s,] = thvs_lwr[1:length(idx_s), ]
if (length(idx) > 0) {
thvs0_upp[idx,] = thvs_upp[(1+length(idx_s)):capl, ]
thvs0_lwr[idx,] = thvs_lwr[(1+length(idx_s)):capl, ]
}
thvs_upp = thvs0_upp
thvs_lwr = thvs0_lwr
}
#new: problem when not gaussian
if (object$sc_y) {
for (i in 1:nrow(thvs_upp)) {
thvs_upp[i,] = thvs_upp[i,] * object$sc
thvs_lwr[i,] = thvs_lwr[i,] * object$sc
}
}
}
#new: NASA's idea for monotonic CI
if (family$family == "gaussian") {
lwr = muhatpr - hl
upp = muhatpr + hl
} else {
lwr = loweta
upp = uppeta
}
#for now, only handles one predictor
if (length(object$shapes) == 1) {
ord = order(newx0) #need a better way for > 1 predictor case
lwr_tmp = lwr[ord]
upp_tmp = upp[ord]
lwr_tmp_u = unique(lwr_tmp)
upp_tmp_u = unique(upp_tmp)
check_ps_lwr = diff(lwr_tmp_u)
check_ps_upp = diff(upp_tmp_u)
if (object$shapes == 9) {
ps_lwr = which(check_ps_lwr < 0)
n_ps_lwr = length(ps_lwr)
if(n_ps_lwr > 0){
#NASA's for loop, the easier way is not working now....
n = length(lwr_tmp)
for(i in 1:(n - 1)){
if(lwr_tmp[i + 1] < lwr_tmp[i]){
lwr_tmp[i + 1] = lwr_tmp[i]
}
}
}
#lwr_tmp[ps_lwr + 1] = lwr_tmp[ps_lwr]
ps_upp = which(check_ps_upp < 0)
n_ps_upp = length(ps_upp)
if(n_ps_upp > 0) {
n = length(upp_tmp)
for(i in (n - 1):1){
if(upp_tmp[i] > upp_tmp[i + 1]){
upp_tmp[i] = upp_tmp[i + 1]
}
}
}
#upp_tmp[ps_upp] = upp_tmp[ps_upp + 1]
}
if (object$shapes == 10) {
ps_lwr = which(check_ps_lwr > 0)
n_ps_lwr = length(ps_lwr)
if(n_ps_lwr > 0){
n = length(lwr_tmp)
for(i in (n - 1):1){
if(lwr_tmp[i] < lwr_tmp[i + 1]){
lwr_tmp[i] = lwr_tmp[i + 1]
}
}
}
#lwr_tmp[ps_lwr] = lwr_tmp[ps_lwr + 1]
ps_upp = which(check_ps_upp > 0)
n_ps_upp = length(ps_upp)
if(n_ps_upp > 0) {
n = length(upp_tmp)
for(i in 1:(n - 1)){
if(upp_tmp[i + 1] > upp_tmp[i]){
upp_tmp[i + 1] = upp_tmp[i]
}
}
}
#upp_tmp[ps_upp + 1] = upp_tmp[ps_upp]
}
lwr = lwr_tmp[order(ord)]
upp = upp_tmp[order(ord)]
#loweta = lwr
#uppeta = upp
#lwr = lwr_tmp
#upp = upp_tmp
}
if ("response" %in% type) {
lwr = family$linkinv(lwr)
upp = family$linkinv(upp)
}
if (family$family == "gaussian") {
ans = list(fit = muhatpr, lower = lwr, upper = upp, acov = acov, object = object, mult = mult, thvs_upp = thvs_upp, thvs_lwr = thvs_lwr)
#ans = list(fit = muhatpr, lower = muhatpr - hl, upper = muhatpr + hl, acov = acov, object = object, mult = mult, thvs_upp = thvs_upp, thvs_lwr = thvs_lwr)
} else { #else if (family$family == "binomial") {
if ("response" %in% type) {
ans = list(fit = muhatpr, lower = lwr, upper = upp, object = object, mult = mult)
#ans = list(fit = muhatpr, lower = lowmu, upper = uppmu, object = object, mult = mult)
} else if ("link" %in% type) {
ans = list(fit = etapr, lower = lwr, upper = upp, object = object, mult = mult)
#ans = list(fit = etapr, lower = loweta, upper = uppeta, object = object, mult = mult)
}
}
}
class(ans) = "cgamp"
return (ans)
}
#############################
#predict delta for ordinal x#
#############################
pred_del = function(x, sh, xp, ms) {
n = length(xp)
#x = (x - min(x)) / (max(x) - min(x))
xu = sort(unique(x))
n1 = length(xu)
sigma = NULL
#######################
#local helper function#
#######################
my_line = function(xp = NULL, y, x, end, start) {
slope = NULL
intercept = NULL
yp = NULL
slope = (y[end] - y[start]) / (x[end] - x[start])
intercept = y[end] - slope * x[end]
yp = intercept + slope * xp
ans = new.env()
ans$slope = slope
ans$intercept = intercept
ans$yp = yp
ans
}
# increasing or decreasing
if (sh < 3) {
sigma = matrix(0, nrow = n1 - 1, ncol = n)
for (i in 1: (n1 - 1)) {
sigma[i, xp > xu[i]] = 1
}
if (sh == 2) {sigma = -sigma}
for (i in 1:(n1 - 1)) {sigma[i, ] = sigma[i, ] - ms[i]}
}
if (sh == 3 | sh == 4) {
# convex or concave
sigma = matrix(0, nrow = n1 - 2, ncol = n)
#for (i in 1: (n1 - 2)) {
# sigma[i, x > xu[i]] = x[x > xu[i]] - xu[i]
#}
for (i in 1: (n1 - 2)) {
sigma[i, xp > xu[i+1]] = xp[xp > xu[i+1]] - xu[i+1]
}
if (sh == 4) {sigma = -sigma}
#xm = cbind(1:n*0+1, xp)
#xpx = solve(t(xm) %*% xm)
#pm = xm %*% xpx %*% t(xm)
#sigma = sigma - sigma %*% t(pm)
xs = sort(x)
ord = order(x)
nx = length(x)
obs = 1:nx
m = nrow(ms)
ms0 = matrix(0, nrow = m, ncol = n)
for (i1 in 1:n) {
for (i2 in 1:m) {
ms0[i2, i1] = my_line(xp = xp[i1], y = ms[i2, ][ord], x = xs, end = nx, start = 1)$yp
}
}
sigma = sigma - ms0
}
if (sh > 4 & sh < 9) {
sigma = matrix(0, nrow = n1 - 1, ncol = n)
if (sh == 5) { ### increasing convex
for (i in 1:(n1 - 1)) {
sigma[i, xp > xu[i]] = (xp[xp > xu[i]] - xu[i]) / (max(x) - xu[i])
}
for (i in 1:(n1 - 1)) {sigma[i,] = sigma[i,] - ms[i]}
} else if (sh == 6) { ## decreasing convex
for (i in 1:(n1 - 1)) {
sigma[i, xp < xu[i + 1]] = (xp[xp < xu[i + 1]] - xu[i + 1]) / (min(x) - xu[i + 1])
}
for (i in 1:(n1 - 1)) {sigma[i,] = sigma[i,] - ms[i]}
#print (ms)
} else if (sh == 7) { ## increasing concave
for (i in 1:(n1 - 1)) {
sigma[i, xp < xu[i + 1]] = (xp[xp < xu[i + 1]] - xu[i + 1]) / (min(x) - xu[i + 1])
}
for (i in 1:(n1 - 1)) {sigma[i,] = -sigma[i,] + ms[i]}
} else if (sh == 8) {## decreasing concave
for (i in 1:(n1 - 1)) {
sigma[i, xp > xu[i]] = (xp[xp > xu[i]] - xu[i]) / (max(x) - xu[i])
}
for (i in 1:(n1 - 1)) {sigma[i,] = -sigma[i,] + ms[i]}
}
}
return (sigma)
}
##############
#predict.wps#
# >= pairs + additive + z
##############
predict.wps = function(object, newData, interval = c("none", "confidence", "prediction"), type = c("response", "link"), level = 0.95, ...) {
#new:
family = object$family
cicfamily = CicFamily(family)
muhat.fun = cicfamily$muhat.fun
if (!inherits(object, "wps")) {
warning("calling predict.wps(<fake-wps-object>) ...")
}
if (missing(newData) || is.null(newData)) {
#if (missing(newData)) {
#etahat = object$etahat
#muhat = muhat.fun(etahat, fml = family$family)
#ans = list(fit = muhat, etahat = etahat, newbigmat = object$bigmat)
ans = list(fit = object$muhat)
return (ans)
}
if (!is.data.frame(newData)) {
#newData = as.data.frame(newData)
stop ("newData must be a data frame!")
}
#shapes = object$shapes
#new: used for ci
ahat = object$coefs
coef_wp = object$coef_wp
prior.w = object$prior.w
pen = object$pen
dmat = object$dmat
amat = object$amat
y = object$y
##zmat includes one vector and also conc, conv, shape=17, additive
#no more
zmat = object$zmat
#vmat includes one vector and also conc, conv, shape=17
#vmat = object$vmat
#delta includes everything
delta = object$delta
tt = object$tms
Terms = delete.response(tt)
#model.frame will re-organize newData in the original order in formula
m = model.frame(Terms, newData)
newdata = m
#print (head(newdata))
#new:
newx0 = NULL; newxv = NULL; newx = NULL; newx_s = NULL; newu = NULL; newt = NULL; newz = NULL; newv = NULL
#newz = list();
ztb = object$ztb; zid1 = object$zid1; zid2 = object$zid2; iz = 1
rn = nrow(newdata)
#at least one pair in decrs and ks_wps
decrs = object$decrs
ks_wps = object$ks_wps
sps_wps = list()
dcss = list()
x1_wps = x2_wps = list()
iwps = 0
varlist = object$varlist_wps
#varlist = varlist[-1]
#######################
#local helper function#
#######################
my_line = function(xp = NULL, y, x, end, start) {
slope = NULL
intercept = NULL
yp = NULL
slope = (y[end] - y[start]) / (x[end] - x[start])
intercept = y[end] - slope * x[end]
yp = intercept + slope * xp
ans = new.env()
ans$slope = slope
ans$intercept = intercept
ans$yp = yp
ans
}
#get shape attributes and elem out of newdata
for (i in 1:ncol(newdata)) {
if (is.null(attributes(newdata[,i])$shape)) {
if (is.factor(newdata[,i])) {
lvli = levels(newdata[,i])
ztbi = levels(ztb[[iz]])
newdatai = NULL
if (!any(lvli %in% ztbi)) {
stop ("new factor level must be among factor levels in the fit!")
} else {
id1 = which(ztbi %in% lvli)
klvls = length(ztbi)
if (klvls > 1) {
newimat = matrix(0, nrow = rn, ncol = klvls-1)
for (i1 in 1:rn) {
if (newdata[i1,i] != ztbi[1]) {
id_col = which(ztbi %in% newdata[i1,i]) - 1
newimat[i1,id_col] = 1
}
}
newdatai = newimat
}
}
} else {
newdatai = newdata[,i]
}
newz = cbind(newz, newdatai)
iz = iz + 1
}
if (length(attributes(newdata[,i])$decreasing)>1) {
iwps = iwps + 1
#sps_wp = attributes(newdata[, i])$space
#sps_wps[[iwps]] = sps_wp
dcs = attributes(newdata[, i])$decreasing
dcss[[iwps]] = dcs
x1_wp = (newdata[, i])[, 1]
x1_wps[[iwps]] = x1_wp
x2_wp = (newdata[, i])[, 2]
x2_wps[[iwps]] = x2_wp
}
if (is.numeric(attributes(newdata[,i])$shape)) {
newx0 = cbind(newx0, newdata[,i])
if ((attributes(newdata[,i])$shape > 2 & attributes(newdata[,i])$shape < 5) | (attributes(newdata[,i])$shape > 10 & attributes(newdata[,i])$shape < 13)) {
newxv = cbind(newxv, newdata[,i])
}
}
#if (is.character(attributes(newdata[,i])$shape)) {
# if (attributes(newdata[,i])$shape == "tree") {
# newt = cbind(newt, newdata[,i])
# }
# if (attributes(newdata[,i])$shape == "umbrella") {
# newu = cbind(newu, newdata[,i])
# }
#}
}
#conc, or conv + shape=17 + other shapes + zmat (including one) + wps
m_acc_add = 0
spl_add = splpr_add = NULL
if (!is.null(newx0)) {
shapes = object$shapes
#put s=17 first as in wps.fit
if (any(shapes == 17)) {
kshapes = length(shapes)
obs = 1:kshapes
idx_s = obs[which(shapes == 17)]; idx = obs[which(shapes != 17)]
newx1 = newx0
shapes0 = 1:kshapes*0
newx1[,1:length(idx_s)] = newx0[,idx_s]
shapes0[1:length(idx_s)] = shapes[idx_s]
if (length(idx) > 0) {
newx1[,(1 + length(idx_s)):kshapes] = newx0[,idx]
shapes0[(1 + length(idx_s)):kshapes] = shapes[idx]
}
newx0 = newx1; shapes = shapes0
}
nc = ncol(newx0)
ms = object$ms
knotsuse_add = object$knotsuse_add
#17 is first
xmat0_add = object$xmat0_add
for (i in 1:nc) {
msi = ms[[i]]
shpi = shapes[i]
ki = knotsuse_add[[i]]
xi = xmat0_add[,i]
xipr = newx0[,i]
if (any(xipr > max(ki)) | any(xipr < min(ki))) {
stop ("No extrapolation is allowed in cgam prediction!")
}
#if (shpi >= 9) {
dpri = makedelta(xipr, shpi, knots = ki, suppre = TRUE, interp = TRUE)
splpri = dpri$amat
if (shpi > 10 & shpi < 13) {
xs = sort(xi)
ord = order(xi)
#nx = length(xi)
#nx is n
obs = 1:n
nr = nrow(splpri)
#nc = length(xipr)
#rn is the length of a new vector
ms2 = matrix(0, nrow = nr, ncol = rn)
for (i1 in 1:rn) {
for (i2 in 1:nr) {
ms2[i2, i1] = my_line(xp = xipr[i1], y = msi[i2, ][ord], x = xs, end = n, start = 1)$yp
}
}
splpri = splpri - ms2
} else {
splpri = splpri - msi
}
#} else {splpri = pred_del(xi, shpi, xipr, msi)}
mi = dim(splpri)[1]
m_acc_add = m_acc_add + mi
#splpr_add = rbind(splpr_add, splpri)
splpr_add = cbind(splpr_add, t(splpri))
}
}
#temp
#newv = cbind(1:rn*0 + 1, newz, newxv)
#newv = cbind(newxv, splpr_add, 1:rn*0 + 1, newz)
newv = cbind(newxv, splpr_add, newz)
np = ncol(newv)
n = length(y)
splpr = NULL
splpr_lst = mus = list()
m_acc = 0
#loop through total number of wps pairs
for (i in 1:iwps) {
k1 = ks_wps[[i]][[1]]
k2 = ks_wps[[i]][[2]]
nxi1 = x1_wps[[i]]
nxi2 = x2_wps[[i]]
if (any(nxi1 > max(k1)) | any(nxi1 < min(k1)) | any(nxi2 > max(k2)) | any(nxi2 < min(k2))) {
stop ("No extrapolation is allowed in cgam prediction!")
}
#sps_wp = sps_wps[[i]]
#space, m1_0, m2_0 don't matter
deli = makedelta_wps(nxi1, nxi2, m1_0 = length(k1), m2_0 = length(k2), k1, k2, space = c("E",
"E"), decreasing = decrs[[i]], interp = TRUE)
splpri = deli$delta
#remove the constant vector
#if (i > 1) {
#splpri = splpri[,-1]
#}
mi = dim(splpri)[2]
m_acc = m_acc + mi
#spl = rbind(spl, spli)
splpr = cbind(splpr, splpri)
splpr_lst[[i]] = splpri
#ignore z for now
#mui = cbind(1, splpri) %*% c(ahat[1], ahat[which(varlist == i)+np])
#print (dim(splpri))
#print (length(ahat))
mui = splpri %*% ahat[which(varlist == i)]+np
mus[[i]] = muhat.fun(mui, fml = family$family)
}
m_acc = m_acc + m_acc_add
xmatpr = cbind(newv, splpr)
muhatpr = xmatpr %*% ahat
muhatpr = muhat.fun(muhatpr, fml = family$family)
if ("none" %in% interval) {
ans = list(fit = muhatpr, xmatpr = xmatpr, spls = splpr_lst, mus = mus)
#new: add prediction interval
} else if (interval == "confidence" | interval == "prediction") {
if (family$family == "gaussian") {
#bmat includes constant + zmat, not weighted
bmat = delta
np = object$d0
nloop = 100
#nsec will be too big for ordinal, ignore for now
#nsec = 2^m_acc
#print (dim(zmat))
if (is.null(prior.w)) {
prior.w = rep(1, n)
}
if (!all(prior.w == 1)) {
for (i in 1:n) {
bmat[,i] = bmat[,i] * sqrt(prior.w[i])
#spl[,i] = spl[,i] * sqrt(prior.w[i])
zmat[i,] = zmat[i,] * sqrt(prior.w[i])
vmat[i,] = vmat[i,] * sqrt(prior.w[i])
}
}
#spl is constrained splines: additive + wps
#spl = bmat[,-c(1:np),drop=FALSE]
#spl = bmat
#if (np >= 1) {
# spl = bmat[,-c(1:np),drop=FALSE]
#}
#muhat0 = (object$muhat)/sqrt(prior.w)
#muhat0: unweighted
muhat0 = object$muhat
sighat = (object$sig2hat)^(1/2)
nv = np
## estimate sector probabilties
#new: not use sector = 1:nsec*0; simulate for 1,000 times and record the faces used more than once
# if times / nloop < 1e-3, then delete
sector = NULL
times = NULL
df = NULL
faces = list()
#set.seed(1)
#first column shows sector; second column shows times
for (iloop in 1:nloop) {
ysim = muhat0 + rnorm(n)*sighat
ysim = ysim * sqrt(prior.w)
#ans = coneB(ysim, t(spl), zmat, face = face)
#cf = round(ans$coefs[(nv+1):(m_acc+nv)], 10)
qv0 = crossprod(bmat)
dv0 = crossprod(dmat)
#pen2 = find_pen(aims = edf, Q = qv0, B = bmat, D = dv0, PNT = TRUE, Y = ysim, D0 = dmat)
#nxi1 = x1_wps[[1]]
#nxi2 = x2_wps[[1]]
#mat = cbind(1, nxi1, nxi2, nxi1*nxi2)
#mu_para = mat %*% solve(t(mat) %*% mat) %*% t(mat) %*% ysim
#ssr = sum((ysim - mu_para)^2)
#sc = ssr / (n - ncol(mat))
#pen = max(1e-6, 1 * sc)
qv = qv0 + pen * dv0
cv = crossprod(bmat, ysim)
#amat = diag(m)
#amat[1, ] = 0
#ans = qprog(qv, cv, amat, 1:nrow(amat)*0, msg = FALSE)
#cf = round(ans$thetahat[(np+1):(m_acc+np)],10)
#sec = 1:m_acc*0
#sec[cf > 0] = 1
umat = chol(qv)
uinv = solve(umat)
atil = amat %*% uinv
cvec = t(uinv) %*% t(bmat) %*% ysim
ans = coneA(cvec, atil, msg = FALSE)
#phihat = ans$thetahat
#ahat = uinv %*% phihat
#new: use polar cone instead
face = ans$face
faces[[iloop]] = face
sec = 1:nrow(amat)*0
sec[face] = 1
#sec = 1:nrow(amat)*0+1
#cf = round(ans$thetahat,10)
#sec[cf > 0] = 0
r = makebin(sec) + 1
if (iloop == 1) {
df = rbind(df, c(r, 1))
sector = rbind(sector, sec)
} else {
if (r %in% df[,1]) {
ps = which(df[,1] %in% r)
df[ps,2] = df[ps,2] + 1
} else {
df = rbind(df, c(r, 1))
sector = rbind(sector, sec)
}
}
}
#remove times/sum(times) < 1e-3??
sm_id = which((df[,2]/nloop) < 1e-3)
if (any(sm_id)) {
df = df[-sm_id, ,drop=FALSE]
sector = sector[-sm_id, ,drop=FALSE]
}
#new:
ns = nrow(df)
bsec = df
bsec[,2] = bsec[,2] / sum(bsec[,2])
ord = order(bsec[,1])
bsec = bsec[ord, ,drop=FALSE]
sector = sector[ord, ,drop=FALSE]
### calculate the mixture cov(alpha) matrix:
#spl = t(spl)
#obs = 1:m_acc;oobs = 1:(m_acc+nv)
#acov = matrix(0, nrow = m_acc+nv, ncol = m_acc+nv)
#for (is in 1:ns) {
# if (bsec[is,2] > 0) {
# jvec = getbin(bsec[is,1], m_acc)
# if (sum(jvec) == 1) {
# smat = cbind(vmat, spl[,which(jvec==1),drop=FALSE])
# } else if (sum(jvec) == 0) {
# smat = vmat
# } else {
# smat = cbind(vmat, spl[,which(jvec==1),drop=FALSE])
# }
# acov1 = bsec[is,2]*solve(t(smat)%*%smat)
# acov2 = matrix(0,nrow=m_acc+nv,ncol=m_acc+nv)
# jobs = 1:(m_acc+nv)>0
# jm = 1:m_acc>0
# jm[obs[jvec==0]] = FALSE
# jobs[(nv+1):(m_acc+nv)] = jm
# nobs = oobs[jobs==TRUE]
# for (i in 1:sum(jobs)) {
# acov2[nobs[i],jobs] = acov1[i,]
# }
# acov = acov+acov2
# }
#}
#get covariance of phihat first
#umat = chol(qv)
#uinv = solve(umat)
#atil = amat %*% uinv
dp = -atil
for (i in 1:nrow(dp)) {
dpi = dp[i,,drop=F]
dpi = dpi/sqrt(tcrossprod(dpi)[1])
dp[i,]=dpi
}
dp = t(dp)
imat = diag(nrow(qv))
acov0 = matrix(0, nrow=nrow(qv), ncol=ncol(qv))
for (is in 1:ns) {
if (bsec[is,2] > 0) {
#jvec = getbin(bsec[is,1], ncol(dp))
jvec = sector[is, ]
if (sum(jvec) == 0) {
pmat_is = imat
} else {
smat = dp[,which(jvec==1),drop=FALSE]
#if (qr(smat)$rank < ncol(smat)) {
#save(smat,file='smat.Rda')
#fc = bsec[is,1]
#pj = bsec[is,2]
#save(jvec, file='jvec.Rda')
#save(fc, file='fc.Rda')
#save(pj, file='pj.Rda')
#save(faces, file='faces.Rda')
#save(bsec, file='bsec.Rda')
#smat = qr.Q(qr(smat), complete = TRUE)[, 1:(qr(smat)$rank), drop = FALSE]
#}
pmat_is_p = smat %*% solve(crossprod(smat), t(smat))
pmat_is = (imat-pmat_is_p)
}
acov0 = acov0 + bsec[is,2]*pmat_is%*%t(uinv)%*%qv0%*%uinv%*%pmat_is
}
}
acov = uinv%*%acov0%*%t(uinv)*sighat^2
#only xmatpr and splpr have interpolation points
#xmatpr = cbind(newv, splpr)
#muhatpr = xmatpr %*% object$coefs
#temp:
#muhatpr = xmatpr %*% object$coefs[1:ncol(xmatpr), ,drop=FALSE]
#new: C.I. level
mult = qnorm((1 - level)/2, lower.tail=FALSE)
#hl = 2*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
#hl = mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
#ans = list(fit = muhatpr, lower = muhatpr - hl, upper = muhatpr + hl)
}
if (interval == "confidence") {
hl = mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
}
if (interval == "prediction") {
hl = mult*sqrt(sighat^2+diag(xmatpr%*%acov%*%t(xmatpr)))
}
ans = list(fit = muhatpr, lower = muhatpr - hl, upper = muhatpr + hl, object = object, acov = acov, mult = mult, newz = newz)
}
class(ans) = "wpsp"
return (ans)
}
##############
#predict.trispl
#not finished: 1 pair + z only
##############
predict.trispl = function(object, newData, interval = c("none", "confidence", "prediction"), type = c("response", "link"), level = 0.95, ...) {
#new:
family = object$family
cicfamily = CicFamily(family)
muhat.fun = cicfamily$muhat.fun
if (!inherits(object, "trispl")) {
warning("calling predict.trispl(<fake-trispl-object>) ...")
}
if (missing(newData) || is.null(newData)) {
#if (missing(newData)) {
#etahat = object$etahat
#muhat = muhat.fun(etahat, fml = family$family)
#ans = list(fit = muhat, etahat = etahat, newbigmat = object$bigmat)
ans = list(fit = object$muhat)
return (ans)
}
if (!is.data.frame(newData)) {
#newData = as.data.frame(newData)
stop ("newData must be a data frame!")
}
#shapes = object$shapes
#new: used for ci
ahat = object$coefs
coef_tri = object$coef_tri
prior.w = object$prior.w
pen = object$pen
dmat = object$pmatc
amat = object$amatc
#delta includes everything
delta = object$dmatc
capk_lst = object$capk_lst
trimat_lst = object$trimat_lst
y = object$y
n = length(y)
#zmat does't include one vector in trispl
zmat = object$zmat
#vmat includes one vector and also conc, conv, shape=17
#vmat = object$vmat
tt = object$tms
Terms = delete.response(tt)
#model.frame will re-organize newData in the original order in formula
m = model.frame(Terms, newData)
newdata = m
#print (head(newdata))
#new:
newx0 = NULL; newxv = NULL; newx = NULL; newx_s = NULL; newu = NULL; newt = NULL; newz = NULL; newv = NULL
#newz = list();
ztb = object$ztb; zid1 = object$zid1; zid2 = object$zid2; iz = 1
rn = nrow(newdata)
#at least one pair in decrs and ks_wps
#decrs = object$decrs
#ks_wps = object$ks_wps
#sps_wps = list()
#dcss = list()
#x1_wps = x2_wps = list()
iwps = 0
#varlist = object$varlist_wps
#varlist = varlist[-1]
itri = 0
convexity = object$cvss
cvss = list()
x1_tris = x2_tris = list()
icvs = 0
varlist_tri = object$varlist_tri
ks_tri = object$knots_lst
#######################
#local helper function#
#######################
my_line = function(xp = NULL, y, x, end, start) {
slope = NULL
intercept = NULL
yp = NULL
slope = (y[end] - y[start]) / (x[end] - x[start])
intercept = y[end] - slope * x[end]
yp = intercept + slope * xp
ans = new.env()
ans$slope = slope
ans$intercept = intercept
ans$yp = yp
ans
}
#get shape attributes and elem out of newdata
for (i in 1:ncol(newdata)) {
if (is.null(attributes(newdata[,i])$shape)) {
if (is.factor(newdata[,i])) {
lvli = levels(newdata[,i])
ztbi = levels(ztb[[iz]])
newdatai = NULL
if (!any(lvli %in% ztbi)) {
stop ("new factor level must be among factor levels in the fit!")
} else {
id1 = which(ztbi %in% lvli)
klvls = length(ztbi)
if (klvls > 1) {
newimat = matrix(0, nrow = rn, ncol = klvls-1)
for (i1 in 1:rn) {
if (newdata[i1,i] != ztbi[1]) {
id_col = which(ztbi %in% newdata[i1,i]) - 1
newimat[i1,id_col] = 1
}
}
newdatai = newimat
}
}
} else {
newdatai = newdata[,i]
}
newz = cbind(newz, newdatai)
iz = iz + 1
} else if (length(attributes(newdata[,i])$decreasing)>1) {
iwps = iwps + 1
#sps_wp = attributes(newdata[, i])$space
#sps_wps[[iwps]] = sps_wp
dcs = attributes(newdata[, i])$decreasing
dcss[[iwps]] = dcs
x1_wp = (newdata[, i])[, 1]
x1_wps[[iwps]] = x1_wp
x2_wp = (newdata[, i])[, 2]
x2_wps[[iwps]] = x2_wp
} else if (is.numeric(attributes(newdata[,i])$shape)) {
newx0 = cbind(newx0, newdata[,i])
if ((attributes(newdata[,i])$shape > 2 & attributes(newdata[,i])$shape < 5) | (attributes(newdata[,i])$shape > 10 & attributes(newdata[,i])$shape < 13)) {
newxv = cbind(newxv, newdata[,i])
}
} else if (is.character(attributes(newdata[,i])$shape) && (attributes(newdata[,i])$categ == "tri")) {
itri = itri + 1
cvs = attributes(newdata[,i])$cvs
cvss[[itri]] = cvs
x1_tri = (newdata[,i])[, 1]
x1_tris[[itri]] = x1_tri
x2_tri = (newdata[,i])[, 2]
x2_tris[[itri]] = x2_tri
}
}
#conc, or conv + shape=17 + other shapes + zmat (including one) + wps
m_acc_add = 0
spl_add = splpr_add = NULL
if (!is.null(newx0)) {
shapes = object$shapes
#put s=17 first as in wps.fit
if (any(shapes == 17)) {
kshapes = length(shapes)
obs = 1:kshapes
idx_s = obs[which(shapes == 17)]; idx = obs[which(shapes != 17)]
newx1 = newx0
shapes0 = 1:kshapes*0
newx1[,1:length(idx_s)] = newx0[,idx_s]
shapes0[1:length(idx_s)] = shapes[idx_s]
if (length(idx) > 0) {
newx1[,(1 + length(idx_s)):kshapes] = newx0[,idx]
shapes0[(1 + length(idx_s)):kshapes] = shapes[idx]
}
newx0 = newx1; shapes = shapes0
}
nc = ncol(newx0)
ms = object$ms
knotsuse_add = object$knotsuse_add
#17 is first
xmat0_add = object$xmat0_add
for (i in 1:nc) {
msi = ms[[i]]
shpi = shapes[i]
ki = knotsuse_add[[i]]
xi = xmat0_add[,i]
xipr = newx0[,i]
if (any(xipr > max(ki)) | any(xipr < min(ki))) {
stop ("No extrapolation is allowed in cgam prediction!")
}
#if (shpi >= 9) {
dpri = makedelta(xipr, shpi, knots = ki, suppre = TRUE, interp = TRUE)
splpri = dpri$amat
if (shpi > 10 & shpi < 13) {
xs = sort(xi)
ord = order(xi)
#nx = length(xi)
#nx is n
obs = 1:n
nr = nrow(splpri)
#nc = length(xipr)
#rn is the length of a new vector
ms2 = matrix(0, nrow = nr, ncol = rn)
for (i1 in 1:rn) {
for (i2 in 1:nr) {
ms2[i2, i1] = my_line(xp = xipr[i1], y = msi[i2, ][ord], x = xs, end = n, start = 1)$yp
}
}
splpri = splpri - ms2
} else {
splpri = splpri - msi
}
#} else {splpri = pred_del(xi, shpi, xipr, msi)}
mi = dim(splpri)[1]
m_acc_add = m_acc_add + mi
#splpr_add = rbind(splpr_add, splpri)
splpr_add = cbind(splpr_add, t(splpri))
}
}
#temp
#newv = cbind(1:rn*0 + 1, newz, newxv)
#for tri.fit, don't include the constant vector
#newv = cbind(newxv, splpr_add, 1:rn*0 + 1, newz)
#newv = cbind(newxv, splpr_add, newz)
#np = ncol(newv)
#m_acc = 0
splpr = NULL
splpr_lst = mus = list()
#loop through total number of wps pairs
for (i in 1:itri) {
k1 = ks_tri[[i]][,1]
m1 = length(k1)
k2 = ks_tri[[i]][,2]
m2 = length(k2)
nxi1 = x1_tris[[i]]
nxi2 = x2_tris[[i]]
trimat = trimat_lst[[i]]
capk = capk_lst[[i]]
if (any(nxi1 > max(k1)) | any(nxi1 < min(k1)) | any(nxi2 > max(k2)) | any(nxi2 < min(k2))) {
stop ("No extrapolation is allowed in cgam prediction!")
}
#sps_wp = sps_wps[[i]]
#space, m1_0, m2_0 don't matter
deli = makedelta_tri(nxi1, nxi2, m1, m2, k1, k2, trimat, capk, space = c("E",
"E"), cvs = convexity[[i]], interp = TRUE)
splpri = deli
#mi = dim(splpri)[2]
#m_acc = m_acc + mi
#spl = rbind(spl, spli)
splpr = cbind(splpr, splpri)
splpr_lst[[i]] = splpri
#ignore z for now
#mui = cbind(1, splpri) %*% c(ahat[1], ahat[which(varlist == i)+np])
#mus[[i]] = muhat.fun(mui, fml = family$family)
}
# m_acc = m_acc + m_acc_add
#in tri.fit: additive + trispl + z + wps (ignore)
xmatpr = cbind(splpr_add, splpr, newz)
muhatpr = xmatpr %*% ahat
muhatpr = muhat.fun(muhatpr, fml = family$family)
if ("none" %in% interval) {
ans = list(fit = muhatpr, xmatpr = xmatpr, spls = splpr_lst, mus = mus, object = object)
#new: add prediction interval
} else if (interval == "confidence" | interval == "prediction") {
if (family$family == "gaussian") {
#bmat includes constant + zmat, not weighted
bmat = delta
np = object$d0
nloop = 500
#nsec will be too big for ordinal, ignore for now
#nsec = 2^m_acc
#print (dim(zmat))
if (is.null(prior.w)) {
prior.w = rep(1, n)
}
if (!all(prior.w == 1)) {
for (i in 1:n) {
bmat[,i] = bmat[,i] * sqrt(prior.w[i])
#spl[,i] = spl[,i] * sqrt(prior.w[i])
#zmat[i,] = zmat[i,] * sqrt(prior.w[i])
#vmat[i,] = vmat[i,] * sqrt(prior.w[i])
}
}
#spl is constrained splines: additive + wps
#spl = bmat[,-c(1:np),drop=FALSE]
#muhat0 = (object$muhat)/sqrt(prior.w)
#muhat0: unweighted
muhat0 = object$muhat
sighat = (object$sig2hat)^(1/2)
#no use:
nv = np
## estimate sector probabilties
#new: not use sector = 1:nsec*0; simulate for 1,000 times and record the faces used more than once
# if times / nloop < 1e-3, then delete
sector = NULL
times = NULL
df = NULL
#faces = list()
#set.seed(1)
#first column shows sector; second column shows times
for (iloop in 1:nloop) {
#print (iloop)
ysim = muhat0 + rnorm(n)*sighat
ysim = ysim * sqrt(prior.w)
#ans = coneB(ysim, t(spl), zmat, face = face)
#cf = round(ans$coefs[(nv+1):(m_acc+nv)], 10)
qv0 = crossprod(bmat)
dv0 = crossprod(dmat)
#pen2 = find_pen(aims = edf, Q = qv0, B = bmat, D = dv0, PNT = TRUE, Y = ysim, D0 = dmat)
qv = qv0 + pen * dv0
cv = crossprod(bmat, ysim)
umat = chol(qv)
uinv = solve(umat)
atil = amat %*% uinv
cvec = t(uinv) %*% t(bmat) %*% ysim
ans = coneA(cvec, atil, msg = FALSE)
#phihat = ans$thetahat
#ahat = uinv %*% phihat
#new: use polar cone instead
face = ans$face
#faces[[iloop]] = face
sec = 1:nrow(amat)*0
sec[face] = 1
#sec = 1:nrow(amat)*0+1
#cf = round(ans$thetahat,10)
#sec[cf > 0] = 0
r = makebin(sec) + 1
if (iloop == 1) {
df = rbind(df, c(r, 1))
sector = rbind(sector, sec)
} else {
if (r %in% df[,1]) {
ps = which(df[,1] %in% r)
df[ps,2] = df[ps,2] + 1
} else {
df = rbind(df, c(r, 1))
sector = rbind(sector, sec)
}
}
}
#remove times/sum(times) < 1e-3??
sm_id = which((df[,2]/nloop) < 1e-3)
if (any(sm_id)) {
df = df[-sm_id, ,drop=FALSE]
sector = sector[-sm_id, ,drop=FALSE]
}
#new:
ns = nrow(df)
bsec = df
bsec[,2] = bsec[,2] / sum(bsec[,2])
ord = order(bsec[,1])
bsec = bsec[ord, ,drop=FALSE]
sector = sector[ord, ,drop=FALSE]
### calculate the mixture cov(alpha) matrix:
dp = -atil
for (i in 1:nrow(dp)) {
dpi = dp[i,,drop=F]
dpi = dpi/sqrt(tcrossprod(dpi)[1])
dp[i,]=dpi
}
dp = t(dp)
imat = diag(nrow(qv))
acov0 = matrix(0, nrow=nrow(qv), ncol=ncol(qv))
for (is in 1:ns) {
if (bsec[is,2] > 0) {
#jvec = getbin(bsec[is,1], ncol(dp))
jvec = sector[is, ]
if (sum(jvec) == 0) {
pmat_is = imat
} else {
smat = dp[,which(jvec==1),drop=FALSE]
pmat_is_p = smat %*% solve(crossprod(smat), t(smat))
pmat_is = (imat-pmat_is_p)
}
acov0 = acov0 + bsec[is,2]*pmat_is%*%t(uinv)%*%qv0%*%uinv%*%pmat_is
}
}
acov = uinv%*%acov0%*%t(uinv)*sighat^2
#only xmatpr and splpr have interpolation points
#xmatpr = cbind(newv, splpr)
#muhatpr = xmatpr %*% object$coefs
#temp:
#muhatpr = xmatpr %*% object$coefs[1:ncol(xmatpr), ,drop=FALSE]
#new: C.I. level
mult = qnorm((1 - level)/2, lower.tail=FALSE)
#hl = 2*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
#hl = mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
#ans = list(fit = muhatpr, lower = muhatpr - hl, upper = muhatpr + hl)
}
if (interval == "confidence") {
hl = mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
}
if (interval == "prediction") {
hl = mult*sqrt(sighat^2+diag(xmatpr%*%acov%*%t(xmatpr)))
}
ans = list(fit = muhatpr, lower = muhatpr - hl, upper = muhatpr + hl, object = object, acov = acov, mult = mult, newz = newz)
}
class(ans) = "trisplp"
return (ans)
}
###
#trispl makedelta
###
makedelta_tri = function(x1, x2, m1 = 0, m2 = 0, k1 = NULL, k2 = NULL, trimat = NULL, capk = NULL, space = c("E",
"E"), cvs = c(TRUE, TRUE), interp = TRUE) {
n = length(x1)
xmat = cbind(x1, x2)
delta = NULL
#### now determine which triangle contains each point
xtri = 1:n*0;still = 1:n>0
ntri = (m2 - 1) * (2 * m1 - 1)
knots = cbind(k1, k2)
for (j in 1:ntri) {
#print (j)
for (i in 1:n) {
if (still[i]) {
if (intri(xmat[i,],knots[trimat[j,1],],knots[trimat[j,2],],knots[trimat[j,3],])) {
still[i] = FALSE
xtri[i] = j
}
}
}
}
### make the design matrix
dmat = matrix(0, nrow = n, ncol = capk)
bmat = matrix(1, nrow = 3, ncol = 3)
a = 1:3
for (i in 1:n) {
for (j in 1:3) {
#print (c(i,j))
a[j] = trimat[xtri[i],j]
bmat[j,2] = knots[a[j],1]
bmat[j,3] = knots[a[j],2]
}
binv = solve(bmat)
for (j in 1:3) {
dmat[i,a[j]] = binv[1,j] + binv[2,j]*x1[i] + binv[3,j]*x2[i]
}
}
delta = cbind(delta, dmat)
return (delta)
}
###########################################
#create a 3D plot for a cgam or wps object#
###########################################
plotpersp <- function(object,...) {
UseMethod("plotpersp", object)
}
# plotpersp <- function(object, x1 = NULL, x2 = NULL,...) {
# x1nm <- deparse(substitute(x1))
# x2nm <- deparse(substitute(x2))
# if (inherits(object, "cgamp")) {
# xnms_add <- object$object$xnms_add
# } else {
# xnms_add <- object$xnms_add
# }
# if (inherits(object, "wpsp")) {
# xnms_wp <- object$object$xnms_wp
# } else {
# xnms_wp <- object$xnms_wp
# }
# if (inherits(object, "trisplp")) {
# xnms_tri <- object$object$xnms_tri
# } else {
# xnms_tri <- object$xnms_tri
# }
# is_add <- all(c(any(grepl(x1nm, xnms_add, fixed = TRUE)), any(grepl(x2nm, xnms_add, fixed = TRUE))))
# #print (is_add)
# is_wps <- all(c(any(grepl(x1nm, xnms_wp, fixed = TRUE)), any(grepl(x2nm, xnms_wp, fixed = TRUE))))
# #print (is_wps)
# is_tri <- all(c(any(grepl(x1nm, xnms_tri, fixed = TRUE)), any(grepl(x2nm, xnms_tri, fixed = TRUE))))
# #print (is_tri)
# if (missing(x1) | missing(x2)) {
# UseMethod("plotpersp")
# } else {
# cs = class(object)
# if (length(cs) == 1 & is.null(x1nm) & is.null(x2nm)) {
# UseMethod("plotpersp")
# } else {
# if (is_wps) {
# #print (x1)
# #print (x2nm)
# if (inherits(object, "wpsp")) {
# #print (x1nm)
# #print (x2nm)
# #print (head(x1))
# plotpersp.wpsp(object, x1, x2, x1nm, x2nm,...)
# } else {
# plotpersp.wps(object, x1, x2, x1nm, x2nm,...)
# }
# } else if (is_add) {
# if (inherits(object, "cgamp")){
# plotpersp.cgamp(object, x1, x2, x1nm, x2nm,...)
# } else {
# plotpersp.cgam(object, x1, x2, x1nm, x2nm,...)
# }
# } else if (is_tri) {
# if (inherits(object, "trisplp")) {
# plotpersp.trisplp(object, x1, x2, x1nm, x2nm,...)
# } else {
# plotpersp.trispl(object, x1, x2, x1nm, x2nm,...)
# }
# } else {
# stop ("Nonparametric components must be from the same class!")
# }
# }
# }
# }
################
#plotpersp.cgam#
################
#new: control function for aesthetics
plotpersp_control <- function(surface = "mu", x1nm = NULL, x2nm = NULL, categ = NULL,
col = NULL, random = FALSE, ngrid = 12,
xlim = NULL, ylim = NULL, zlim = NULL,
xlab = NULL, ylab = NULL, zlab = NULL,
th = NULL, ltheta = NULL, main = NULL,
sub = NULL, ticktype = "simple") {
list(x1nm = x1nm, x2nm = x2nm, surface = surface, categ = categ,
col = col, random = random, ngrid = ngrid,
xlim = xlim, ylim = ylim, zlim = zlim,
xlab = xlab, ylab = ylab, zlab = zlab,
th = th, ltheta = ltheta, main = main,
sub = sub,
ticktype = ticktype)
}
plotpersp.cgam <- function(object, x1 = NULL, x2 = NULL, control = plotpersp_control(),...) {
if (!inherits(object, "cgam")) {
warning("calling plotpersp(<fake-cgam-object>) ...")
}
#new: unpack aesthetics
defaults <- plotpersp_control()
control <- modifyList(defaults, control)
x1nm <- control$x1nm
x2nm <- control$x2nm
surface <- control$surface
categ <- control$categ
col <- control$col
random <- control$random
ngrid <- control$ngrid
xlim <- control$xlim
ylim <- control$ylim
zlim <- control$zlim
xlab <- control$xlab
ylab <- control$ylab
zlab <- control$zlab
th <- control$th
ltheta <- control$ltheta
main <- control$main
ticktype <- control$ticktype
sub <- control$sub
# c(x1nm, x2nm, surface, categ, col, random, ngrid, xlim, ylim, zlim,
# xlab, ylab, zlab, th, ltheta, main, ticktype, sub) %<-% control
#
#new: capture x1nm and x2nm cleanly
x1nm <- x1nm %||% if (!is.null(x1)) {
if (is.character(x1)) x1 else deparse(substitute(x1))
}
x2nm <- x2nm %||% if (!is.null(x2)) {
if (is.character(x2)) x2 else deparse(substitute(x2))
}
xnms <- object$xnms_add
xmat <- object$xmat_add
#if (x1nm == "NULL" | x2nm == "NULL") {
if (is.null(x1nm) || is.null(x2nm)) {
if (length(xnms) >= 2) {
x1nm <- xnms[1]
x2nm <- xnms[2]
x1id <- 1
x2id <- 2
x1 <- xmat[, 1]
x2 <- xmat[, 2]
} else {stop ("Number of non-parametric predictors must >= 2!")}
}
ynm <- object$ynm
#xmat <- object$xmat
#print (dim(xmat))
is_fac <- object$is_fac
is_param <- object$is_param
family <- object$family
fml <- family$family
cicfamily <- CicFamily(family)
muhat.fun <- cicfamily$muhat.fun
znms <- object$znms
kznms <- length(znms)
if (!is.null(categ)) {
if (!is.character(categ)) {
warning("categ must be a character argument!")
} else if (!any(znms == categ)) {
#in.or.out case
#if (!is.null(attr(object, "sub"))) {
# if (!is.null(categ)) {
# categ = paste("factor(", categ, ")", sep = "")
# }
#} else {
# warning(paste(categ, "is not an exact character name defined in the cgam fit!"))
# categ = NULL
#}
if (any(grepl(categ, znms))) {
id = which(grepl(categ, znms))
znmi = znms[id]
if (grepl("as.factor", znmi)) {
categ = paste("as.factor(", categ, ")", sep = "")
} else if (grepl("factor", znmi)) {
categ = paste("factor(", categ, ")", sep = "")
} else {print(paste(categ, "is not an exact character name defined in the cgam fit!"))}
} else {print(paste(categ, "is not an exact character name defined in the cgam fit!"))}
} else {
obsz = 1:kznms
zid = obsz[znms == categ]
#linear term:
if (!(is_fac[zid])) {
categ = NULL
}
}
}
shapes <- object$shapes
#new:
#zid1 = object$zid1 - 1 - length(shapes)
#zid2 = object$zid2 - 1 - length(shapes)
zid1 <- object$zid1
zid2 <- object$zid2
kznms <- length(znms)
zmat <- object$zmat
if (any(class(object) == "wps")) {
d0 <- object$d0
np_add <- object$np_add
p <- d0 - np_add
pb <- object$pb
zmat <- zmat[, (pb+1):(pb+p), drop = FALSE]
#remove the one
zmat <- zmat[, -1, drop = FALSE]
#print (head(zmat))
}
#zcoefs = object$zcoefs
#new: exclude the coef for the one vector
#temp:trispl not include one
if (fml != "ordered" & all(class(object) != "trispl")) {
zcoefs <- object$zcoefs[-1]
} else {
zcoefs <- object$zcoefs
}
#print (zcoefs)
#xmatnms <- object$xmatnms
knms <- length(xnms)
obs <- 1:knms
#new: remove data argument; very rare to use it anyway
#new: x1 and x2 are in .Globe, not in formula
if (all(xnms != x1nm)) {
if (length(x1) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x1!")
}
bool <- apply(xmat, 2, function(x) all(x1 == x))
if (any(bool)) {
x1id <- obs[bool]
#change x1nm to be the one in formula
x1nm <- xnms[bool]
} else {
stop (paste(paste("'", x1nm, "'", sep = ''), "is not a predictor defined in the cgam fit!"))
}
} else {
x1id <- obs[xnms == x1nm]
}
if (all(xnms != x2nm)) {
if (length(x2) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x2!")
}
bool <- apply(xmat, 2, function(x) all(x2 == x))
if (any(bool)) {
x2id <- obs[bool]
x2nm <- xnms[bool]
} else {
stop (paste(paste("'", x2nm, "'", sep = ''), "is not a predictor defined in the cgam fit!"))
}
} else {
x2id <- obs[xnms == x2nm]
}
#}
#xmat is not the one in fit
#print (length(x1))
#print (length(x2))
#xm <- cbind(x1, x2)
xm <- xmat[, c(x1id, x2id)]
#print (all(xm == cbind(x1, x2)))
#print (head(cbind(x1, x2)))
#new:
xlim <- range(xm[,1])
ylim <- range(xm[,2])
x_grid <- ngrid
y_grid <- ngrid
x1g <- 0:x_grid / x_grid * .95 * (max(xm[,1]) - min(xm[,1])) + min(xm[,1]) + .025 * (max(xm[,1]) - min(xm[,1]))
n1 <- length(x1g)
x2g <- 0:y_grid / y_grid * .95 * (max(xm[,2]) - min(xm[,2])) + min(xm[,2]) + .025 * (max(xm[,2]) - min(xm[,2]))
n2 <- length(x2g)
xgmat <- matrix(nrow = n1, ncol = n2)
eta0 <- object$coefs[1]
thvecs <- object$etacomps
#print ('thvecs')
for (i2 in 1:n2) {
for (i1 in 1:n1) {
x1a <- max(xm[xm[,1] <= x1g[i1], 1])
x1b <- min(xm[xm[,1] > x1g[i1], 1])
v1a <- min(thvecs[x1id, xm[,1] == x1a])
v1b <- min(thvecs[x1id, xm[,1] == x1b])
alp <- (x1g[i1] - x1a) / (x1b - x1a)
th1add <- (1 - alp) * v1a + alp * v1b
x2a <- max(xm[xm[,2] <= x2g[i2],2])
x2b <- min(xm[xm[,2] > x2g[i2],2])
v2a <- min(thvecs[x2id, xm[,2] == x2a])
v2b <- min(thvecs[x2id, xm[,2] == x2b])
alp <- (x2g[i2] - x2a) / (x2b - x2a)
th2add <- (1 - alp) * v2a + alp * v2b
xgmat[i1,i2] <- eta0 + th1add + th2add
}
}
x3_add <- 0
if (knms >= 3) {
x3id <- obs[-c(x1id, x2id)]
kx3 <- length(x3id)
for (i in 1:kx3) {
x3i <- xmat[, x3id[i]]
x3i_use <- max(x3i[x3i <= median(x3i)])
x3i_add <- min(thvecs[x3id[i], x3i == x3i_use])
x3_add <- x3_add + x3i_add
}
}
if (surface == "eta") {
xgmat <- xgmat + as.numeric(x3_add)
}
if (is.null(categ) & surface == "mu") {
z_add <- 0
if (!is.null(znms)) {
kzids <- length(zid1)
for (i in 1:kzids) {
pos1 <- zid1[i]; pos2 <- zid2[i]
zi <- zmat[, pos1:pos2, drop = FALSE]
zcoefsi <- zcoefs[pos1:pos2]
for (j in 1:ncol(zi)){
uzij <- unique(zi[,j])
kuzij <- length(uzij)
nmodej <- sum(zi[,j] == uzij[1])
zij_mode <- uzij[1]
for (u in 2:kuzij) {
if (sum(zi[,j] == uzij[u]) > nmodej) {
zij_mode <- uzij[u]
nmodej <- sum(zi[,j] == uzij[u])
}
}
obsuzij <- 1:length(uzij)
uzhatij <- uzij * zcoefsi[j]
zij_add <- uzhatij[obsuzij[uzij == zij_mode]]
z_add <- z_add + zij_add
}
}
}
xgmat <- xgmat + as.numeric(x3_add) + as.numeric(z_add)
#xgmat <- muhat.fun(xgmat, fml = fml)
if (fml != "gaussian" & fml != "ordered") {
for (i2 in 1:n2) {
for (i1 in 1:n1) {
xgmat[i1, i2] <- muhat.fun(xgmat[i1, i2], fml = fml)
}
}
}
} else if (!is.null(categ) & surface == "mu"){
xgmats <- list()
mins <- NULL; maxs <- NULL
obsz <- 1:kznms
zid <- obsz[znms == categ]
#print (class(znms[znms == categ]))
pos1 <- zid1[zid]; pos2 <- zid2[zid]
#print (pos1)
#print (pos2)
#zi <- zmat[, pos1:pos2, drop = FALSE]
#z_add <- 1:nrow(zi)*0
#zcoefsi <- zcoefs[pos1:pos2]
#print (zcoefsi)
zcoefsi = zcoefs[pos1:pos2]
#include the base level
zcoefsi = c(0, zcoefsi)
z_add = sort(zcoefsi)
kz_add <- length(z_add)
#new: plot the smallest one first:
#z_add <- z_add[order(z_add)]
#print (z_add)
for (iz in 1:kz_add) {
xgmats[[iz]] <- xgmat + as.numeric(x3_add) + z_add[iz]
#mins <- c(mins, min(xgmats[[iz]]))
#maxs <- c(maxs, max(xgmats[[iz]]))
if (fml != "gaussian" & fml != "ordered") {
for (i2 in 1:n2) {
for (i1 in 1:n1) {
xgmats[[iz]][i1, i2] <- muhat.fun(xgmats[[iz]][i1, i2], fml = fml)
}
}
}
#xgmat[[iz]] <- muhat.fun(xgmat[[iz]], fml = fml)
mins <- c(mins, min(xgmats[[iz]]))
maxs <- c(maxs, max(xgmats[[iz]]))
}
}
if (is.null(xlab)) {
#xlab = deparse(x1nm)
xlab <- x1nm
}
if (is.null(ylab)) {
#ylab = deparse(x2nm)
ylab <- x2nm
}
if (is.null(zlab)) {
if (surface == "mu") {
if (fml == "binomial") {
zlab <- paste("Pr(", ynm, ")")
} else if (fml == "poisson" | fml == "gaussian" | fml == "Gamma") {
zlab <- paste("Est mean of", ynm)
}
}
if (surface == "eta") {
if (fml == "binomial") {
zlab <- paste("Est log odds ratio of", ynm)
} else if (fml == "poisson" | fml == "Gamma") {
zlab <- paste("Est log mean of", ynm)
} else if (fml == "gaussian") {
zlab <- paste("Est mean of", ynm)
}
}
}
#if (is.null(zlim)) {
# zlim <- range(xgmat, na.rm = TRUE)
#}
palette <- c("peachpuff", "lightblue", "limegreen", "grey", "wheat", "yellowgreen", "seagreen1", "palegreen", "azure", "whitesmoke")
if (!is.null(categ) & surface == "mu") {
#palette = c("peachpuff", "lightblue", "grey", "wheat", "yellowgreen", "plum", "limegreen", "paleturqoise", "azure", "whitesmoke")
kxgm <- length(xgmats)
if (is.null(col)) {
#if (kxgm == 2) {
# col = c("peachpuff", "lightblue")
#} else if (kxgm == 3) {
# col = c("peachpuff", "lightblue", "grey")
#} else if (kxgm > 3 & kxgm < 11) {
# col = sample(palette, replace = FALSE)
if (random) {
col <- topo.colors(kxgm)
#col <- sample(palette, size = kxgm, replace = FALSE)
#print (col)
} else {
#print (kxgm)
if (kxgm > 1 & kxgm < 11) {
col <- palette[1:kxgm]
} else {
#new: use rainbow
col <- topo.colors(kxgm)
}
}
} else {
col0 <- col
if (col0 == "heat" | col0 == "topo" | col0 == "terrain" | col0 == "cm") {
#col0 <- col
ncol <- 100
facets <- facetcols <- list()
col <- list()
for (i in 1:kxgm) {
nr <- nrow(xgmats[[i]])
nc <- ncol(xgmats[[i]])
facets[[i]] <- (xgmats[[i]])[-1,-1] + (xgmats[[i]])[-1,-nc] + (xgmats[[i]])[-nr,-1] + (xgmats[[i]])[-nr,-nc]
facetcols[[i]] <- cut(facets[[i]], ncol)
#print (head(facetcols[[i]]))
if (col0 == "heat") {
col[[i]] <- (heat.colors(ncol))[facetcols[[i]]]
#print (head(col[[i]]))
} else if (col0 == "topo") {
col[[i]] <- (topo.colors(ncol))[facetcols[[i]]]
} else if (col0 == "terrain") {
col[[i]] <- (terrain.colors(ncol))[facetcols[[i]]]
} else {
col[[i]] <- (cm.colors(ncol))[facetcols[[i]]]
}
}
} else if (length(col0) < kxgm) {
rem <- kxgm - length(col0)
nrem <- length(rem)
rem_col <- palette[1:nrem]
col <- c(col0, rem_col)
} else if (length(col0) > kxgm) {
col <- col0[1:kxgm]
#print (paste("The first", kxgm, "colors are used!"))
}
if (random) {
print ("User defined colors are used!")
}
}
#print (col[[1]][1:10])
#print (kxgm)
#new: set th for decr or incr
decrs = shapes[c(x1id, x2id)] %in% c(2, 6, 8, 10, 15, 16)
incrs = shapes[c(x1id, x2id)] %in% c(1, 5, 7, 9, 13, 14)
if (is.null(th) | !is.numeric(th)) {
ang = NULL
if (incrs[1] & incrs[2]) {
if (is.null(ang)) {
ang = -40
}
} else if (decrs[1] & incrs[2]) {
if (is.null(ang)) {
ang = 40
}
} else if (incrs[1] & decrs[2]) {
if (is.null(ang)) {
ang = 240
}
} else if (decrs[1] & decrs[2]) {
if (is.null(ang)) {
ang = 140
}
} else {ang = -37}
} else {ang = th}
if (is.null(ltheta) | !is.numeric(ltheta)) {
ltheta <- -135
}
#print (col[[1]][1:10])
for (i in 1:kxgm) {
#print (col[i])
#i = 1
#print (i)
#print (length(col))
xgmat <- xgmats[[i]]
#if (is.null(th) | !is.numeric(th)) {
# th <- -40
#}
#if (is.null(ltheta) | !is.numeric(ltheta)) {
# ltheta <- -135
#}
#persp(x1g, x2g, xgmat, xlim = xlim, ylim = ylim, theta = th)
#new: avoid thick labs
box = TRUE
axes = TRUE
if (i > 1) {
xlab = ylab = zlab = " "
box = FALSE
axes = FALSE
}
#print (length(col))
if (is.list(col)) {
coli = unlist(col[[i]])
#print (head(coli))
} else {coli = col[i]}
if (is.null(zlim)) {
lwr = min(mins)
upp = max(maxs)
zlim0 = c(lwr - (upp-lwr)/3, upp + (upp-lwr)/3)
} else {
zlim0 = zlim
}
persp(x1g, x2g, xgmat, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = xlab, ylab = ylab, zlab = zlab,
col = coli, main = main, theta = ang, ltheta = ltheta, ticktype = ticktype, box = box, axes = axes,...)
par(new = TRUE)
}
par(new = FALSE)
} else {
if (is.null(col)) {
if (random) {
col <- sample(palette, size = 1, replace = FALSE)
} else {
#col <- "white"
#col <- color[facetcol]
nr <- nrow(xgmat)
nc <- ncol(xgmat)
ncol <- 100
facet <- xgmat[-1,-1] + xgmat[-1,-nc] + xgmat[-nr,-1] + xgmat[-nr,-nc]
#print (facet)
facetcol <- cut(facet, ncol)
col <- heat.colors(ncol)[facetcol]
}
} else {
#if (length(col) > 1) {
# col <- col[1]
# print ("The first color is used!")
# col <- heat.colors(x_grid*y_grid)
#}
if (col == "heat" | col == "topo" | col == "terrain" | col == "cm") {
nr <- nrow(xgmat)
nc <- ncol(xgmat)
ncol <- 100
facet <- xgmat[-1,-1] + xgmat[-1,-nc] + xgmat[-nr,-1] + xgmat[-nr,-nc]
facetcol <- cut(facet, ncol)
if (col == "heat") {
col <- heat.colors(ncol)[facetcol]
} else if (col == "topo") {
col <- topo.colors(ncol)[facetcol]
} else if (col == "terrain") {
col <- terrain.colors(ncol)[facetcol]
} else {
col <- cm.colors(ncol)[facetcol]
}
}
if (random) {
print ("User defined color is used!")
}
}
#if (is.null(th) | !is.numeric(th)) {
# th <- -40
#}
#if (is.null(ltheta) | !is.numeric(ltheta)) {
# ltheta <- -135
#}
#new: set th for decr or incr
decrs = shapes[c(x1id, x2id)] %in% c(2, 6, 8, 10, 15, 16)
incrs = shapes[c(x1id, x2id)] %in% c(1, 5, 7, 9, 13, 14)
if (is.null(th) | !is.numeric(th)) {
ang = NULL
if (incrs[1] & incrs[2]) {
if (is.null(ang)) {
ang = -40
}
} else if (decrs[1] & incrs[2]) {
if (is.null(ang)) {
ang = 40
}
} else if (incrs[1] & decrs[2]) {
if (is.null(ang)) {
ang = 240
}
} else if (decrs[1] & decrs[2]) {
if (is.null(ang)) {
ang = 140
}
} else {ang = -37}
} else {ang = th}
if (is.null(ltheta) | !is.numeric(ltheta)) {
ltheta <- -135
}
if (is.null(zlim)) {
lwr = min(xgmat)
upp = max(xgmat)
zlim0 = c(lwr - (upp-lwr)/3, upp + (upp-lwr)/3)
} else {
zlim0 = zlim
}
persp(x1g, x2g, xgmat, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = xlab, ylab = ylab, zlab = zlab, col = col, main = main, theta = ang, ltheta = ltheta, ticktype = ticktype,...)
rslt = list(zlim = zlim0, xlab = xlab, ylab = ylab, zlab = zlab, theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype, z_add = z_add, x3_add = x3_add)
invisible(rslt)
}
#print (col)
}
#############################################################
#apply plotpersp on a predict.cgam or predict.cgamm object
#############################################################
plotpersp.cgamp = function(object, x1=NULL, x2=NULL, x1nm=NULL, x2nm=NULL,
data=NULL, up = TRUE, main=NULL, cex.main=.8,
xlab = NULL, ylab = NULL, zlab = NULL, zlim = NULL,
th = NULL, ltheta = NULL, ticktype = "detailed",...) {
#obj is prediction for cgam or cgamm
if (!inherits(object, "cgamp")) {
warning("calling plotpersp(<fake-cgam-prediction-object>) ...")
}
t_col = function(color, percent = 50, name = NULL) {
rgb.val <- col2rgb(color)
## Make new color using input color as base and alpha set by transparency
t.col <- rgb(rgb.val[1], rgb.val[2], rgb.val[3],
maxColorValue = 255,
alpha = (100-percent)*255/100,
names = name)
## Save the color
invisible(t.col)
}
if (up) {
mycol = t_col("green", perc = 90, name = "lt.green")
} else {
mycol = t_col("pink", perc = 80, name = "lt.pink")
}
acov = object$acov
mult = object$mult
#obj is the cgam or cgamm fit
obj = object$object
#ah = obj$coef_wp
xnms = obj$xnms_add
xmat = obj$xmat_add
bigmat = obj$bigmat
#decrs = obj$decrs
#if (x1nm == "NULL" | x2nm == "NULL") {
if (is.null(x1nm) | is.null(x2nm)) {
if (length(xnms) >= 2) {
x1nm = xnms[1]
x2nm = xnms[2]
x1id = 1
x2id = 2
x1 = xmat[, 1]
x2 = xmat[, 2]
} else {stop ("Number of non-parametric predictors must >= 2!")}
}
#labels = obj$labels
#labels = labels[which(grepl("warp", labels, fixed = TRUE))]
#is_fac = obj$is_fac
ynm = obj$ynm
#varlist = obj$varlist_wps
#varlist = varlist[-1]
kts = obj$knots
np = obj$d0
knms = length(xnms)
obs = 1:knms
if (!is.null(data)) {
if (!is.data.frame(data)) {
stop ("User need to make the data argument a data frame with names for each variable!")
}
datnms <- names(data)
if (!any(datnms == x1nm) | !any(datnms == x2nm)) {
stop ("Check the accuracy of the names of x1 and x2!")
}
x1 <- data[ ,which(datnms == x1nm)]
x2 <- data[ ,which(datnms == x2nm)]
if (length(x1) != nrow(xmat)) {
warning ("Number of observations in the data set is not the same as the number of elements in x1!")
}
x1id <- obs[xnms == x1nm]
if (length(x2) != nrow(xmat)) {
warning ("Number of observations in the data set is not the same as the number of elements in x2!")
}
x2id <- obs[xnms == x2nm]
} else {
if (all(xnms != x1nm)) {
if (length(x1) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x1!")
}
bool <- apply(xmat, 2, function(x) all(x1 == x))
if (any(bool)) {
x1id <- obs[bool]
#change x1nm to be the one in formula
x1nm <- xnms[bool]
} else {
stop (paste(paste("'", x1nm, "'", sep = ''), "is not a predictor defined in the cgam fit!"))
}
} else {
x1id <- obs[xnms == x1nm]
}
if (all(xnms != x2nm)) {
if (length(x2) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x2!")
}
bool <- apply(xmat, 2, function(x) all(x2 == x))
if (any(bool)) {
x2id <- obs[bool]
x2nm <- xnms[bool]
} else {
stop (paste(paste("'", x2nm, "'", sep = ''), "is not a predictor defined in the cgam fit!"))
}
} else {
x2id <- obs[xnms == x2nm]
}
}
#xm = xmat[, c(x1id, x2id)]
xm0 = object$newx0
xm = xm0[,c(x1id,x2id)]
#print (x1id)
#print (x2id)
#print (head(x1))
#print (head(x2))
thvs_upp = object$thvs_upp
thvs_lwr = object$thvs_lwr
mins = min(thvs_lwr)+obj$coefs[1]
maxs = max(thvs_upp)+obj$coefs[1]
#print (mins)
#print (maxs)
#print (obj$coefs[1])
#if (up) {
if (is.null(zlim)) {
zlim = c(mins-(maxs-mins)/2.2, maxs+(maxs-mins)/2.2)
}
#} else {
# zlim = c(mins-(maxs-mins)/3, maxs)
#}
res = plotpersp.cgam(obj, x1=x1, x2=x2, x1nm=x1nm, x2nm=x2nm, zlim=zlim, col='white', xlab=xlab, ylab=ylab, zlab=zlab, th=th, ltheta=ltheta, ticktype=ticktype)
#print ('check')
ngrid = res$ngrid
#print (res$zlim)
x_grid = ngrid
y_grid = ngrid
x1g = 0:x_grid / x_grid * .95 * (max(xm[,1]) - min(xm[,1])) + min(xm[,1]) + .025 * (max(xm[,1]) - min(xm[,1]))
n1 = length(x1g)
x2g = 0:y_grid / y_grid * .95 * (max(xm[,2]) - min(xm[,2])) + min(xm[,2]) + .025 * (max(xm[,2]) - min(xm[,2]))
n2 = length(x2g)
xgmat = matrix(nrow = n1, ncol = n2)
eta0 = obj$coefs[1]
if (up) {
thvecs = thvs_upp
} else {
thvecs = thvs_lwr
}
for (i2 in 1:n2) {
for (i1 in 1:n1) {
x1a = max(xm[xm[,1] <= x1g[i1], 1])
x1b = min(xm[xm[,1] > x1g[i1], 1])
v1a = min(thvecs[x1id, xm[,1] == x1a])
v1b = min(thvecs[x1id, xm[,1] == x1b])
alp = (x1g[i1] - x1a) / (x1b - x1a)
th1add = (1 - alp) * v1a + alp * v1b
x2a = max(xm[xm[,2] <= x2g[i2],2])
x2b =min(xm[xm[,2] > x2g[i2],2])
v2a = min(thvecs[x2id, xm[,2] == x2a])
v2b = min(thvecs[x2id, xm[,2] == x2b])
alp = (x2g[i2] - x2a) / (x2b - x2a)
th2add = (1 - alp) * v2a + alp * v2b
xgmat[i1,i2] = eta0 + th1add + th2add
}
}
z_add = res$z_add
x3_add = res$x3_add
xgmat = xgmat + z_add + x3_add
fml = obj$family$family
#if (fml != "gaussian" & fml != "ordered") {
# for (i2 in 1:n2) {
# for (i1 in 1:n1) {
# xgmat[i1, i2] <- muhat.fun(xgmat[i1, i2], fml = fml)
# }
# }
#}
if (up) {
if (is.null(main)) {
main = "Cgam Surface with Upper 95% Confidence Surface"
}
}
if (!up) {
if (is.null(main)) {
main = "Cgam Surface with Lower 95% Confidence Surface"
}
}
par(new = TRUE)
persp(x1g, x2g, xgmat, zlim = res$zlim, xlab = "", ylab = "", zlab = "", theta = res$theta,
ltheta = res$ltheta, cex.axis = res$cex.axis, main = main, cex.main = cex.main,
ticktype = res$ticktype, col=mycol, box=FALSE, axes=FALSE,...)
par(new=FALSE)
}
#################
#plotpersp.wps#
################
plotpersp.wps = function(object, x1 = NULL, x2 = NULL, x1nm = NULL,
x2nm = NULL, data = NULL, surface = "C",
categ = NULL, col = NULL, random = FALSE,
xlim = range(x1), ylim = range(x2), zlim = NULL,
xlab = NULL, ylab = NULL, zlab = NULL, th = NULL,
ltheta = NULL, main = NULL, ticktype = "simple",...) {
#print ('wps')
if (!inherits(object, "wps")) {
warning("calling plotpersp(<fake-wps-object>) ...")
}
#x1nm = deparse(substitute(x1))
#x2nm = deparse(substitute(x2))
#print (x1nm)
#print (x2nm)
xnms = object$xnms_wp
xmat = object$xmat_wp
#if (x1nm == "NULL" | x2nm == "NULL") {
if (is.null(x1nm) | is.null(x2nm)) {
if (length(xnms) >= 2) {
x1nm = xnms[1]
x2nm = xnms[2]
x1id = 1
x2id = 2
x1 = xmat[, 1]
x2 = xmat[, 2]
} else {stop ("Number of non-parametric predictors must >= 2!")}
}
#xnms = object$xnms
#xmat = object$xmat
labels = object$labels
labels = labels[which(grepl("warp", labels, fixed = TRUE))]
#new:
is_fac = object$is_fac
ynm = object$ynm
#xmat is delta
#delta = object$delta
znms = object$znms
decrs0 = object$decrs
kznms = length(znms)
#zmat include 1 vector if only wps + add
zmat = object$zmat
np = d0 = object$d0
pb = object$pb
np_add = object$np_add
p = d0 - np_add
#print ('call wps')
#zmat = zmat[, (pb+1):(pb+d0), drop = FALSE]
#check!
#zmat = zmat[, (pb+1):(pb+p), drop = FALSE]
#print ('zmat')
#print (head(zmat))
if (any(class(object) == "trispl")) {
zmat0 = zmat
} else {
#test more...
if (!is.null(zmat)) {
zmat = zmat[, (pb+1):(pb+p), drop = FALSE]
#new constant in zmat now
#if (d0 > 1) {
# zmat0 = zmat[, -1, drop = FALSE]
#} else {zmat0 = NULL}
zmat0 = zmat
} else {
zmat0 = zmat
}
}
#print (head(zmat0))
if (all(class(object) != "trispl")) {
#zcoefs = object$zcoefs[-1]
#no more constant vector in zmat
zcoefs = object$zcoefs
} else {zcoefs = object$zcoefs}
#print (zcoefs)
zid1 = object$zid1
zid2 = object$zid2
ah = object$coef_wp
#ahu = object$coefsu
varlist = object$varlist_wps
#varlist = varlist[-1]
kts = object$ks_wps
#k1 = object$k1
#k2 = object$k2
#p = dim(zmat)[2]
#p = d0
family = object$family
fml = family$family
cicfamily = CicFamily(family)
muhat.fun = cicfamily$muhat.fun
#additive
thvecs = object$etacomps
xnms_add = object$xnms_add
xmat_add = object$xmat_add
knms = length(xnms_add)
x3_add = 0
if (knms >= 1) {
#x3id <- obs[-c(x1id, x2id)]
#kx3 <- length(x3id)
for (i in 1:knms) {
x3i = xmat_add[, i]
x3i_use = max(x3i[x3i <= median(x3i)])
x3i_add = min(thvecs[i, x3i == x3i_use])
x3_add = x3_add + x3i_add
}
}
#if (!is.null(categ)) {
# if (!is.character(categ)) {
# warning("categ must be a character argument!")
# } else if (!any(znms == categ)) {
#print ('TRUE')
# warning(paste(categ, "is not an exact character name defined in the cgam fit!"))
# categ = NULL
# } else {
# obsz = 1:kznms
# zid = obsz[znms == categ]
# if (!(is_fac[zid])) {
# categ = NULL
# }
# }
#}
if (!is.null(categ)) {
if (!is.character(categ)) {
warning("categ must be a character argument!")
} else if (!any(znms == categ)) {
if (any(grepl(categ, znms))) {
id = which(grepl(categ, znms))
znmi = znms[id]
if (grepl("as.factor", znmi)) {
categ = paste("as.factor(", categ, ")", sep = "")
} else if (grepl("factor", znmi)) {
categ = paste("factor(", categ, ")", sep = "")
} else {print(paste(categ, "is not an exact character name defined in the cgam fit!"))}
} else {print(paste(categ, "is not an exact character name defined in the cgam fit!"))}
} else {
obsz = 1:kznms
zid = obsz[znms == categ]
#linear term:
#if (!(is_fac[zid])) {
# categ = NULL
#}
}
}
#new: switch xnms
if (!is.null(data)) {
if (!is.data.frame(data)) {
stop ("User need to make the data argument a data frame with names for each variable!")
}
datnms = names(data)
if (!any(datnms == x1nm) | !any(datnms == x2nm)) {
stop ("Check the accuracy of the names of x1 and x2!")
}
x1 = data[ ,which(datnms == x1nm)]
x2 = data[ ,which(datnms == x2nm)]
} else {
if (all(xnms != x1nm)) {
#stop (paste(paste("'", x1nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
#new: in case of wrong data fame
if (length(x1) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x1!")
}
bool = apply(xmat, 2, function(x) all(x1 == x))
if (any(bool)) {
#x1id = obs[bool]
x1nm = xnms[bool]
} else {
stop (paste(paste("'", x1nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
if (all(xnms != x2nm)) {
#stop (paste(paste("'", x2nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
if (length(x2) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x2!")
}
bool = apply(xmat, 2, function(x) all(x2 == x))
if (any(bool)) {
#x2id = obs[bool]
x2nm = xnms[bool]
} else {
stop (paste(paste("'", x2nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
}
xnm12 = c(x1nm, x2nm)
id_lab = which(xnms %in% xnm12)
xnm12_lab = labels[id_lab]
xnm_other = xnms[-id_lab]
id1 = id2 = ipr = NULL
#print ('id_lab')
#print (xnm12_lab)
if (length(unique(xnm12_lab)) > 1 | length(id_lab) != 2) {
stop ("Two non-parametric predictors do not form a warped-plane surface!")
} else {
id1 = sort(id_lab)[1]
id2 = sort(id_lab)[2]
ipr = id2 / 2
}
decrs = decrs0[[ipr]]
ktsi = kts[[ipr]]
k1 = ktsi[[1]]
k2 = ktsi[[2]]
m1 = length(k1)
m2 = length(k2)
#if (x1nm0 != xnms[1] & x2nm0 != xnms[2]) {
# x1nm = x2nm0
# x2nm = x1nm0
# tmp = x1
# x1 = x2
# x2 = tmp
#} else {x1nm = x1nm0; x2nm = x2nm0}
#print (paste('id1: ', id1))
#print (paste('id2: ', id2))
if (x1nm != xnms[id1] & x2nm != xnms[id2]) {
nm = x1nm
x1nm = x2nm
x2nm = nm
tmp = x1
x1 = x2
x2 = tmp
}
# apl = 1:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))
# #aplu = 1:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))
# apl[1] = ah[1]
# #aplu[1] = ahu[1]
# #apl[2:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))] = ah[(p + 1):(m1 + m2 - 1 + (m1 - 1) * (m2 - 1) + p - 1)]
# #aplu[2:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))] = ahu[(p + 1):(m1 + m2 - 1 + (m1 - 1) * (m2 - 1) + p - 1)]
# apl[2:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))] = (ah[-c(1:p)])[which(varlist == ipr)]
# #aplu[2:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))] = (ahu[-1])[which(varlist == ipr)]
# mupl = matrix(apl[1], nrow = m1, ncol = m2)
# #muplu = matrix(aplu[1], nrow = m1, ncol = m2)
# for (i1 in 2:m1) {
# mupl[i1, ] = mupl[i1, ] + apl[i1]
# #muplu[i1, ] = muplu[i1, ] + aplu[i1]
# }
# for (i2 in 2:m2) {
# mupl[, i2] = mupl[, i2] + apl[m1 - 1 + i2]
# #muplu[, i2] = muplu[, i2] + aplu[m1 - 1 + i2]
# }
# for (i1 in 2:m1) {
# for (i2 in 2:m2) {
# mupl[i1, i2] = mupl[i1, i2] + apl[m1 + m2 - 2 + (i1 - 2) * (m2 - 1) + i2]
# #muplu[i1, i2] = muplu[i1, i2] + aplu[m1 + m2 - 2 + (i1 - 2) * (m2 - 1) + i2]
# }
# }
#plot the estimates at knots
newData = expand.grid(k1,k2)
colnames(newData) = xnm12
npr = round(length(xnms) / 2, 0L)
new_other = NULL
if (npr > 1) {
new_other = matrix(0, nrow=nrow(newData), ncol=(2*(npr-1)))
kts_other = kts[-ipr]
for (i in 1:(npr-1)) {
for (j in 1:2) {
newi = mean(kts_other[[i]][[j]])
new_other[,(i-1)*2+j] = newi
}
}
newd = cbind(newData, new_other)
colnames(newd) = c(xnm12, xnm_other)
newData = as.data.frame(newd)
}
if (length(xnms_add) > 0) {
#new_add = matrix(0, nrow=nrow(newData), ncol=ncol(xmat_add))
means = apply(xmat_add, 2, mean)
new_add = matrix(rep(means, nrow(newData)), ncol=ncol(xmat_add), byrow=T)
nms = colnames(newData)
newd = cbind(newData, new_add)
colnames(newd) = c(nms, xnms_add)
newData = as.data.frame(newd)
}
#test!
Mode = function(x) {
ux = unique(x)
ux[which.max(tabulate(match(x, ux)))]
}
newz = NULL
if (!is.null(zmat)) {
newz = matrix(0, nrow=nrow(newData), ncol=ncol(zmat))
for(j in 1:(ncol(zmat))) {
newz[,j] = Mode(zmat[,j])
}
}
if (!is.null(newz)) {
znms = object$znms
nz = matrix(0, nrow=nrow(newData), ncol=ncol(newz))
nznm = gsub("[\\(\\)]", "", regmatches(znms, gregexpr("\\(.*?\\)", znms))[[1]])
#new: zmat has > 1 columns -> not work, will make predict.wps give an error
#nznm = paste0(nznm, 1:ncol(newz), sep="")
nms = colnames(newData)
newData = cbind(newData, nz)
#check more:
if (length(nznm) > 0) {
colnames(newData) = c(nms, rep(nznm, ncol(newz)))
}
if (length(nznm) == 0) {
colnames(newData) = c(nms, znms)
}
}
pfit.knots = predict.wps(object, newData, interval='none')
xmatpr = pfit.knots$xmatpr
spls = pfit.knots$spls
#ignore z
spl_use = spls[[ipr]]
#get the fit for each pair
mus = pfit.knots$mus
muhat_use = spl_use%*%ah[which(varlist == ipr)+np]
mupl = matrix(0, m1, m2)
for(i2 in 1:m2) {
for(i1 in 1:m1) {
mupl[i1,i2] = muhat_use[(i2-1)*m1 + i1]
}
}
#new: more families
if (fml != "gaussian") {
for (i1 in 1:m1) {
for (i2 in 1:m2) {
mupl[i1, i2] = muhat.fun(mupl[i1, i2], fml = fml)
#muplu[i1, i2] = muhat.fun(muplu[i1, i2], fml = fml)
}
}
#mupl = muhat.fun(mupl, fml = fml)
#muplu = muhat.fun(muplu, fml = fml)
}
## reverse transform for decreasing
if (is.null(th) | !is.numeric(th)) {
ang = NULL
if (!decrs[1] & !decrs[2]) {
if (is.null(ang)) {
ang = -40
}
} else if (decrs[1] & !decrs[2]) {
#k1 = -k1[m1:1];
#mupl = mupl[m1:1, 1:m2];
#muplu = muplu[m1:1, 1:m2]
if (is.null(ang)) {
ang = 40
}
} else if (!decrs[1] & decrs[2]) {
#k2 = -k2[m2:1];
#mupl = mupl[1:m1, m2:1];
#muplu = muplu[1:m1, m2:1]
if (is.null(ang)) {
ang = 240
}
} else if (decrs[1] & decrs[2]) {
#k1 = -k1[m1:1]; k2 = -k2[m2:1];
#mupl = mupl[m1:1, m2:1];
#muplu = muplu[m1:1, m2:1]
if (is.null(ang)) {
ang = 140
}
}
} else {ang = th}
if (is.null(ltheta) | !is.numeric(ltheta)) {
ltheta <- -135
}
if (is.null(categ)) {
z_add = 0
if (!is.null(znms)) {
kzids = length(zid1)
for (i in 1:kzids) {
pos1 = zid1[i]; pos2 = zid2[i]
#zi is a factor
zi = zmat0[, pos1:pos2, drop = FALSE]
zcoefsi = zcoefs[pos1:pos2]
for (j in 1:ncol(zi)){
#find the 'mode' of the jth column of zi; add the coef corresponding to the 'mode'
uzij = unique(zi[,j])
kuzij = length(uzij)
nmodej = sum(zi[,j] == uzij[1])
zij_mode = uzij[1]
for (u in 2:kuzij) {
if (sum(zi[,j] == uzij[u]) > nmodej) {
zij_mode = uzij[u]
nmodej = sum(zi[,j] == uzij[u])
}
}
obsuzij = 1:length(uzij)
uzhatij = uzij * zcoefsi[j]
zij_add = uzhatij[obsuzij[uzij == zij_mode]]
z_add = z_add + zij_add
}
}
}
mupl = mupl + as.numeric(z_add) + as.numeric(x3_add)
#muplu = muplu + as.numeric(z_add)
#new:
if (fml != "gaussian") {
for (i1 in 1:m1) {
for (i2 in 1:m2) {
mupl[i1, i2] = muhat.fun(mupl[i1, i2], fml = fml)
#muplu[i1, i2] = muhat.fun(muplu[i1, i2], fml = fml)
}
}
#mupl = muhat.fun(mupl, fml = fml)
#muplu = muhat.fun(muplu, fml = fml)
}
mins = min(mupl); maxs = max(mupl)
#minsu = min(muplu); maxsu = max(muplu)
} else {
mupls = muplus = list()
mins = maxs = NULL
minsu = maxsu = NULL
obsz = 1:kznms
zid = obsz[znms == categ]
pos1 = zid1[zid]; pos2 = zid2[zid]
zcoefsi = zcoefs[pos1:pos2]
#?include the base level
zcoefsi = c(0, zcoefsi)
z_add = sort(zcoefsi)
kz_add = length(z_add)
#print (kz_add)
for (iz in 1:kz_add) {
mupls[[iz]] = mupl + z_add[iz] + as.numeric(x3_add)
mins = c(mins, min(mupls[[iz]]))
maxs = c(maxs, max(mupls[[iz]]))
#muplus[[iz]] = muplu + z_add[iz]
#minsu = c(minsu, min(muplus[[iz]]))
#maxsu = c(maxsu, max(muplus[[iz]]))
}
if (fml != "gaussian") {
for (iz in 1:kz_add) {
mupli = mupls[[iz]]
#muplui = muplus[[iz]]
for (i1 in 1:m1) {
for (i2 in 1:m2) {
mupli[i1, i2] = muhat.fun(mupli[i1, i2], fml = fml)
#muplui[i1, i2] = muhat.fun(muplui[i1, i2], fml = fml)
}
}
#mupli = muhat.fun(mupli, fml = fml)
#muplui = muhat.fun(muplui, fml = fml)
mupls[[iz]] = mupli
#muplus[[iz]] = muplui
}
}
}
palette = c("peachpuff", "lightblue", "limegreen", "grey", "wheat", "yellowgreen", "seagreen1", "palegreen", "azure", "whitesmoke")
if (is.null(xlab)) {
xlab = x1nm
}
if (is.null(ylab)) {
ylab = x2nm
}
if (is.null(zlab)) {
if (fml == "binomial") {
zlab = paste("Pr(", ynm, ")")
} else if (fml == "poisson" | fml == "gaussian" | fml == "Gamma") {
zlab = paste("Est mean of", ynm)
}
}
if (is.null(categ)) {
if (is.null(col)) {
if (random) {
col = sample(palette, size = 1, replace = FALSE)
} else {
#col = "white"
if (surface == 'C') {
musurf = mupl
#} else if (surface == 'U') {
# musurf = muplu
}
nr = nrow(musurf)
nc = ncol(musurf)
ncol = 100
facet = musurf[-1,-1] + musurf[-1,-nc] + musurf[-nr,-1] + musurf[-nr,-nc]
facetcol = cut(facet, ncol)
col = heat.colors(ncol)[facetcol]
}
} else if (col == "heat" | col == "topo" | col == "terrain" | col == "cm") {
if (surface == 'C') {
musurf = mupl
#} else if (surface == 'U') {
# musurf = muplu
}
nr = nrow(musurf)
nc = ncol(musurf)
ncol = 100
facet = musurf[-1,-1] + musurf[-1,-nc] + musurf[-nr,-1] + musurf[-nr,-nc]
facetcol = cut(facet, ncol)
if (col == "heat") {
col = heat.colors(ncol)[facetcol]
} else if (col == "topo") {
col = topo.colors(ncol)[facetcol]
} else if (col == "terrain") {
col = terrain.colors(ncol)[facetcol]
} else {
col = cm.colors(ncol)[facetcol]
}
}
if (surface == 'C') {
musurf = mupl
#if (is.null(main)) {
# main = 'Constrained Warped-Plane Spline Surface'
#}
if (is.null(zlim)) {
lwr = min(mins)
upp = max(maxs)
#print (lwr)
#print (upp)
zlim0 = c(lwr - (upp-lwr)/5, upp + (upp-lwr)/5)
} else {
zlim0 = zlim
}
#} else if (surface == 'U') {
# musurf = muplu
#if (is.null(main)) {
# main = 'Unconstrained Warped-Plane Spline Surface'
#}
#zlim0 = c(min(minsu), max(maxsu))
}
#print (head(musurf))
xlim = range(x1)
ylim = range(x2)
#persp(k1, k2, musurf, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype,...)
persp(k1, k2, musurf, zlim = zlim0, xlab = xlab, ylab = ylab, zlab = zlab,
theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype,...)
rslt = list(zlim = zlim0, xlab = xlab, ylab = ylab, zlab = zlab, theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype, z_add = z_add, x3_add = x3_add)
invisible(rslt)
} else {
kxgm = length(mupls)
if (is.null(col)) {
if (random) {
#new:
col = topo.colors(kxgm)
#col = sample(palette, size = kxgm, replace = FALSE)
} else {
if (kxgm > 1 & kxgm < 11) {
col = palette[1:kxgm]
} else {
#integ = floor(kxgm / 10)
#rem = kxgm %% 10
#kint = length(integ)
#col = NULL
#for (i in 1:kint) {
# col = c(col, palette)
#}
#col = c(col, palette[1:rem])
#new:
col = topo.colors(kxgm)
}
}
} else {
col0 = col
if (col0 == "heat" | col0 == "topo" | col0 == "terrain" | col0 == "cm") {
ncol = 100
facets = facetcols = list()
if (surface == "C") {
xgmats = mupls
}
#if (surface == "U") {
# xgmats = muplus
#}
col = list()
for (i in 1:kxgm) {
nr = nrow(xgmats[[i]])
nc = ncol(xgmats[[i]])
facets[[i]] = (xgmats[[i]])[-1,-1] + (xgmats[[i]])[-1,-nc] + (xgmats[[i]])[-nr,-1] + (xgmats[[i]])[-nr,-nc]
facetcols[[i]] = cut(facets[[i]], ncol)
if (col0 == "heat") {
col[[i]] = (heat.colors(ncol))[facetcols[[i]]]
} else if (col0 == "topo") {
col[[i]] = (topo.colors(ncol))[facetcols[[i]]]
} else if (col0 == "terrain") {
col[[i]] = (terrain.colors(ncol))[facetcols[[i]]]
} else {
col[[i]] = (cm.colors(ncol))[facetcols[[i]]]
}
}
} else if (length(col0) < kxgm) {
#rem = kxgm - length(col)
#nrem = length(rem)
#rem_col = palette[1:nrem]
#col = c(col, rem_col)
#new:
col = topo.colors(kxgm)
} else if (length(col0) > kxgm) {
col = col[1:kxgm]
#print (paste("The first", kxgm, "colors are used!"))
}
#if (random) {
#print ("User defined colors are used!")
#}
}
for (i in 1:kxgm) {
mupli = mupls[[i]]
#muplui = muplus[[i]]
if (surface == 'C') {
musurf = mupli
#if (is.null(main)) {
# main = 'Constrained Warped-Plane Spline Surface'
#}
if (is.null(zlim)) {
lwr = min(mins)
upp = max(maxs)
zlim0 = c(lwr - (upp-lwr)/5, upp + (upp-lwr)/5)
} else {
zlim0 = zlim
}
#} else if (surface == 'U') {
# musurf = muplui
#if (is.null(main)) {
# main = 'Unconstrained Warped-Plane Spline Surface'
#}
#zlim0 = c(min(minsu), max(maxsu))
}
#par(mar = c(4, 2, 2, 2))
#print (sub)
#persp(k1, k2, musurf, sub = sub)
if (is.list(col)) {
coli = unlist(col[[i]])
} else {coli = col[i]}
#xlim = range(x1)
#ylim = range(x2)
#persp(k1, k2, musurf, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = coli, cex.axis = .75, main = main, ticktype = ticktype,...)
persp(k1, k2, musurf, zlim = zlim0, xlab = xlab, ylab = ylab, zlab = zlab, theta = ang,
ltheta = ltheta, col = coli, cex.axis = .75, main = main, ticktype = ticktype,...)
par(new = TRUE)
}
par(new = FALSE)
}
}
##########################################
#apply plotpersp on a wps.predict object
#>=1 wps pair + z + additive #done
##########################################
###############################################################
#plotpersp for a predict.wps object
#check the zlim when there's a smooth additive component more
###############################################################
plotpersp.wpsp = function(object, x1=NULL, x2=NULL, x1nm=NULL, x2nm=NULL,
data=NULL, up = TRUE, main=NULL, cex.main=.8, xlab = NULL,
ylab = NULL, zlab = NULL, th = NULL, ltheta = NULL,
ticktype = "simple",...) {
#obj is prediction for wps
if (!inherits(object, "wpsp")) {
warning("calling plotpersp(<fake-wpsp-object>) ...")
}
t_col = function(color, percent = 50, name = NULL) {
rgb.val <- col2rgb(color)
## Make new color using input color as base and alpha set by transparency
t.col <- rgb(rgb.val[1], rgb.val[2], rgb.val[3],
maxColorValue = 255,
alpha = (100-percent)*255/100,
names = name)
## Save the color
invisible(t.col)
}
if (up) {
mycol = t_col("green", perc = 90, name = "lt.green")
} else {
mycol = t_col("pink", perc = 80, name = "lt.pink")
}
acov = object$acov
mult = object$mult
#obj is the wps fit
obj = object$object
ah = obj$coef_wp
xnms = obj$xnms_wp
xmat = obj$xmat_wp
delta = obj$delta
decrs = obj$decrs
xnms_add = obj$xnms_add
xmat_add = obj$xmat_add
#if (x1nm == "NULL" | x2nm == "NULL") {
if (is.null(x1nm) | is.null(x2nm)) {
if (length(xnms) >= 2) {
x1nm = xnms[1]
x2nm = xnms[2]
x1id = 1
x2id = 2
x1 = xmat[, 1]
x2 = xmat[, 2]
} else {stop ("Number of non-parametric predictors must >= 2!")}
}
labels = obj$labels
labels = labels[which(grepl("warp", labels, fixed = TRUE))]
is_fac = obj$is_fac
ynm = obj$ynm
varlist = obj$varlist_wps
#varlist = varlist[-1]
kts = obj$ks_wps
np = obj$d0
#switch xnms
if (!is.null(data)) {
if (!is.data.frame(data)) {
stop ("User need to make the data argument a data frame with names for each variable!")
}
datnms = names(data)
if (!any(datnms == x1nm) | !any(datnms == x2nm)) {
stop ("Check the accuracy of the names of x1 and x2!")
}
x1 = data[ ,which(datnms == x1nm)]
x2 = data[ ,which(datnms == x2nm)]
} else {
if (all(xnms != x1nm)) {
#stop (paste(paste("'", x1nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
#new: in case of wrong data fame
if (length(x1) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x1!")
}
bool = apply(xmat, 2, function(x) all(x1 == x))
if (any(bool)) {
#x1id = obs[bool]
x1nm = xnms[bool]
} else {
stop (paste(paste("'", x1nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
if (all(xnms != x2nm)) {
#stop (paste(paste("'", x2nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
if (length(x2) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x2!")
}
bool = apply(xmat, 2, function(x) all(x2 == x))
if (any(bool)) {
#x2id = obs[bool]
x2nm = xnms[bool]
} else {
stop (paste(paste("'", x2nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
}
xnm12 = c(x1nm, x2nm)
id_lab = which(xnms %in% xnm12)
xnm12_lab = labels[id_lab]
#new:
xnm_other = xnms[-id_lab]
id1 = id2 = ipr = NULL
if (length(unique(xnm12_lab)) > 1 | length(id_lab) != 2) {
stop ("Two non-parametric predictors do not form a warped-plane surface!")
} else {
id1 = sort(id_lab)[1]
id2 = sort(id_lab)[2]
ipr = id2 / 2
}
#find the pairs to be plotted
decrs_use = decrs[[ipr]]
kts_use = kts[[ipr]]
x1p = kts_use[[1]]
x2p = kts_use[[2]]
k1 = length(x1p)
k2 = length(x2p)
if (x1nm != xnms[id1] & x2nm != xnms[id2]) {
nm = x1nm
x1nm = x2nm
x2nm = nm
tmp = x1
x1 = x2
x2 = tmp
#new:
xnm12 = c(x1nm, x2nm)
}
newData = expand.grid(x1p,x2p)
#find the names of the pair
colnames(newData) = xnm12
#ignore z if there's any
#temp:
newz = object$newz
npr = round(length(xnms) / 2, 0L)
new_other = NULL
if (npr > 1) {
new_other = matrix(0, nrow=nrow(newData), ncol=(2*(npr-1)))
kts_other = kts[-ipr]
for (i in 1:(npr-1)) {
for (j in 1:2) {
newi = mean(kts_other[[i]][[j]])
new_other[,(i-1)*2+j] = newi
}
}
newd = cbind(newData, new_other)
colnames(newd) = c(xnm12, xnm_other)
newData = as.data.frame(newd)
}
if (length(xnms_add) > 0) {
#new_add = matrix(0, nrow=nrow(newData), ncol=ncol(xmat_add))
means = apply(xmat_add, 2, mean)
new_add = matrix(rep(means, nrow(newData)), ncol=ncol(xmat_add), byrow=T)
nms = colnames(newData)
newd = cbind(newData, new_add)
colnames(newd) = c(nms, xnms_add)
newData = as.data.frame(newd)
}
if (!is.null(newz)) {
znms = obj$znms
nz = matrix(0, nrow=nrow(newData), ncol=ncol(newz))
nznm = gsub("[\\(\\)]", "", regmatches(znms, gregexpr("\\(.*?\\)", znms))[[1]])
#new: zmat has > 1 columns -> not work, will make predict.wps give an error
#nznm = paste0(nznm, 1:ncol(newz), sep="")
nms = colnames(newData)
newData = cbind(newData, nz)
colnames(newData) = c(nms, nznm)
}
#print (head(x1))
#print (x1nm)
#print (x2nm)
#print (colnames(newData))
#determine zlim beforehand
pfit.knots = predict.wps(obj, newData, interval='none')
#get the spline for each pair
xmatpr = pfit.knots$xmatpr
spls = pfit.knots$spls
#ignore z
#spl_use = cbind(1, spls[[ipr]])
spl_use = spls[[ipr]]
#get the fit for each pair
mus = pfit.knots$mus
#muhat_use = mus[[ipr]]
#test more:
#muhat_use = spl_use%*%ah[c(1, which(varlist == ipr)+np)]
muhat_use = spl_use%*%ah[which(varlist == ipr)+np]
#get the acov for each pair
if (length(xnms_add) > 0) {
k_add = length(obj$coef_add)
k_conv = sum(obj$shapes == 11 || obj$shapes == 12)
#acov_use = acov[c(1, which(varlist == ipr)+np+k_conv+k_add), c(1, which(varlist == ipr)+np+k_conv+k_add)]
keep_id = which(varlist == ipr)+np+k_conv+k_add
acov_use = acov[keep_id, keep_id]
} else {
#acov_use = acov[c(1, which(varlist == ipr)+np), c(1, which(varlist == ipr)+np)]
keep_id = which(varlist == ipr)+np
acov_use = acov[keep_id, keep_id]
}
lower = muhat_use - mult*sqrt(diag(spl_use%*%acov_use%*%t(spl_use)))
upper = muhat_use + mult*sqrt(diag(spl_use%*%acov_use%*%t(spl_use)))
#lower = pfit.knots$lower
#upper = pfit.knots$upper
#zlwr = min(object$lower) - (max(object$fit) - min(object$fit)) / 2 + x3_add
#zupp = max(object$upper) + (max(object$fit) - min(object$fit)) / 2 + x3_add
#check the limits more
zlwr = min(lower) - (max(object$fit) - min(object$fit)) / 10
zupp = max(upper) + (max(object$fit) - min(object$fit)) / 10
res = plotpersp.wps(obj, x1=x1, x2=x2, x1nm, x2nm, col='white', zlim=c(zlwr, zupp), xlab=xlab, ylab=ylab, zlab=zlab, th=th, ltheta=ltheta, ticktype=ticktype)
#res = plotpersp.wps(obj, x1=x1, x2=x2, x1nm, x2nm, col='white', xlab=xlab, ylab=ylab, zlab=zlab, th=th, ltheta=ltheta, ticktype=ticktype)
surf = matrix(0, k1, k2)
for(i2 in 1:k2) {
for(i1 in 1:k1) {
if (up) {
#surf[i1,i2] = muhat_use[(i2-1)*k1 + i1]
surf[i1,i2] = upper[(i2-1)*k1 + i1]
} else {
surf[i1,i2] = lower[(i2-1)*k1 + i1]
}
}
}
z_add = res$z_add
x3_add = res$x3_add
surf = surf + z_add + x3_add
if (up) {
if (is.null(main)) {
main = "Warped-Plane Surface with Upper 95% Confidence Surface"
}
}
if (!up) {
if (is.null(main)) {
main = "Warped-Plane Surface with Lower 95% Confidence Surface"
}
}
par(new = TRUE)
#persp(x1p, x2p, surf, zlim = res$zlim, xlab = res$xlab, ylab = res$ylab, zlab = res$zlab, theta = res$theta, ltheta = res$ltheta, cex.axis = res$cex.axis, main = main, cex.main = cex.main, ticktype = res$ticktype, col=mycol)
persp(x1p, x2p, surf, zlim = res$zlim, xlab = "", ylab = "", zlab = "",
theta = res$theta, ltheta = res$ltheta, cex.axis = res$cex.axis,
main = main, cex.main = cex.main, ticktype = res$ticktype, col=mycol, box=FALSE, axes=FALSE,...)
par(new=FALSE)
}
#####
#wps#
#####
wps_getedf = function(ahati, sm, amat, amat0, xw0, xmat0, qmat0, p) {
nz = 1:dim(amat)[1] < sm
nz[amat %*% ahati > sm] = TRUE
if (sum(nz) < dim(amat0)[1]) {
gamj = -t(amat0[!nz, ])
if (length(gamj) == dim(xw0)[2]) {
gamj = matrix(gamj, ncol = 1)
}
aq = qr(gamj)
if (aq$rank >= 1) {
if (aq$rank == 1) {
gamj = matrix(qr.Q(aq)[, 1:aq$rank, drop = FALSE], ncol = 1)
} else {
gamj = qr.Q(aq)[, 1:aq$rank, drop = FALSE]
}
pa = gamj %*% solve(t(gamj) %*% gamj) %*% t(gamj)
dj1 = dim(gamj)[1]; dj2 = dim(gamj)[2]
#imat = matrix(0, nrow = dj1, ncol = dj1)
#for (i in 1:dj1) {imat[i, i] = 1}
imat = diag(dj1)
uvecs = matrix(rnorm(dj1 * (dj1 - dj2)), nrow = dj1)
wmatt = (imat - pa) %*% uvecs
aqt = qr(wmatt); wmat = qr.Q(aqt)
b0mat = xw0 %*% wmat
}
} else {
b0mat = xw0
inmat = diag(dim(xmat0)[2])
wmat = inmat
}
p0mat = xmat0 %*% wmat %*% solve(t(wmat) %*% qmat0 %*% wmat) %*% t(wmat) %*% t(xmat0)
edfi = sum(diag(p0mat)) + p - 1
return (edfi)
}
########################################
#new wps.fit, with new amat and dmat
########################################
wps.fit = function(x1t, x2t, y, zmat = NULL, xmat_add = NULL, delta_add = NULL, delta_ut = NULL, varlist_add = NULL,
shapes_add = NULL, np_add = 0, shapes = NULL, w = NULL, pen = 0, pnt = TRUE, cpar = 1.5, decrs = c(FALSE, FALSE), delta = NULL, kts = NULL, wt.iter = FALSE, family = gaussian(), cic = FALSE, nsim = 100, nprs = 1, idx_s = NULL, idx = NULL, gcv = FALSE, pvf = FALSE) {
cicfamily = CicFamily(family)
linkfun = cicfamily$linkfun
llh.fun = cicfamily$llh.fun
etahat.fun = cicfamily$etahat.fun
gr.fun = cicfamily$gr.fun
wt.fun = cicfamily$wt.fun
zvec.fun = cicfamily$zvec.fun
muhat.fun = cicfamily$muhat.fun
ysim.fun = cicfamily$ysim.fun
deriv.fun = cicfamily$deriv.fun
dev.fun = cicfamily$dev.fun
n = length(y)
#new: scale penalty term later
#scy = var(y)
one = 1:n*0 + 1
# if (is.null(zmat)) {
# zmat = matrix(one, ncol = 1)
# } else {
# if (dim(zmat)[1] != n) {
# stop ("Error: # rows of zmat must equal length of y")
# }
# zproj = zmat %*% solve(crossprod(zmat), t(zmat))
# onep = one - zproj %*% one
# # if the one vector is not in the space of zmat, then include the one vector in zmat
# if (sum(onep^2) > 1e-12) {
# zmat = cbind(one, zmat)
# }
# }
#p doesn't include the additive x
p = 0
if (!is.null(zmat)){
p = dim(zmat)[2]
dimnames(zmat)[[2]] = NULL
}
#new: we have additive x's
#we already get warp.delta (delta); the 1st col of xmat is one
#bmat include conv, conc, shape = 17 and additive
#include bmat in zmat because we don't have penalty for bmat
imat = diag(n)
#delta0 = delta
#dproj = delta%*%solve(crossprod(delta))%*%t(delta)
#zproj = zmat %*% solve(crossprod(zmat), t(zmat))
#zmat = (imat - dproj) %*% zmat
#delta = (imat - zproj) %*% delta
#save(delta,file='delta.Rda')
xmat0 = delta
bmat = NULL
pb = 0
if (!is.null(delta_add)) {
bmat = t(delta_add)
pb = ncol(bmat)
zmat = cbind(bmat, zmat)
xmat0 = cbind(xmat0, bmat)
}
#stop (print (xmat0[1,]))
#print (all(xmat0[, 1] == 1))
#xmat is additive, z, surface
if (p >= 1) {
#xmat = cbind(zmat, delta[, -1])
#imat = diag(n)
#zproj = zmat %*% solve(crossprod(zmat), t(zmat))
#delta = (imat - zproj) %*% delta
#zproj = zmat %*% solve(crossprod(zmat), t(zmat))
#onep = one - zproj %*% one
#onep = one %*% solve(crossprod(one), t(one))
#delta = (imat - onep) %*% delta
#zmat = (imat - onep)%*%zmat
xmat = cbind(zmat, delta)
#xmat = cbind(delta,zmat)
} else {
#xmat = xmat0
xmat = delta
}
# constraint matrix
if (nprs >= 1) {
amat_lst = list()
dmat_lst = list()
varlist = NULL
for (ipr in 1:nprs) {
ktsi = kts[[ipr]]
k1 = ktsi[[1]]
k2 = ktsi[[2]]
m1 = length(k1)
m2 = length(k2)
amat = matrix(0, nrow = 2*m1*m2 - m1 - m2, ncol = m1*m2)
irow = 0
for(j in 1:(m2-1)){
for(i in 1:m1){
irow = irow+1
amat[irow,m2*(i-1)+j]=-1
amat[irow,m2*(i-1)+j+1]=1
}
}
for(j in 1:m2){
for(i in 1:(m1-1)){
irow = irow+1
amat[irow,m2*(i)+j]=1
amat[irow,m2*(i-1)+j]=-1
}
}
amat_lst[[ipr]] = amat
# penalty matrix
dmat = matrix(0, nrow = 2*(m1 * m2 - m1 - m2), ncol = m1*m2)
irow = 0
for(j in 1:m2){
for(i in 1:(m1-2)){
irow=irow+1
dmat[irow,m2*(i+1)+j]=1/(k1[i+2]-k1[i+1])
dmat[irow,m2*i+j]=-1/(k1[i+2]-k1[i+1])-1/(k1[i+1]-k1[i])
dmat[irow,m2*(i-1)+j]=1/(k1[i+1]-k1[i])
}
}
for(j in 1:(m2-2)){
for(i in 1:m1){
irow=irow+1
dmat[irow,m2*(i-1)+j+2]=1/(k2[j+2]-k2[j+1])
dmat[irow,m2*(i-1)+j+1]=-1/(k2[j+2]-k2[j+1])-1/(k2[j+1]-k2[j])
dmat[irow,m2*(i-1)+j]=1/(k2[j+1]-k2[j])
}
}
dmat_lst[[ipr]] = dmat
#if (ipr > 1) {
#no constant for the 2nd pair
# vari = 1:(m1*m2-1)*0 + ipr
# } else {
# vari = 1:m1*m2*0 + ipr
# }
vari = 1:m1*m2*0 + ipr
#this varlist is for surface
varlist = c(varlist, vari)
}
amat = as.matrix(bdiag(amat_lst))
dmat = as.matrix(bdiag(dmat_lst))
}
#amat0 is for the wps surface now
amat0 = amat
#print (amat0[,1])
nr0 = nrow(amat0); nc0 = ncol(amat0)
#amat include the original zmat
if (p >= 1) {
#amatz = matrix(0, nrow = 2 * m1 * m2 - m1 - m2, ncol = p)
#amat = cbind(amatz, amat[, 2:(m1 * m2)])
#p doesn't include additive components but include the one vector
amatz = matrix(0, nrow = nrow(amat), ncol = p)
#amat = cbind(amatz, amat[, -1])
amat = cbind(amatz, amat)
#amat = cbind(amat, amatz)
}
#now make amat and amat0 to include additive components
nr = nrow(amat); nc = ncol(amat)
if (pb >= 1) {
tmp = matrix(0, nrow = (nr+pb), ncol = (nc+pb))
tmp0 = matrix(0, nrow = (nr0+pb), ncol = (nc0+pb))
amatb = diag(pb)
#np_add is shape == 17 and conc (4,12); conv (3,11)
if (np_add > 0) {
amatb[1:np_add,1:np_add] = 0
}
tmp[1:pb,1:pb] = amatb
tmp0[1:pb,1:pb] = amatb
tmp[(pb+1):(nr+pb), (pb+1):(nc+pb)] = amat
tmp0[(pb+1):(nr0+pb), (pb+1):(nc0+pb)] = amat0
amat = tmp
amat0 = tmp0
}
dmat0 = dmat
#print (paste('dmat', dim(dmat)))
#not penalize the addtive part and z, zmat include both
if (p >= 1) {
dmatz = matrix(0, nrow = dim(dmat)[1], ncol = p)
#dmat = cbind(dmatz, dmat[, -1])
dmat = cbind(dmatz, dmat)
#dmat = cbind(dmat, dmatz)
}
if (pb >= 1) {
dmatb = matrix(0, nrow = dim(dmat)[1], ncol = pb)
dmat = cbind(dmatb, dmat)
dmat0 = cbind(dmatb, dmat0)
}
#}
# weight
# xmat0 not include zmat;only used in edf
#print (dim(xmat))
#print (dim(amat))
#print (dim(dmat))
if (is.null(w)) {
xw0 = xmat0
yw = y
xw = xmat
zw = zmat
} else {
if (min(w) > 1e-8) {
yw = y * sqrt(w)
xw = xmat
zw = zmat
xw0 = xmat0
for (i in 1:n) {
xw[i, ] = xmat[i, ] * sqrt(w[i])
xw0[i, ] = xmat0[i, ] * sqrt(w[i])
zw[i, ] = zmat[i, ] * sqrt(w[i])
}
} else {
xw0 = xmat0; xw = xmat; yw = y; zw = zmat
}
}
# transform to cone projection
sc = 1
#print (pen)
sm = 0
if (round(pen, 6) > sm) {
ps = pen
if (pen > 1) {
warning('Large penalty term will make the inference wrong!')
}
} else if (pnt & (round(pen, 6) == 0)) {
#new: penalty interplolation
if (!gcv) {
ps = make_pen(n)
#print (ps)
} else {
#ps = make_pen(n, xw=xmat, xmat=xmat, dmat=dmat, y=y, amat=amat, gcv=gcv)
ng = 9
lams = 2^(0:8)
#lams = lams/2^8/n^(1/3)
#lams = 10*lams/2^8/n^(3/4)
lams = lams/2^8/n^(3/4)
#print (lams)
gcvs = 1:ng*0
for(i in 1:ng) {
# pen = lams[ipen]
# qv = t(xmat)%*%xmat+pen*t(dmat)%*%dmat
# umat = chol(qv)
# uinv = solve(umat)
# atil = amat%*%uinv
# zvec = t(uinv)%*%t(xmat)%*%y
# ans = coneA(zvec,atil)
# ahatc = uinv%*%ans$thetahat
# dimp = nrow(qv)
# if (length(ans$face)==0) {
# pmat = diag(dimp)
# } else if (length(ans$face)==1){
# aj = matrix(atil[ans$face,],nrow=1)
# pmat = -t(aj)%*%solve(aj%*%t(aj))%*%aj
# for(i in 1:dimp){pmat[i,i] = 1+pmat[i,i]}
# } else {
# aj = atil[ans$face,]
# pmat = -t(aj)%*%solve(aj%*%t(aj))%*%aj
# for(i in 1:dimp){pmat[i,i] = 1+pmat[i,i]}
# }
# ## get df
# bigp = xmat%*%uinv%*%pmat%*%t(uinv)%*%t(xmat)
# degf = sum(diag(bigp))
# muhat = xmat%*%ahatc
# sse = sum((y-muhat)^2)
# gcvs[ipen] = sse/(1-degf/n)^2
pen = lams[i]
qv0 = crossprod(xw)
dv0 = crossprod(dmat)
qv = qv0 + pen * dv0
cv = crossprod(xw, y)
umat = chol(qv)
uinv = solve(umat)
atil = amat %*% uinv
cvec = t(uinv) %*% t(xw) %*% y
ansi = coneA(cvec, atil, msg = FALSE)
face = ansi$face
phihat = ansi$thetahat
ahat = uinv %*% phihat
muhat = xmat %*% ahat
sse = sum((y-muhat)^2)
dp = -atil
dp = t(dp)
imat = diag(nrow(qv))
if (length(face) == 0) {
pm = imat
} else {
smat = dp[,face,drop=FALSE]
pmat_polar = smat %*% solve(crossprod(smat), t(smat))
pm = (imat-pmat_polar)
}
bigp = xmat%*%uinv%*%pm%*%t(uinv)%*%t(xmat)
edfi = sum(diag(bigp))
gcvi = sse/(1-edfi/n)^2
gcvs[i] = gcvi
}
ps = min(lams[gcvs == min(gcvs)])
}
} else if (!pnt) {
ps = 1e-6
}
if (!wt.iter) {
qmat = t(xw) %*% xw + ps * t(dmat) %*% dmat
qmat0 = t(xw0) %*% xw0 + ps * t(dmat0) %*% dmat0
umat = chol(qmat)
uinv = solve(umat)
atil = amat %*% uinv
cvec = t(uinv) %*% t(xw) %*% yw
ans = coneA(cvec, atil, msg = FALSE)
face = ans$face
phihat = ans$thetahat
ahat = uinv %*% phihat
#muhat = xw %*% ahat
muhat = xmat %*% ahat
muhatkeep = muhat
etahatkeep = muhat
coefkeep = ahat
llh = llh.fun(y, muhatkeep, etahatkeep, phihat=NULL, n, w, fml = family$family)
} else {
etahat = etahat.fun(n, y, fml = family$family)
gr = gr.fun(y, etahat, weights = w, fml = family$family)
wt = wt.fun(y, etahat, n, weights = w, fml = family$family)
#cvec = crossprod(xw, (wt * etahat - gr))
#qmat = t(xw) %*% diag(wt) %*% xw + ps * t(dmat) %*% dmat
#qmat0 = t(xw0) %*% diag(wt) %*% xw0 + ps * t(dmat0) %*% dmat0
cvec = crossprod(xmat, (wt * etahat - gr))
qmat = t(xmat) %*% diag(wt) %*% xmat + ps * t(dmat) %*% dmat
qmat0 = t(xmat0) %*% diag(wt) %*% xmat0 + ps * t(dmat0) %*% dmat0
ans = qprog(qmat, cvec, amat, 1:nrow(amat)*0, msg = FALSE)
face = ans$face
ahat = ans$thetahat
#etahat = xw %*% ahat
etahat = xmat %*% ahat
muhat = muhat.fun(etahat, fml = family$family)
diff = 1
nrep = 0
sm = 1e-8
while (diff > sm & nrep < 100) {
oldmu = muhat
nrep = nrep + 1
gr = gr.fun(y, etahat, weights = w, fml = family$family)
wt = wt.fun(y, etahat, n, weights = w, fml = family$family)
#cvec = crossprod(xw, (wt * etahat - gr))
#qmat = t(xw) %*% diag(wt) %*% xw + ps * t(dmat) %*% dmat
#qmat0 = t(xw0) %*% diag(wt) %*% xw0 + ps * t(dmat0) %*% dmat0
cvec = crossprod(xmat, (wt * etahat - gr))
qmat = t(xmat) %*% diag(wt) %*% xmat + ps * t(dmat) %*% dmat
qmat0 = t(xmat0) %*% diag(wt) %*% xmat0 + ps * t(dmat0) %*% dmat0
ans = qprog(qmat, cvec, amat, 1:nrow(amat)*0, msg = FALSE)
ahat = ans$thetahat
#etahat = xw %*% ahat
etahat = xmat %*% ahat
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
}
muhatkeep = muhat
etahatkeep = etahat
coefkeep = ahat
llh = llh.fun(y, muhatkeep, etahatkeep, phihat=NULL, n, w, fml = family$family)
}
# get trace of "proj" matrix
# include the additive part
sm = 1e-8
nz = 1:dim(amat)[1] < sm
#only additive and wps will give nz = TRUE
nz[amat %*% ahat > sm] = TRUE
if (sum(nz) < dim(amat0)[1]) {
gamj = -t(amat0[!nz, ])
if (length(gamj) == dim(xw0)[2]) {
gamj = matrix(gamj, ncol = 1)
}
aq = qr(gamj)
if (aq$rank >= 1) {
if (aq$rank == 1) {
gamj = matrix(qr.Q(aq)[, 1:aq$rank, drop = FALSE], ncol = 1)
} else {
gamj = qr.Q(aq)[, 1:aq$rank, drop = FALSE]
}
#pa = gamj %*% solve(crossprod(gamj), t(gamj))
pa = gamj %*% solve(t(gamj) %*% gamj) %*% t(gamj)
dj1 = dim(gamj)[1]; dj2 = dim(gamj)[2]
#imat = matrix(0, nrow = dj1, ncol = dj1)
#for (i in 1:dj1) {imat[i, i] = 1}
imat = diag(dj1)
uvecs = matrix(rnorm(dj1 * (dj1 - dj2)), nrow = dj1)
wmatt = (imat - pa) %*% uvecs
aqt = qr(wmatt); wmat = qr.Q(aqt)
b0mat = xw0 %*% wmat
}
} else {
b0mat = xw0
inmat = diag(dim(xmat0)[2])
wmat = inmat
}
p0mat = xmat0 %*% wmat %*% solve(t(wmat) %*% qmat0 %*% wmat) %*% t(wmat) %*% t(xmat0)
#edf = sum(diag(p0mat)) + p - 1
#new: to find edf differently
#print (ps)
dp = -atil
#for (i in 1:nrow(dp)) {
# dpi = dp[i,,drop=F]
# dpi = dpi/sqrt(tcrossprod(dpi)[1])
# dp[i,]=dpi
#}
dp = t(dp)
imat = diag(nrow(qmat))
#print (dim(imat))
#print (dim(dp))
if (length(face) == 0) {
pmat = imat
} else {
smat = dp[,face,drop=FALSE]
pmat_polar = smat %*% solve(crossprod(smat), t(smat))
pmat = (imat-pmat_polar)
}
#print (dim(smat))
bigp = xmat%*%uinv%*%pmat%*%t(uinv)%*%t(xmat)
#print (pmat)
edf = sum(diag(bigp))
#inmat = matrix(0, nrow = n, ncol = n)
#diag(inmat) = 1
#sse1 = sum((yw - xw %*% ahat)^2)
#zcoefs = ahat[1:p]
#sse0 = sum((yw - zw %*% zcoefs)^2)
#new: more than gaussian
#zcoefs don't include shape = 17
thvecs = NULL
thvecs_ut = NULL
coef_add = 0
coef_ut = 0
coef_wp = ahat
if (pb > 0) {
#print (pb)
coef_add = ahat[1:pb]
coef_wp = ahat[-(1:pb)]
capl = ncol(xmat_add)
if (!is.null(xmat_add)){
#print (paste('capl: ', capl))
thvecs = matrix(0, nrow = capl, ncol = n)
ncon = 0
vcoef_add = coef_add[1:np_add]
#print (vcoef_add)
lconv = sum(shapes_add > 2 & shapes_add < 5 | shapes_add > 10 & shapes_add < 13)
if (lconv > 0) {
dcoefs = coef_add[-c(1:lconv)]
delta_add2 = delta_add[-c(1:lconv), ,drop = FALSE]
} else {
dcoefs = coef_add
delta_add2 = delta_add
}
for (i in 1:capl) {
#thvecs[i,] = t(delta_add[varlist_add == i,]) %*% coef_add[varlist_add == i]
thvecs[i,] = t(delta_add2[varlist_add == i,]) %*% dcoefs[varlist_add == i]
if (shapes_add[i] > 2 & shapes_add[i] < 5 | shapes_add[i] > 10 & shapes_add[i] < 13) {
ncon = ncon + 1
thvecs[i,] = thvecs[i,] + vcoef_add[ncon] * xmat_add[,i]
#print (vcoef_add[ncon])
}
}
#if (!is.null(idx_s)) {
if (length(idx_s) > 0) {
thvecs0 = thvecs
thvecs0[idx_s,] = thvecs[1:length(idx_s), ]
#if (!is.null(idx)) {
if (length(idx) > 0) {
thvecs0[idx,] = thvecs[(1+length(idx_s)):capl, ]
}
thvecs = thvecs0
}
}
if (!is.null(delta_ut)) {
#print (length(coef_add))
#print (nrow(delta_ut))
#print ((length(coef_add) - nrow(delta_ut) + 1):length(coef_add))
coef_ut = coef_add[(length(coef_add) - nrow(delta_ut) + 1):length(coef_add)]
thvecs_ut = t(delta_ut) %*% coef_ut
}
if (!is.null(thvecs_ut)) {
thvecs = rbind(thvecs, t(thvecs_ut))
}
}# else {coef_add = 0; coef_wp = ahat; thvecs = NULL}
zcoefs = NULL
if (!is.null(zmat)) {
zcoefs = ahat[(pb+1):(pb+p)]
}
#vcoefs include zcoefs and shape = 17, conv and conc
# if (np_add > 0) {
# vcoefs = ahat[c(1:np_add, (pb+1):(pb+p))]
# vmat = zw[,c(1:np_add, (pb+1):(pb+p)), drop=F]
# } else {
# vcoefs = zcoefs
# vmat = zw[,(pb+1):(pb+p), drop=F]
# }
#muvhat includes the weight part
# muvhat = muhat.fun(vmat %*% vcoefs, fml = family$family)
#sse1 = sum((yw - muhat)^2)
sse1 = sum((yw - xw %*% ahat)^2)
# sse0 = sum((yw - muvhat)^2)
#new use edf instead if (n - cpar * edf) < 0
# np = ncol(vmat)
np = 0
if (!is.null(zmat)) {
np = ncol(zmat)
}
#if ((n - np - cpar * edf) <= 0) {
if ((n - cpar * edf) <= 0) {
sig2hat = sse1 / edf
} else {
sig2hat = sse1 / (n - cpar * edf)
#print (sse1)
}
#print (paste('sig2hat', sig2hat))
if (p >= 1) {
#w2 = as.vector(w / deriv.fun(muhatkeep, fml = family$family))
inmat = diag(n)
#pm = one %*% solve(crossprod(one)) %*% t(one)
#covmat = solve(t(zmat[,(pb+1):(pb+p), drop=F]) %*% (inmat - p0mat + pm) %*% zmat[,(pb+1):(pb+p), drop=F])
#new:
# qmat0 = t(xw0) %*% xw0 + ps * t(dmat0) %*% dmat0
# umat0 = chol(qmat0)
# uinv0 = solve(umat0)
# atil0 = amat0 %*% uinv0
#
# dp0 = -t(atil0)
# imat0 = diag(nrow(qmat0))
# if (length(face) == 0) {
# pmat0 = imat0
# } else {
# smat0 = dp0[,face,drop=FALSE]
# pmat_polar0 = smat0 %*% solve(crossprod(smat0), t(smat0))
# pmat0 = (imat0-pmat_polar0)
# }
# bigp0 = xmat0%*%uinv0%*%pmat0%*%t(uinv0)%*%t(xmat0)
# zm = zmat[,(pb+1):(pb+p), drop=F]
# covmat = solve(t(zm) %*% (inmat - bigp0) %*% zm)
#test:
#one = 1:nrow(pmat)*0 + 1
#pm = one %*% solve(crossprod(one)) %*% t(one)
#print (dim(pmat))
#print (dim(pm))
mat1 = uinv %*% pmat %*% t(uinv) %*% t(xmat)
covmat0 = sig2hat * mat1 %*% t(mat1)
covmat = covmat0[(pb+1):(pb+p), (pb+1):(pb+p), drop=FALSE]
#print (covmat)
#if (wt.iter) {
# sez = sqrt(diag(covmat))
#} else {
#sez = sqrt(diag(covmat) * sig2hat)
sez = sqrt(diag(covmat))
#print (paste('sig:',sig2hat))
#print (sez)
#}
tz = zcoefs / sez
#print (zcoefs)
#print (tz)
#new use edf instead if (n - cpar * edf) < 0
if ((n - cpar * edf) <= 0) {
pz = 2 * (1 - pt(abs(tz), edf))
if (np > 1) {
warning ('Effective degrees of freedom is close to the number of observations! Inference about parametric covariates is not reliable!')
}
#print ('Check pz!')
} else {
pz = 2 * (1 - pt(abs(tz), n - cpar * edf))
#print (edf)
#print (cpar)
#print (pz)
}
}
# get unconstrained penalized estimator
#if (!wt.iter) {
# prmatu = xw %*% solve(qmat) %*% t(xw)
#new:
# etahatu = prmatu %*% yw
# muhatu = muhat.fun(etahatu, fml = family$family)
# sseu = sum((yw - muhatu)^2)
# edfu = sum(diag(prmatu))
#} else {
# if (is.null(w)) {
# w = 1:n*0 + 1
# }
# prior.w = w
# prmatu = xw %*% solve(qmat) %*% t(xw)
# nrep = 0
# muhatu = mean(y) + 1:n*0
# etahatu = linkfun(muhatu)
# diff = 1
# if (family$family == "binomial") {
# mdiff = abs(max(muhatu) - 1) > sm
# } else {mdiff = TRUE}
# while (diff > sm & mdiff & nrep < n^2) {
# nrep = nrep + 1
# oldmu = muhatu
# zhat = etahatu + (y - muhatu) * deriv.fun(muhatu, fml = family$family)
# w = as.vector(prior.w * (deriv.fun(muhatu, fml = family$family))^(-1))
# #b = solve(tvmat %*% vmat) %*% tvmat %*% zhat
# #etahat = xmat %*% b
# etahatu = prmatu %*% zhat
# muhatu = muhat.fun(etahatu, fml = family$family)
# diff = mean((muhatu - oldmu)^2)
# mdiff = abs(max(muhatu) - 1)
# if (family$family == "binomial") {
# mdiff = abs(max(muhatu) - 1) > sm
# } else {mdiff = TRUE}
# }
# sseu = sum((y - muhatu)^2)
# edfu = sum(diag(prmatu))
#}
#new: get cic
cic_val = NULL
if (is.null(w)) {
w = rep(1, n)
}
if (cic & nsim > 0) {
edfs = 1:nsim*0
if (!wt.iter) {
for (isim in 1:nsim) {
ysim = rnorm(n)
ysimw = ysim * sqrt(w)
cveci = t(uinv) %*% t(xw) %*% ysimw
ansi = coneA(cveci, atil, msg = FALSE)
phihati = ansi$thetahat
ahati = uinv %*% phihati
edfi = wps_getedf(ahati, sm, amat, amat0, xw0, xmat0, qmat0, np)
edfs[isim] = edfi
}
#cic = llh + log(2 * (mean(edfs) + np) / (n - np - 1.5 * mean(edfs)) + 1)
#cic = log(sse1) + log(2 * (mean(edfs) + np) / (n - np - 1.5 * mean(edfs)) + 1)
cic_val = llh + log(2 * (mean(edfs)) / (n - np - 1.5 * (mean(edfs) - np)) + 1)
} else {
if (family$family == "poisson") {
mu0 = mean(y)
} else {mu0 = NULL}
for (isim in 1:nsim) {
ysim = ysim.fun(n, mu0, fml = family$family)
etahat = etahat.fun(n, ysim, fml = family$family)
gr = gr.fun(ysim, etahat, weights = w, fml = family$family)
wt = wt.fun(ysim, etahat, n, weights = w, fml = family$family)
cvec = crossprod(xmat, (wt * etahat - gr))
qmat = t(xmat) %*% diag(wt) %*% xmat + ps * t(dmat) %*% dmat
qmat0 = t(xmat0) %*% diag(wt) %*% xmat0 + ps * t(dmat0) %*% dmat0
ans = qprog(qmat, cvec, amat, 1:nrow(amat)*0, msg = FALSE)
ahat = ans$thetahat
etahat = xmat %*% ahat
muhat = muhat.fun(etahat, fml = family$family)
diff = 1
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > 1e-8
} else {mdiff = TRUE}
nrep = 0
while (diff > sm & nrep < 100 & mdiff) {
oldmu = muhat
nrep = nrep + 1
gr = gr.fun(ysim, etahat, weights = w, fml = family$family)
wt = wt.fun(ysim, etahat, n, weights = w, fml = family$family)
cvec = crossprod(xmat, (wt * etahat - gr))
qmat = t(xmat) %*% diag(wt) %*% xmat + ps * t(dmat) %*% dmat
qmat0 = t(xmat0) %*% diag(wt) %*% xmat0 + ps * t(dmat0) %*% dmat0
ansi = qprog(qmat, cvec, amat, 1:nrow(amat)*0, msg = FALSE)
ahati = ansi$thetahat
etahat = xmat %*% ahati
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > 1e-8
} else {mdiff = TRUE}
}
edfi = wps_getedf(ahati, sm, amat, amat0, xw0, xmat0, qmat0, np)
edfs[isim] = edfi
}
#cic = llh + log(2 * (mean(edfs) + np) / (n - np - 1.5 * mean(edfs)) + 1)
cic_val = llh + log(2 * (mean(edfs)) / (n - np - 1.5 * (mean(edfs) - np)) + 1)
}
}
#print (edf)
#new: test for constant vs wps
#vmat = qr.Q(qr(t(atil)), complete = TRUE)[, -(1:(qr(t(atil))$rank)), drop = FALSE]
vmat = cbind(1:n*0+1)
if (!is.null(zmat)) {
vmat = cbind(vmat, zmat)
}
np = ncol(vmat)
if (!is.null(w)) {
pvmat = vmat %*% solve(crossprod(vmat), t(vmat))
} else {
vw = vmat
for (i in 1:nrow(vmat)) {
vw[i, ] = vmat[i, ] * sqrt(w[i])
}
pvmat = vmat %*% solve(crossprod(vw), t(vw))
}
#phihat0 = pvmat %*% cvec
#ahat0 = uinv %*% phihat0
#muhat0 = xmat %*% ahat0
muhat0 = pvmat %*% y
if (!is.null(w)) {
sse0 = sum(w * (y - muhat0)^2)
sse1 = sum(w * (y - muhat)^2)
} else {
sse0 = sum((y - muhat0)^2)
sse1 = sum((y - muhat)^2)
}
bval = (sse0 - sse1) / sse0
#print (bval)
#g = qr(amat)
#m = ncol(amat)
#dim0 = m - g$rank
#test = TRUE
pval = NULL
if (pvf) {
nloop = 200
sm = 1e-5
if (bval > sm) {
#bdist = 0:nloop*0
bdist = NULL
for (iloop in 1:nloop) {
#ysim = muhat0 + rnorm(n)
#new: add (sig2hat)^(1/2) when there's z
ysim = muhat0 + rnorm(n)*(sig2hat)^(1/2)
ysimw = ysim
if (!is.null(w)) {
ysimw = ysim * sqrt(w)
}
cveci = t(uinv) %*% t(xw) %*% ysimw
ansi = try(coneA(cveci, atil))
if (any(class(ansi) %in% 'try-error')) {
next
}
phi = ansi$thetahat
ah = uinv %*% phi
muh = xmat %*% ah
#phi0 = pvmat %*% cveci
#ah0 = uinv %*% phi0
#muh0 = xmat %*% ah0
#muh0 = pvmat %*% ysimw
muh0 = pvmat %*% ysim
if (!is.null(w)) {
sse0 = sum(w * (ysim - muh0)^2)
sse1 = sum(w * (ysim - muh)^2)
} else {
sse0 = sum((ysim - muh0)^2)
sse1 = sum((ysim - muh)^2)
}
bstat = (sse0 - sse1) / sse0
bdist = c(bdist, bstat)
#bdist[iloop] = bstat
}
pval = sum(bdist > bval)/nloop
} else {pval = 1}
}
ans = new.env()
ans$pval = pval
ans$bval = bval
#ans$k1 = k1
#ans$k2 = k2
for (ipr in 1:nprs) {
decri = decrs[[ipr]]
ktsi = kts[[ipr]]
k1 = ktsi[[1]]
k2 = ktsi[[2]]
if (decri[1]) {
k1 = -rev(k1)
}
if (decri[2]) {
k2 = -rev(k2)
}
ktsi[[1]] = k1
ktsi[[2]] = k2
kts[[ipr]] = ktsi
}
ans$kts = kts
ans$muhat = muhatkeep
ans$etahat = etahatkeep
#ans$muplot = mupl
#ans$muhatu = muhatu
#ans$muplotu = muplu
ans$gcv = sse1 / (1 - edf / n)^2
#ans$gcvu = sseu / (1 - edfu/n)^2
#ans$ssr = sse1
ans$sse1 = sse1
#ans$sse0 = sse0
ans$edf = edf
if (cic & nsim > 0) {
ans$edf0 = mean(edfs) #+ np
} else {ans$edf0 = np}
#ans$nz = amat %*% ahat
#ans$edfu = edfu
ans$coef_add = coef_add
ans$coef_ut = coef_ut
ans$coef_wp = coef_wp
ans$coefs = coefkeep
#ans$coefsu = solve(qmat) %*% t(xw) %*% yw
#include coef for one vector
#ans$zcoefs = ahat[1:p]
ans$zcoefs = zcoefs
ans$zmat = zmat
#ans$zmat_0 = zmat_0
ans$sig2hat = sig2hat
ans$delta = xmat
ans$pen = ps
ans$d0 = p + np_add
#print (paste('p: ', p))
ans$cpar = cpar
#ans$gcvus = gcvus
#ans$lambdas_pen = lambdas_pen
#if (p >= 2) {
if (p >= 1) {
ans$sez = sez
ans$pz = pz
ans$covmat = covmat
ans$tz = tz
} else {ans$sez = NULL; ans$pz = NULL; ans$covmat = NULL; ans$tz = NULL}
#print (sig2hat)
ans$cic = cic_val
ans$varlist = varlist
ans$etacomps = thvecs
#new:
ans$amat = amat
ans$dmat = dmat
#ans$vmat = vmat
return (ans)
}
####################################################################
#four monotonicity functions for warped-plane fit
#new: attr(xm, 'shape') are all changed into pairs of numbers because of testpar
#test more
####################################################################
s.incr.incr <- function(x1, x2, numknots = c(0, 0), knots = list(k1 = 0, k2 = 0), space = c("E", "E"))
{
cl <- match.call()
pars1 <- match.call()[2]
pars2 <- match.call()[3]
xm <- cbind(x1, x2)
attr(xm, "name") <- c(deparse(pars1$x1), deparse(pars2$x2))
attr(xm, "nm") <- c(deparse(pars1$x1), deparse(pars2$x2))
#attr(xm, "shape") <- "wps_ii"
attr(xm, "shape") <- c(1, 1)
attr(xm, "numknots") <- numknots
attr(xm, "knots") <- knots
attr(xm, "space") <- space
attr(xm, "decreasing") <- c(FALSE, FALSE)
attr(xm, "categ") <- "warp"
#class(xm) <- "warp"
#warp <<- TRUE
return (xm)
}
s.incr.decr <- function(x1, x2, numknots = c(0, 0), knots = list(k1 = 0, k2 = 0), space = c("E", "E"))
{
cl <- match.call()
pars1 <- match.call()[2]
pars2 <- match.call()[3]
xm <- cbind(x1, x2)
attr(xm, "name") <- c(deparse(pars1$x1), deparse(pars2$x2))
attr(xm, "nm") <- c(deparse(pars1$x1), deparse(pars2$x2))
#attr(xm, "shape") <- "wps_id"
attr(xm, "shape") <- c(1, 2)
attr(xm, "numknots") <- numknots
attr(xm, "knots") <- knots
attr(xm, "space") <- space
attr(xm, "decreasing") <- c(FALSE, TRUE)
attr(xm, "categ") <- "warp"
#warp <<- TRUE
#class(xm) <- "warp"
return (xm)
}
s.decr.incr <- function(x1, x2, numknots = c(0, 0), knots = list(k1 = 0, k2 = 0), space = c("E", "E"))
{
cl <- match.call()
pars1 <- match.call()[2]
pars2 <- match.call()[3]
xm <- cbind(x1, x2)
attr(xm, "name") <- c(deparse(pars1$x1), deparse(pars2$x2))
attr(xm, "nm") <- c(deparse(pars1$x1), deparse(pars2$x2))
#attr(xm, "shape") <- "wps_di"
attr(xm, "shape") <- c(2, 1)
attr(xm, "numknots") <- numknots
attr(xm, "knots") <- knots
attr(xm, "space") <- space
attr(xm, "decreasing") <- c(TRUE, FALSE)
attr(xm, "categ") <- "warp"
#warp <<- TRUE
#class(xm) <- "warp"
return (xm)
}
s.decr.decr <- function(x1, x2, numknots = c(0, 0), knots = list(k1 = 0, k2 = 0), space = c("E", "E"))
{
cl <- match.call()
pars1 <- match.call()[2]
pars2 <- match.call()[3]
xm <- cbind(x1, x2)
attr(xm, "name") <- c(deparse(pars1$x1), deparse(pars2$x2))
attr(xm, "nm") <- c(deparse(pars1$x1), deparse(pars2$x2))
#attr(xm, "shape") <- "wps_dd"
attr(xm, "shape") <- c(2, 2)
attr(xm, "numknots") <- numknots
attr(xm, "knots") <- knots
attr(xm, "space") <- space
attr(xm, "decreasing") <- c(TRUE, TRUE)
attr(xm, "categ") <- "warp"
#warp <<- TRUE
#class(xm) <- "warp"
return (xm)
}
###############################################################
#makedelta_wps: make delta to a pair of warped-plane variables#
###############################################################
makedelta_wps <- function(x1t, x2t, m1_0 = 0, m2_0 = 0, k1 = 0, k2 = 0, space = c("E", "E"), decreasing = c(FALSE, FALSE), interp = FALSE)
{
# x1 and x2 no need to sort
# if decreasing (all calculations done for doubly-increasing case)
n = length(x1t)
if (decreasing[1]) {
#print (k1 != 0)
x1 = -x1t
#if (!is.null(k1)) {
if (!all(k1 == 0)) {
m1 = length(k1); k1 = -k1[m1:1]
}
} else {x1 = x1t}
if (decreasing[2]) {
x2 = -x2t
#if (!is.null(k2)) {
if (!all(k2 == 0)) {
m2 = length(k2); k2 = -k2[m2:1]
}
} else {x2 = x2t}
# determine whether to use default knots or user-defined knots
# check if k1 and k2 > 1 elems
make1 = FALSE
#if (is.null(k1)) {
#if (k1 == 0) {
if (all(k1 == 0)) {
make1 = TRUE
} else if (min(k1) > min(x1) | max(k1) < max(x1)) {
warning ('Predictor should be within the range of the knots! User-defined knots not used!')
make1 = TRUE
# new: at least 4 kts?
}# else if (length(k1) < 4) {
# make1 = TRUE
#} else if (m1_0 >= 4) {
# make1 = TRUE
#}
make2 = FALSE
#if (is.null(k2)) {
#if (k2 == 0) {
if (all(k2 == 0)) {
make2 = TRUE
} else if (min(k2) > min(x2) | max(k2) < max(x2)) {
warning ('Predictor should be within the range of the knots! User-defined knots not used!')
make2 = TRUE
}# else if (length(k2) < 4) {
# make2 = TRUE
#} else if (m2_0 >= 4) {
# make2 = TRUE
#}
# add quantile part in it
if (make1) {
# new:
#print (m1_0 == 12L)? !is.integer(m1_0) not work
#print (m1_0)
if (m1_0 < 4 | round(m1_0, 0) != m1_0) {
#if (m1_0 < 4) {
if (m1_0 != 0) {
warning ('At least four knots should be used! Number of knots is re-defined!')
}
#m1 = 2 * round(n^(1/6)) + 4
#new:
#m1 = round(6*n^(1/6))
#m1 = round(4*n^(1/6))
m1 = round(5*n^(1/6))
#print (m1)
} else {m1 = m1_0}
if (space[1] == "Q") {
k1 = quantile(unique(x1), probs = seq(0, 1, length = m1), names = FALSE)
}
if (space[1] == "E") {
k1 = 0:(m1 - 1) / (m1 - 1) * (max(x1) - min(x1)) + min(x1)
#print (0:(m1 - 1) / (m1 - 1) * (max(x1) - min(x1)) + min(x1) )
#k1 = 0:(m1 - 1) / (m1 - 1)
}
#k1 = 0:(m1 - 1) / (m1 - 1) * (max(x1) - min(x1)) + min(x1)
} else { m1 = length(k1) }
if (make2) {
#new:
if (m2_0 < 4 | round(m2_0, 0) != m2_0) {
if (m2_0 != 0) {
warning ('At least four knots should be used! Number of knots is re-defined!')
}
#m2 = 2 * round(n^(1/6)) + 4
#m2 = round(6*n^(1/6))
#m2 = round(4*n^(1/6))
m2 = round(5*n^(1/6))
} else {m2 = m2_0}
if (space[2] == "Q") {
k2 = quantile(unique(x2), probs = seq(0, 1, length = m2), names = FALSE)
}
if (space[2] == "E") {
k2 = 0:(m2 - 1) / (m2 - 1) * (max(x2) - min(x2)) + min(x2)
#k2 = 0:(m2 - 1) / (m2 - 1)
}
#k2 = 0:(m2 - 1) / (m2 - 1) * (max(x2) - min(x2)) + min(x2)
} else { m2 = length(k2) }
## check to see if empty knot intervals
#new: if it's for prediction, then skip
if (!interp) {
rm1 = k1[m1]; rm2 = k2[m2]
keep = 1:m1 > 0
for (i in 2:m1) {
if (sum(x1 >= k1[i-1] & x1 < k1[i]) == 0) {
keep[i] = FALSE
}
}
k1 = k1[keep]; m1 = length(k1); k1[m1] = rm1
keep = 1:m2 > 0
for (i in 2:m2) {
if (sum(x2 >= k2[i-1] & x2 < k2[i]) == 0) {
keep[i] = FALSE
}
}
k2 = k2[keep]; m2 = length(k2); k2[m2] = rm2
}
# make the basis functions
#b1 = matrix(0, nrow = n, ncol = m1)
#b2 = matrix(0, nrow = n, ncol = m2)
#for (i in 2:(m1 - 1)) {
# i1 = x1 >= k1[i-1] & x1 <= k1[i]
# b1[i1, i] = (x1[i1] - k1[i-1]) / (k1[i] - k1[i-1])
# i2 = x1 > k1[i] & x1 <= k1[i+1]
# b1[i2, i] = (k1[i+1] - x1[i2]) / (k1[i+1] - k1[i])
#}
# i1 = x1 >= k1[1] & x1 <= k1[2]
# b1[i1, 1] = (k1[2] - x1[i1]) / (k1[2] - k1[1])
# i2 = x1 > k1[m1-1] & x1 <= k1[m1]
# b1[i2, m1] = (x1[i2] - k1[m1-1]) / (k1[m1] - k1[m1-1])
#
# for (i in 2:(m2 - 1)) {
# i1 = x2 >= k2[i-1] & x2 <= k2[i]
# b2[i1, i] = (x2[i1] - k2[i-1]) / (k2[i] - k2[i-1])
# i2 = x2 > k2[i] & x2 <= k2[i+1]
# b2[i2, i] = (k2[i+1] - x2[i2]) / (k2[i+1] - k2[i])
# }
# i1 = x2 >= k2[1] & x2 <= k2[2]
# b2[i1, 1] = (k2[2] - x2[i1]) / (k2[2] - k2[1])
# i2 = x2 > k2[m2-1] & x2 <= k2[m2]
# b2[i2, m2] = (x2[i2] - k2[m2-1]) / (k2[m2] - k2[m2-1])
# ## design matrix
# xmat0 = matrix(nrow = n, ncol = m1 + m2 - 1 + (m1 - 1) * (m2 - 1))
# xmat0[ ,1] = 1:n*0 + 1
# xmat0[ ,2:m1] = b1[ ,2:m1]
# xmat0[ ,(m1 + 1):(m1 + m2 - 1)] = b2[ ,2:m2]
# for (i in 1:(m1 - 1)) {
# xmat0[ ,(m1 + m2 + (i - 1) * (m2 - 1)):(m1 + m2 - 1 + i * (m2 - 1))] = b1[ ,i + 1] * b2[ ,2:m2]
# }
#if (dim(zmat)[2] > 1) {
# xmat = cbind(zmat, xmat0[ ,2:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))])
#} else {xmat = xmat0}
#bmat = xmat0[ ,2:(m1 + m2 - 1 + (m1 - 1) * (m2 - 1))]
# ignore the zmat for now
# xmat = xmat0
# columns of delta are edges, different from other make_delta in cgam
bmat = matrix(0, nrow=n, ncol=m1*m2)
for(i in 1:(m1-1)){
for(j in 1:(m2-1)){
ii=x1>=k1[i]&x1<=k1[i+1]&x2>=k2[j]&x2<=k2[j+1]
#rg_ij = (k1[i+1]-k1[i])*(k2[j+1]-k2[j])
bmat[ii,m2*(i-1)+j]=(k1[i+1]-x1[ii])*(k2[j+1]-x2[ii])/((k1[i+1]-k1[i])*(k2[j+1]-k2[j]))
bmat[ii,m2*(i-1)+j+1]=(k1[i+1]-x1[ii])*(x2[ii]-k2[j])/((k1[i+1]-k1[i])*(k2[j+1]-k2[j]))
bmat[ii,m2*i+j]=(x1[ii]-k1[i])*(k2[j+1]-x2[ii])/((k1[i+1]-k1[i])*(k2[j+1]-k2[j]))
bmat[ii,m2*i+j+1]=(x1[ii]-k1[i])*(x2[ii]-k2[j])/((k1[i+1]-k1[i])*(k2[j+1]-k2[j]))
}
}
ans = new.env()
ans$delta = bmat
ans$k1 = k1
ans$k2 = k2
return (ans)
#attr(delta, "shape") = "warp"
#delta
}
##############################
#penalty interpolation
##############################
make_pen = function(n, xw=NULL, xmat=NULL, dmat=NULL, y=NULL, amat=NULL, gcv=FALSE) {
if (!gcv) {
if (n <= 100) {
lambda = 0.06
}
if (n >= 5000) {
lambda = 0.026
}
if (n > 100 & n < 5000) {
ns = c(1, 2, 4, 8, 10, 20, 50)*100
lams = c(6, 5, 4, 3.4, 3.2, 2.8, 2.6)/100
diff_vec = sign(n - ns)
st = rev(which(diff_vec == 1L))[1]
ed = which(diff_vec == -1L)[1]
my_line = function(xp = NULL, y, x, end=2, start=1) {
slope = NULL
intercept = NULL
yp = NULL
slope = (y[end] - y[start]) / (x[end] - x[start])
intercept = y[end] - slope * x[end]
yp = intercept + slope * xp
return (yp)
}
yvec = c(lams[st], lams[ed])
xvec = c(ns[st], ns[ed])
lambda = my_line(xp = n, y = yvec, x = xvec)
}
} else {
#use gcv to find lambda
#ng = 20
#lams = seq(1e-4, 1, length=20)
#lams = 2^(1:ng)
#lams = 2*lams/max(lams)
#gcvs = 1:ng*0
ng = 9
lams = 2^(0:8)
lams = lams/2^8/n^(1/3)
#print (lams)
gcvs = 1:ng*0
for(i in 1:ng) {
pen = lams[i]
qv0 = crossprod(xw)
dv0 = crossprod(dmat)
qv = qv0 + pen * dv0
cv = crossprod(xw, y)
umat = chol(qv)
uinv = solve(umat)
atil = amat %*% uinv
cvec = t(uinv) %*% t(xw) %*% y
ansi = coneA(cvec, atil, msg = FALSE)
face = ansi$face
phihat = ansi$thetahat
ahat = uinv %*% phihat
muhat = xmat %*% ahat
sse = sum((y-muhat)^2)
dp = -atil
dp = t(dp)
imat = diag(nrow(qv))
if (length(face) == 0) {
pm = imat
} else {
smat = dp[,face,drop=FALSE]
pmat_polar = smat %*% solve(crossprod(smat), t(smat))
pm = (imat-pmat_polar)
}
bigp = xmat%*%uinv%*%pm%*%t(uinv)%*%t(xmat)
#tst = bigp%*%y
#print (all.equal(tst, muhat))
edfi = sum(diag(bigp))
#edfi = sum(diag(xw %*% solve(qv) %*% t(xw)))
gcvi = sse/(1-edfi/n)^2
gcvs[i] = gcvi
#print (sse)
}
#plot(lams, gcvs, type='o')
#lambda = (lams[which.min(gcvs)])[1]
lambda = min(lams[gcvs == min(gcvs)])
}
return (lambda)
}
#######################
#amat and penalty bmat#
#######################
makeamat_wps <- function(kts, nprs) {
#if (nprs >= 1) {
amat_lst = list()
dmat_lst = list()
varlist = NULL
for (ipr in 1:nprs) {
ktsi = kts[[ipr]]
k1 = ktsi[[1]]
k2 = ktsi[[2]]
m1 = length(k1)
m2 = length(k2)
amat = matrix(0, nrow = 2*m1*m2 - m1 - m2, ncol = m1*m2)
amat[1, 2] = 1
amat[2, m1 + 1] = 1
irow = 2
for (i2 in 2:m2) {
irow = irow+1
amat[irow, 2] = 1; amat[irow, m1 + m2 + i2 - 2] = 1
}
for (i1 in 2:m1) {
irow = irow + 1
amat[irow, m1 + 1] = 1; amat[irow, m1 + m2 + (i1 - 2) * (m2 - 1)] = 1
}
for (i1 in 2:(m1 - 1)) {
irow = irow + 1
amat[irow, i1] = -1; amat[irow, i1 + 1] = 1
}
for (i2 in 2:(m2 - 1)) {
irow = irow + 1
amat[irow, m1 + i2 - 1] = -1
amat[irow, m1 + i2] = 1
}
for (i1 in 2:(m1 - 1)) {
for (i2 in 2:m2) {
irow = irow + 1
amat[irow, i1] = -1
amat[irow, i1 + 1] = 1
amat[irow, m1 + m2 - 2 + (i1 - 2) * (m2 - 1) + i2] = -1
amat[irow, m1 + m2 - 2 + (i1 - 1) * (m2 - 1) + i2] = 1
}
}
for (i2 in 2:(m2 - 1)) {
for (i1 in 2:m1) {
irow = irow + 1
amat[irow, m1 + i2 - 1] = -1
amat[irow, m1 + i2] = 1
amat[irow, m1 + m2 - 2 + (i1 - 2) * (m2 - 1) + i2] = -1
amat[irow, m1 + m2 - 1 + (i1 - 2) * (m2 - 1) + i2] = 1
}
}
if (ipr > 1) {
amat = amat[,-1]
}
amat_lst[[ipr]] = amat
# penalty matrix
dmat = matrix(0, nrow = 2 * (m1 * m2 - m1 - m2), ncol = m1 * m2)
# by row
irow = 1
dmat[irow, 2] = -2; dmat[irow, 3] = 1
for (i in 2:(m1 - 2)) {
irow = irow + 1
dmat[irow, i] = 1; dmat[irow, i + 1] = -2; dmat[irow, i + 2] = 1
}
for (ik2 in 2:m2) {
irow = irow + 1
dmat[irow, 2] = -2; dmat[irow, 3] = 1
dmat[irow, m1 + m2 - 1 + ik2 - 1] = -2
dmat[irow, m1 + 2 * m2 + ik2 - 3] = 1
for (ik1 in 2:(m1 - 2)) {
irow = irow + 1
dmat[irow, ik1] = 1; dmat[irow, ik1 + 1] = -2; dmat[irow, ik1 + 2] = 1
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 2) + ik2 - 1] = 1
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 1) + ik2 - 1] = -2
dmat[irow, m1 + m2 - 1 + (m2 - 1) * ik1 + ik2 - 1] = 1
}
}
# by col
irow = irow + 1
dmat[irow, m1 + 1] = -2; dmat[irow, m1 + 2] = 1
for (i in 2:(m2 - 2)) {
irow = irow + 1
dmat[irow, m1 + i - 1] = 1; dmat[irow, m1 + i] = -2; dmat[irow, m1 + i + 1] = 1
}
for (ik1 in 2:m1) {
irow = irow + 1
dmat[irow, m1 + 1] = -2; dmat[irow, m1 + 2] = 1
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 2) + 1] = -2
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 2) + 2] = 1
for (ik2 in 2:(m2 - 2)) {
irow = irow + 1
dmat[irow, m1 + ik2 - 1] = 1; dmat[irow, m1 + ik2] = -2; dmat[irow, m1 + ik2 + 1] = 1
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 2) + ik2 - 1] = 1
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 2) + ik2] = -2
dmat[irow, m1 + m2 - 1 + (m2 - 1) * (ik1 - 2) + ik2 + 1] = 1
}
}
if (ipr > 1) {
dmat = dmat[,-1]
}
#Dmat = cbind(Dmat, dmat)
dmat_lst[[ipr]] = dmat
if (ipr > 1) {
#no constant for the 2nd pair
vari = 1:(m1*m2-1)*0 + ipr
} else {
vari = 1:m1*m2*0 + ipr
}
varlist = c(varlist, vari)
}
amat = as.matrix(bdiag(amat_lst))
#dmat = Dmat
dmat = as.matrix(bdiag(dmat_lst))
ans = list(amat = amat, dmat = dmat, varlist = varlist)
return (ans)
#}
}
#################
#new coef method#
#################
coef.cgam <- function(object,...) {
ans <- object$coefs
ans
}
coef.wps <- function(object,...) {
ans <- object$coefs
ans
}
coef.trispl <- function(object,...) {
ans <- object$coefs
ans
}
coef.cgam.polr <- function(object,...) {
ans <- object$coefs
ans
}
###################
#new fitted method#
###################
fitted.cgam <- function(object,...) {
ans <- object$muhat
ans
}
fitted.wps <- function(object,...) {
ans <- object$muhat
ans
}
fitted.trispl <- function(object,...) {
ans <- object$muhat
ans
}
#fitted.cgam.polr <- function(object,...) {
# ans <- object$muhat
# ans
#}
fitted.cgam.polr <- function(object,...) {
a <- object$zeta
eta <- object$muhat
lev <- object$lev
nc <- length(a) + 1
n <- length(eta)
ps <- matrix(0, nrow = nc, ncol = n)
for (i in 1:nc) {
if (i == 1) {
ps[i,] <- pfun(a[1] - eta)
} else if (i == nc) {
ps[i,] <- 1 - pfun(a[nc-1] - eta)
} else {
ps[i,] <- pfun(a[i] - eta) - pfun(a[i-1] - eta)
}
}
ps <- t(ps)
dimnames(ps) <- list(1:n, lev)
return (ps)
}
#############################
#shape selection part
#############################
#get(x = "s", pos = "package:cgam")
#new: add npop; per.mutate
ShapeSelect <- function(formula, family = gaussian, cpar = 2, data = NULL, weights = NULL, npop = 200, per.mutate = 0.05, genetic = FALSE) {
#if (exists("s", parent.frame()) & class(get("s", envir = parent.frame())) == "function") {
if (exists("s", parent.frame()) & inherits(get("s", envir = parent.frame()), "function")) {
if (!identical(get("s", envir = parent.frame()), cgam::s)) {
assign("s", cgam::s, envir = parent.frame())
}
}
cl <- match.call()
if (is.character(family))
family <- get(family, mode = "function", envir = parent.frame())
if (is.function(family))
family <- family()
if (is.null(family$family))
stop("'family' not recognized!")
mf <- match.call(expand.dots = FALSE)
m <- match(c("formula", "data"), names(mf), 0L)
mf <- mf[c(1L, m)]
mf[[1L]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
ynm <- names(mf)[1]
mt <- attr(mf, "terms")
y <- model.response(mf, "any")
if (family$family == "binomial") {
#if (class(y) == "factor") {
if(inherits(y, "factor")){
y <- ifelse(y == levels(y)[1], 0, 1)
}
#new: test
#if (class(y) == "character") {
if(inherits(y, "character")){
y <- ifelse(factor(y) == levels(factor(y))[1], 0, 1)
}
}
#print (head(y))
shpsx <- list(); shpsz <- list(); shpst <- list(); shpsvx <- NULL
ix <- 1; iz <- 1; itr <- 1; sel <- FALSE
xmat <- NULL; xnms <- NULL
vxmat <- NULL; vxnms <- NULL
zmat <- NULL; znms <- NULL; zfacs <- NULL
vzmat <- NULL; vznms <- NULL; vzfacs <- NULL
trmat <- NULL; trnms <- NULL; vtrmat <- NULL; vtrnms <- NULL
for (i in 2:ncol(mf)) {
if (!is.null(attributes(mf[, i])$type)) {
if (attributes(mf[, i])$type == "fac" | attributes(mf[, i])$type == "lin") {
if (attributes(mf[, i])$type == "fac") {
zfacs <- c(zfacs, TRUE)
} else {
#if (is.character(mf[,i])) {
#mf[,i] = ifelse(factor(mf[,i]) == levels(factor(mf[,i]))[1], 0, 1)
# nm <- attributes(mf[,i])$nm
# mf[,i] <- ifelse(factor(mf[,i]) == levels(factor(mf[,i]))[1], 0, 1)
# attr(mf[,i], "type") <- "lin"
# attr(mf[,i], "shape") <- c(0, 1)
# attr(mf[,i], "nm") <- nm
# zfacs <- c(zfacs, TRUE)
#} else {
zfacs <- c(zfacs, FALSE)
#}
}
zmat <- cbind(zmat, mf[, i])
znms <- c(znms, attributes(mf[, i])$nm)
shpsz[[iz]] <- attributes(mf[, i])$shape
iz <- iz + 1
sel <- TRUE
}
#if (attributes(mf[, i])$type == "lin") {
# zfacs <- c(zfacs, FALSE)
# zmat <- cbind(zmat, mf[, i])
#temp
#znms <- c(znms, names(mf)[i])
# znms <- c(znms, attributes(mf[, i])$nm)
# shpsz[[iz]] <- c(0, 1)
# iz <- iz + 1
#}
if (attributes(mf[, i])$type == "nparam") {
xmat <- cbind(xmat, mf[, i])
xnms <- c(xnms, attributes(mf[, i])$nm)
shpsx[[ix]] <- attributes(mf[, i])$shape
ix <- ix + 1
sel <- TRUE
}
#if (attributes(mf[, i])$type == "ord.tree") {
if (attributes(mf[, i])$type == "tree") {
trmat <- cbind(trmat, mf[, i])
trnms <- c(trnms, attributes(mf[, i])$nm)
shpst[[itr]] <- attributes(mf[, i])$shape
itr <- itr + 1
sel <- TRUE
}
} else {
if (is.numeric(attributes(mf[, i])$shape)) {
shpsvx <- c(shpsvx, attributes(mf[, i])$shape)
vxmat <- cbind(vxmat, mf[, i])
vxnms <- c(vxnms, attributes(mf[, i])$nm)
} else if (is.character(attributes(mf[, i])$shape)) {
if (attributes(mf[, i])$shape == "tree") {
vtrmat <- cbind(vtrmat, mf[, i])
vtrnms <- c(vtrnms, attributes(mf[, i])$nm)
}
} else {
if (is.factor(mf[, i])) {
vzfacs <- c(vzfacs, TRUE)
} else {
vzfacs <- c(vzfacs, FALSE)
}
vzmat <- cbind(vzmat, mf[, i])
#temp
vznms <- c(vznms, names(mf)[i])
}
}
}
if (!sel) {
stop ("No variable to be selected! Use cgam instead!")
}
if (!is.null(xmat)) {
capl <- ncol(xmat)
bx <- sapply(shpsx, function(x) length(x))
xnum <- rev(cumprod(bx))[1]
} else {capl <- 0; xnum <- 1}
if (!is.null(zmat)) {
capk <- ncol(zmat)
znum <- 2^capk
} else {capk <- 0; znum <- 1}
if (!is.null(trmat)) {
capt <- ncol(trmat)
trnum <- 3^capt
} else {capt <- 0; trnum <- 1}
nmod <- xnum * znum * trnum
tm <- 0
if (genetic) {
# call GA
print ("Go genetic algorithm!")
ptm <- proc.time()
ans <- ConstrGA(y, xmat, zmat, trmat, family = family, shpsx = shpsx, shpsvx = shpsvx, shpsz = shpsz, shpst = shpst, cpar = cpar, nmod = nmod, zfacs = zfacs, weights = weights, vzmat = vzmat, vzfacs = vzfacs, vxmat = vxmat, vtrmat = vtrmat, npop = npop, per.mutate = per.mutate)
tm <- proc.time() - ptm
} else {
if (nmod <= 5e+2) {
print ("Go through models one by one!")
Sys.sleep(1)
ptm <- proc.time()
ans <- ConstrALL(y, xmat, zmat, trmat, family = family, shpsx = shpsx, shpsvx = shpsvx, shpsz = shpsz, shpst = shpst, cpar = cpar, zfacs = zfacs, weights = weights, vzmat = vzmat, vzfacs = vzfacs, vxmat = vxmat, vtrmat = vtrmat)
tm <- tm + proc.time() - ptm
#could go one-by-one, but will suggest genetic
} else if (nmod > 5e+2 & nmod <= 1e+6) {
print ("Estimating the time of one fit!")
ptm <- proc.time()
invisible(ConstrGA(y, xmat, zmat, trmat, family = family, shpsx = shpsx, shpsvx = shpsvx, shpsz = shpsz, shpst = shpst, cpar = cpar, nmod = nmod, zfacs = zfacs, time.est = TRUE, weights = weights, vzmat = vzmat, vzfacs = vzfacs, vxmat = vxmat, vtrmat = vtrmat, npop = npop, per.mutate = per.mutate))
tm <- proc.time() - ptm
print (paste("Total time of one fit is roughly", round(tm[3], 1), "seconds"))
if (round(tm[3] * nmod/60^2) > 1) {
tm2 <- paste(round(tm[3] * nmod/60^2), "hours")
} else {tm2 <- paste(round(tm[3] * nmod/60), "minutes")}
msg <- paste("Number of all models is", nmod, "and the time for all fits is roughly", tm2, ". Go one by one?")
res <- dlgMessage(msg, "yesno")$res
if (res == "yes") {
print ("Go one by one!")
ptm <- proc.time()
ans <- ConstrALL(y, xmat, zmat, trmat, family = family, shpsx = shpsx, shpsvx = shpsvx, shpsz = shpsz, shpst = shpst, cpar = cpar, zfacs = zfacs, weights = weights, vzmat = vzmat, vzfacs = vzfacs, vxmat = vxmat, vtrmat = vtrmat)
tm <- proc.time() - ptm
} else {
print ("Go genetic!")
ptm <- proc.time()
ans <- ConstrGA(y, xmat, zmat, trmat, family = family, shpsx = shpsx, shpsvx = shpsvx, shpsz = shpsz, shpst = shpst, cpar = cpar, nmod = nmod, zfacs = zfacs, weights = weights, vzmat = vzmat, vzfacs = vzfacs, vxmat = vxmat, vtrmat = vtrmat, npop = npop, per.mutate = per.mutate)
tm <- proc.time() - ptm
}
#too many models or memory problem
} else {
print ("Go genetic! Too many models!")
ptm <- proc.time()
ans <- ConstrGA(y, xmat, zmat, trmat, family = family, shpsx = shpsx, shpsvx = shpsvx, shpsz = shpsz, shpst = shpst, cpar = cpar, nmod = nmod, zfacs = zfacs, weights = weights, vzmat = vzmat, vzfacs = vzfacs, vxmat = vxmat, vtrmat = vtrmat, npop = npop, per.mutate = per.mutate)
tm <- tm + proc.time() - ptm
}
}
#print (vznms)
colnames(ans$pop2)[1:(capl+capk+capt)] = c(xnms, znms, trnms)
rslt <- list(pop = ans$pop2, top = ans$pop2[1,], fitness = ans$fitness, tm = tm, xnms = xnms, znms = znms, trnms = trnms, zfacs = zfacs, mxf = ans$mxf, mnf = ans$mnf, GA = ans$GA, vzcat = ans$vzcat, vzmat = vzmat, shpsx = shpsx, vxnms = vxnms, vznms = vznms, vtrnms = vtrnms)
form <- make_form(pvec = ans$pop2[1, 1:(capl+capk+capt)], pnms = colnames(ans$pop2)[1:(capl+capk+capt)], ynm = ynm, zfacs = zfacs, vznms = vznms, vxnms = vxnms, shpsvx = shpsvx, vtrnms = vtrnms)
fm <- form$fm
#print (fm)
zps <- form$zps
if (is.null(fm)) {
print ('No predictor is chosen')
best.fit <- NULL
} else {
best.fit <- cgam(formula = fm, nsim = 0, family = family, cpar = cpar, data = data, weights = weights)
rslt$best.fit <- best.fit
rslt$fm <- fm
id_noflat <- which(ans$pop[1, 1:capl, drop = FALSE] != 0)
if (length(id_noflat) > 1) {
msg <- paste("A perspective plot of the best fit?")
res <- dlgMessage(msg, "yesno")$res
if (res == "yes") {
if (is.null(zps)) {
plotpersp(best.fit)
} else {plotpersp(best.fit, categ = zps[1])}
}
}
}
rslt$best.fit <- best.fit
rslt$call <- cl
class(rslt) <- "shapeselect"
return (rslt)
}
######################
#extract the best fit#
######################
#' Extract the Best Fit Returned by the ShapeSelect Routine
#'
#' This is a subroutine that only works for the `ShapeSelect` routine.
#' It returns an object of the `cgam` class given the variables and their shapes
#' chosen by the `ShapeSelect` routine.
#'
#' @param x An object of the `ShapeSelect` class.
#'
#' @return The best fit returned by the `ShapeSelect` routine, which is an object of class `cgam`.
#'
#' @author Xiyue Liao
#'
#' @examples
#' \dontrun{
#' library(MASS)
#' data(Rubber)
#'
#' # Perform variable and shape selection with four possible shapes:
#' # increasing, decreasing, convex, and concave
#' ans <- ShapeSelect(loss ~ shapes(hard, set = c("incr", "decr", "conv", "conc")) +
#' shapes(tens, set = c("incr", "decr", "conv", "conc")),
#' data = Rubber, genetic = TRUE)
#'
#' # Extract the best fit (a cgam object)
#' bf <- best.fit(ans)
#' class(bf)
#' plotpersp(bf)
#' }
#'
#' @seealso \code{\link{cgam}}, \code{\link{ShapeSelect}}
#' @keywords best fit of the ShapeSelect routine
#' @export
best.fit <- function(x) {
if (!inherits(x, "shapeselect")) {
stop("best.fit only works for an object of the ShapeSelect routine!")
}
object <- x$best.fit
return (object)
}
##########################################
#new symbolic routine #
#s(): shape-restricted for genetic only #
#keep all 17 one shape routines for cgam#
#########################################
shapes <- function(x, set = "s.9")
{
cl <- match.call()
pars <- match.call()[-1]
attr(x, "nm") <- deparse(pars$x)
if (is.numeric(set)) {
if (min(set) >= 0 & max(set) <= 16) {
#shps <- c(0, set)
shps <- set
shps <- unique(sort(shps))
#attr(x, "char") <- NULL
} else {stop ("Shape values for shape-restricted variables can only be between 0 and 16!")}
attr(x, "type") <- "nparam"
} else {
attr(x, "type") <- "nparam"
if (identical(set, "s.5")) {
shps <- c(0, 9:12)
} else if (identical(set, "s.9")) {
shps <- c(0, 9:16)
} else if (identical(set, "ord.5")) {
shps <- c(0, 1:4)
} else if (identical(set, "ord.9")) {
shps <- c(0, 1:8)
#print (shps)
} else if (identical(set, "tree")) {
#shps <- c(0, "tree", "unordered")
shps <- c(0, 1, 2)
attr(x, "type") <- "tree"
} else {
lshps <- length(set)
shps <- unique(sort(unname(sapply(set, CharToShape))))
}
}
attr(x, "nm") <- deparse(pars$x)
attr(x, "shape") <- shps
x
}
######################
#choose z as factors
######################
in.or.out <- function(z)
{
cl <- match.call()
pars <- match.call()[-1]
attr(z, "nm") <- deparse(pars$z)
if (is.factor(z)) {
attr(z, "type") <- "fac"
} else {attr(z, "type") <- "lin"}
#shps <- c(0, 1)
attr(z, "shape") <- c(0, 1)
z
}
#####################
#make a cgam formula#
#####################
make_form <- function(pvec = NULL, pnms = NULL, ynm = NULL, zfacs = NULL, vznms = NULL, vxnms = NULL, shpsvx = NULL, vtrnms = NULL) {
fm <- NULL
zps <- NULL
zi <- 1
vs <- NULL
rm <- c("flat", "out")
pvec <- apply(as.matrix(pvec, nrow = 1), 2, as.character)
if (all(pvec %in% rm)) {
rslt <- list(fm = fm, zps = zps)
#return (rslt)
} else {
if (any(pvec %in% rm)) {
id_rm <- which(pvec %in% rm)
pvec <- pvec[-id_rm]
pnms <- pnms[-id_rm]
}
if (as.character(pvec[1]) == "in") {
fm0 <- pnms[1]
zps <- c(zps, fm0)
zi <- zi + 1
#vs <- c(vs, pnms[1])
} else if (as.character(pvec[1]) == "unordered") {
fm0 <- paste("factor(", pnms[1], ")", sep = "")
zps <- c(zps, fm0)
#vs <- c(vs, pnms[1])
} else {
fm0 <- paste(as.character(pvec[1]), "(" , pnms[1], ")" , sep = "")
}
vs <- c(vs, pnms[1])
if (length(pvec) > 1) {
#zi only works for zfacs, not tree unordered case
#zi <- 1
for (i in 2:length(pvec)) {
#if (as.character(pvec[i]) == "flat") {
#not include the x
# next
#} else
if (as.character(pvec[i]) == "in") {
#if (zfacs[zi]) {
# fi <- paste("factor(", pnms[i], ")", sep = "")
#} else {fi <- pnms[i]}
fi <- pnms[i]
zps <- c(zps, fi)
zi <- zi + 1
} else if (as.character(pvec[i]) == "unordered") {
fi <- paste("factor(", pnms[i], ")", sep = "")
#fi <- pnms[i]
zps <- c(zps, fi)
} else {
#should work with tree?
fi <- paste(as.character(pvec[i]), "(" , pnms[i], ")" , sep = "")
}
fm0 <- paste(fm0, fi, sep = "+")
}
}
if (!is.null(vxnms)) {
lvx <- length(vxnms)
for (i in 1:lvx) {
#fi <- vxnms[i]
pvi <- ShapeToChar(shpsvx[i], tag = "x")
fi <- paste(pvi, "(" , vxnms[i], ")" , sep = "")
fm0 <- paste(fm0, fi, sep = "+")
}
}
if (!is.null(vznms)) {
lvz <- length(vznms)
for (i in 1:lvz) {
fi <- vznms[i]
zps <- c(zps, fi)
fm0 <- paste(fm0, fi, sep = "+")
}
}
if (!is.null(vtrnms)) {
lvt <- length(vtrnms)
for (i in 1:lvt) {
fi <- paste("tree", "(" , vtrnms[i], ")" , sep = "")
fm0 <- paste(fm0, fi, sep = "+")
}
}
fm <- as.formula(paste(ynm, "~", fm0, sep = ""))
rslt <- list(fm = fm, zps = zps)
}
return (rslt)
}
###################
#genetic algorithm#
###################
ConstrGA = function(y, xmat, zmat, trmat, family = gaussian, shpsx = NULL, shpsvx = NULL, shpsz = NULL, shpst = NULL, cpar = 1.2, nmod = 2e+4, zfacs = NULL, time.est = FALSE, weights = NULL, vzmat = NULL, vzfacs = NULL, vxmat = NULL, vtrmat = NULL, npop = NULL, per.mutate = NULL) {
#linkfun = family$linkfun
cicfamily = CicFamily(family)
linkfun = cicfamily$linkfun
llh.fun = cicfamily$llh.fun
etahat.fun = cicfamily$etahat.fun
gr.fun = cicfamily$gr.fun
wt.fun = cicfamily$wt.fun
zvec.fun = cicfamily$zvec.fun
muhat.fun = cicfamily$muhat.fun
ysim.fun = cicfamily$ysim.fun
deriv.fun = cicfamily$deriv.fun
dev.fun = cicfamily$dev.fun
#print (head(xmat))
#print (head(zmat))
#print (head(y))
n = length(y)
#sm = 1e-7
capl = length(xmat) / n
if (capl < 1) {capl = 0}
if (round(capl, 8) != round(capl, 1)) {
stop ("Incompatible dimensions for xmat!")
}
#check!
if (capl > 0) {
for(i in 1:capl) {
xmat[,i] = (xmat[,i] - min(xmat[,i])) / (max(xmat[,i]) - min(xmat[,i]))
#xmat[,i] = (xmat[,i] - mean(xmat[,i])) / sd(xmat[,i])
#xmat[,i] = xmat[,i] / sd(xmat[,i])
}
}
caplv = length(vxmat) / n
if (caplv < 1) {caplv = 0}
if (round(caplv, 8) != round(caplv, 1)) {
stop ("Incompatible dimensions for xmat!")
}
#new:
if (caplv > 0) {
for(i in 1:caplv) {
vxmat[,i] = (vxmat[,i] - min(vxmat[,i])) / (max(vxmat[,i]) - min(vxmat[,i]))
#vxmat[,i] = (vxmat[,i] - mean(vxmat[,i])) / sd(vxmat[,i])
#vxmat[,i] = vxmat[,i] / sd(vxmat[,i])
}
}
capk = length(zmat) / n
if (capk < 1) {capk = 0}
if (round(capk, 8) != round(capk, 1)) {
stop ("Incompatible dimensions for zmat!")
}
capkv = length(vzmat) / n
if (capkv < 1) {capkv = 0}
if (round(capkv, 8) != round(capkv, 1)) {
stop ("Incompatible dimensions for vzmat!")
}
capt = length(trmat) / n
if (capt < 1) {capt = 0}
if (round(capt, 8) != round(capt, 1)) {
stop ("Incompatible dimensions for trmat!")
}
captv = length(vtrmat) / n
if (captv < 1) {captv = 0}
if (round(captv, 8) != round(captv, 1)) {
stop ("Incompatible dimensions for trmat!")
}
#nrep=0
################################################################
##get basis functions for all allowed shapes for each component#
#not consider allowed shapes for now
################################################################
# get basis functions for the constrained components -- ordinal monotone
if (capl > 0) {
delta = varlst = NULL
if (1 %in% shpsx[[1]] | 2 %in% shpsx[[1]]) {
#print ('1')
del1 = makedelta(xmat[, 1], 1)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (1 %in% shpsx[[i]] | 2 %in% shpsx[[i]]) {
#print ('1')
del2 = makedelta(xmat[, i], 1)$amat
m2 = length(del2) / n
} else {del2 = NULL; m2 = 0}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
#var1: keep track of x's in delta: 11112222...
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_om = delta
#varlist_om = varlist
} #else {delta_om = del1; varlist_om = var1}
delta_om = delta
varlist_om = varlist
}
#print (shpsx[[1]])
# get basis functions for the constrained components -- smooth monotone
if (capl > 0) {
delta = varlst = NULL
if (9 %in% shpsx[[1]] | 10 %in% shpsx[[1]]) {
#print ('9')
del1 = makedelta(xmat[, 1], 9)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (9 %in% shpsx[[i]] | 10 %in% shpsx[[i]]) {
#print ('9')
del2 = makedelta(xmat[, i], 9)$amat
m2 = length(del2) / n
} else {del2 = NULL; m2 = 0}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_sm = delta
#varlist_sm = varlist
} #else {delta_sm = del1; varlist_sm = var1}
delta_sm = delta
varlist_sm = varlist
}
#print (delta_sm)
#print (varlist_sm)
# get basis functions for the constrained components -- ordinal convex
if (capl > 0) {
delta = varlst = NULL
if (3 %in% shpsx[[1]] | 4 %in% shpsx[[1]]) {
#print ('3')
del1 = makedelta(xmat[, 1], 3)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (3 %in% shpsx[[i]] | 4 %in% shpsx[[i]]) {
#print ('3')
del2 = makedelta(xmat[, i], 3)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_ocv = delta
#varlist_ocv = varlist
} #else {delta_ocv = del1; varlist_ocv = var1}
delta_ocv = delta
varlist_ocv = varlist
}
if (capl > 0) {
delta = varlst = NULL
# get basis functions for the constrained components -- smooth convex
if (11 %in% shpsx[[1]] | 12 %in% shpsx[[1]]) {
#print ('11')
del1 = makedelta(xmat[, 1], 11)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (11 %in% shpsx[[i]] | 12 %in% shpsx[[i]]) {
#print ('11')
del2 = makedelta(xmat[, i], 11)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_scv = delta
#varlist_scv = varlist
} #else {delta_scv = del1; varlist_scv = var1}
delta_scv = delta
varlist_scv = varlist
}
# get basis functions for the constrained components -- ordinal increasing convex
if (capl > 0) {
delta = varlst = NULL
if (5 %in% shpsx[[1]] | 8 %in% shpsx[[1]]) {
#print ('5')
del1 = makedelta(xmat[, 1], 5)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (5 %in% shpsx[[i]] | 8 %in% shpsx[[i]]) {
#print ('5')
del2 = makedelta(xmat[, i], 5)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_oincv = delta
#varlist_oincv = varlist
} #else {delta_oincv = del1; varlist_oincv = var1}
delta_oincv = delta
varlist_oincv = varlist
}
# get basis functions for the constrained components -- smooth increasing convex
if (capl > 0) {
delta = varlst = NULL
if (13 %in% shpsx[[1]] | 16 %in% shpsx[[1]]) {
#print ('13')
del1 = makedelta(xmat[, 1], 13)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (13 %in% shpsx[[i]] | 16 %in% shpsx[[i]]) {
#print ('13')
del2 = makedelta(xmat[, i], 13)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_sincv = delta
#varlist_sincv = varlist
} #else {delta_sincv = del1; varlist_sincv = var1}
delta_sincv = delta
varlist_sincv = varlist
}
# get basis functions for the constrained components -- ordinal decreasing convex
if (capl > 0) {
delta = varlst = NULL
if (6 %in% shpsx[[1]] | 7 %in% shpsx[[1]]) {
#print ('6')
del1 = makedelta(xmat[, 1], 6)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (6 %in% shpsx[[i]] | 7 %in% shpsx[[i]]) {
#print ('6')
del2 = makedelta(xmat[, i], 6)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_odecv = delta
#varlist_odecv = varlist
} #else {delta_odecv = del1; varlist_odecv = var1}
delta_odecv = delta
varlist_odecv = varlist
}
# get basis functions for the constrained components -- smooth increasing concave
if (capl > 0) {
delta = varlst = NULL
if (14 %in% shpsx[[1]] | 15 %in% shpsx[[1]]) {
#print ('14')
del1 = makedelta(xmat[, 1], 14)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (14 %in% shpsx[[i]] | 15 %in% shpsx[[i]]) {
#print ('14')
del2 = makedelta(xmat[, i], 14)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
#delta_sincc = delta
#varlist_sincc = varlist
} #else {delta_sincc = del1; varlist_sincc = var1}
delta_sincc = delta
varlist_sincc = varlist
}
#zmat: similar idea, zvars: columns for z1, z2,...,z's are not factorized for now
#print (zmat)
if (capk > 0) {
#zcat: similar to the final delta of x's
zcat = NULL
zvars = NULL
#st = 0
for (k in 1:capk){
zk = zmat[, k]
is_fac = zfacs[k]
if (is_fac) {
zkmat = model.matrix(~ factor(zk))[, -1, drop = FALSE]
zvars = c(zvars, rep(k, ncol(zkmat)))
} else {
zkmat = zk
zvars = c(zvars, k)
}
zcat = cbind(zcat, zkmat)
#if (is_fac) {
# zvars = c(zvars, rep(k, ncol(zkmat)))
#} else {zvars = c(zvars, k)}
}
}
#print (paste('capk:', capk))
vzcat = NULL
if (capkv > 0) {
for (k in 1:capkv){
vzk = vzmat[, k]
is_fac = vzfacs[k]
if (is_fac) {
vzkmat = model.matrix(~ factor(vzk))[, -1, drop = FALSE]
} else {
vzkmat = vzk
}
vzcat = cbind(vzcat, vzkmat)
}
}
vxcat = NULL
if (caplv > 0) {
for (l in 1:caplv) {
xl = vxmat[, l]
shpl = shpsvx[l]
vxdd = t(makedelta(xl, shpl)$amat)
if (shpl != 17) {
#caplv = caplv - 1
vxcat = cbind(vxcat, vxdd)
} else if (shpl == 17) {
capkv = capkv + 1
vzcat = cbind(vzcat, vxdd)
}
#print (dim(vxdd))
}
}
if (capt > 0) {
#trcat: work the same way as zcat, include in bigmat as the final part
trcat = NULL
trvars = NULL
for (k in 1:capt){
trk = trmat[, k]
#trkmat = model.matrix(~ factor(trk))[, -1, drop = FALSE]
trkmat = t(tree.fun(trk))
trcat = cbind(trcat, trkmat)
trvars = c(trvars, rep(k, ncol(trkmat)))
}
}
if (captv > 0) {
vtrcat = NULL
#vtrvars = NULL
for (k in 1:captv){
vtrk = vtrmat[, k]
#trkmat = model.matrix(~ factor(trk))[, -1, drop = FALSE]
vtrkmat = t(tree.fun(vtrk))
vtrcat = cbind(vtrcat, vtrkmat)
#trvars = c(trvars, rep(k, ncol(trkmat)))
}
}
# make the initial random population: capl: shapes for x's, capk: in or out for z's
if (time.est) {
npop = 1
} else {
#npop = 200 #* nmod / 2e+4
#if (nmod < 2e+6) {
# npop = 200
#} else {
# npop = 200 + round((nmod - 2e+6) / nmod * 20)
#}
#new: now we allow user to speficy npop
if (npop <= 0 | round(npop) != npop) {
warning('npop must be a positive integer! npop=200 will be used!')
if (nmod < 2e+6) {npop = 200} else {npop = 200 + round((nmod - 2e+6) / nmod * 20)}
}
#if (npop > nmod) {
# warning('npop must be smaller than the total number of possible models! npop=200 will be used!')
# if (nmod < 2e+6) {npop = 200} else {npop = 200 + round((nmod - 2e+6) / nmod * 20)}
#}
#print (npop)
}
popmat = matrix(0, nrow = npop, ncol = capl + capk + capt)
#print (capl)
for (ipop in 1:npop) {
# trunc(runif(capl)*9) gives 0 ~ 8
# trunc(runif(capk)*2) gives 0 ~ 1
#popmat[ipop, 1:capl] = trunc(runif(capl)*9)
#if(capk>0){popmat[ipop,(capl+1):(capl+capk)]=trunc(runif(capk)*2)}
if (capl > 0) {
for (l in 1:capl) {
# include flat for each x
popmat[ipop, l] = sample(shpsx[[l]], 1)
}
}
if (capk > 0) {
popmat[ipop, (capl + 1):(capl + capk)] = trunc(runif(capk)*2)
}
if (capt > 0) {
popmat[ipop, (capl + capk + 1):(capl + capk + capt)] = trunc(runif(capt)*3)
}
}
#print (popmat)
#print (class(popmat))
fitness = 1:npop*(-1)
## keep track of fitnesses already calculated
cicvals = matrix(0, ncol = 2, nrow = npop*100)
kpop = matrix(0, nrow = 5000, ncol = capl + capk + capt)
kfit = 1:5000
robs = 1:(npop*100)
#check!
#fits = vector("list", npop)
ivals = 0
## loop through the population
#base number's for x's
if (capl > 0) {
bx = sapply(shpsx, function(x) length(x))
#number of x's for each base
numx = unname(table(bx))
ubx = unique(bx)
lbx = length(ubx)
}
if (!time.est) {
cat(paste("Evaluating the fitness of the initial population....", "\n"))
}
for (ipop in 1:npop) {
#if (ipop%%5 == 0) print (ipop)
#print (popmat[ipop,])
#print (capl)
# i1, i2: row numbers by base 10 instead of base 9 and 2
#imod is not right....
#i1 = 0
#for (l in 1:capl) {i1 = i1 + 5^(capl - l) * popmat[ipop, l]}
i1 = 0
if (capl > 0) {
for (i in 1:lbx) {
capli = numx[i]
bxi = ubx[i]
popi = (popmat[ipop, 1:capl, drop = FALSE])[which(bx == bxi)]
for (il in 1:capli) {i1 = i1 + bxi^(capli - il) * popi[il]}
}
}
i2 = 0
if (capk > 0) {
for (k in 1:capk) {i2 = i2 + 2^(capk - k) * popmat[ipop, capl + k]}
}
i3 = 0
if (capt > 0) {
for (tr in 1:capt) {i3 = i3 + 3^(capt - tr) * popmat[ipop, capl + capk + tr]}
}
#imod = i2 * 9^capl + i1 + 1
mult = 1
if (capl > 0) {
for (i in 1:lbx) {
mult = mult * (ubx[i])^numx[i]
}
}
mult2 = 1
if (capk > 0) {
mult2 = 2^capk
}
#imod = i3 * 2^capk * mult + i2 * mult + i1 + 1
imod = i3 * mult2 * mult + i2 * mult + i1 + 1
## if we've done this model before, read old CIC for fitness
if (!all(cicvals[, 1] != imod)) {
rownum = robs[cicvals[, 1] == imod]
fitness[ipop] = -cicvals[rownum, 2]
} else {
#use 0 to represent all 'flat'
if (sum(popmat[ipop, ]) == 0) {
#llh=-2*(nsuc*log(mu0)+(n-nsuc)*log(1-mu0))/n
#print ('test llh')
llh = llh.fun(y = y, muhat = rep(mean(y), n), etahat = rep(mean(y), n), phihat=NULL, n = n, weights = weights, fml = family$family)
cic = llh + log(1 + 2 / (n - 1))
fitness[ipop] = -cic
} else {
delta = matrix(1:n*0+1, nrow = 1)
if (capkv > 0) {
delta = rbind(delta, t(vzcat))
}
#print (head(t(delta)))
if (capk > 0) {
if (sum(popmat[ipop, (capl+1):(capl+capk)]) > 0) {
#zuse = 1:st < 0
zuse = 1:ncol(zcat) < 0
for (i in 1:capk) {
if (popmat[ipop, capl+i] == 1) {
zuse[zvars == i] = TRUE
}
}
delta = rbind(delta, t(zcat[, zuse]))
#delta = rbind(1:n*0+1, t(zcat[, zuse]))
} #else {delta = matrix(1:n*0+1, nrow = 1)}
}
#new: unordered part for tree = 2, equivalent to 'z'
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 2) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (sum(popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13) > 0) {
usex = popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13
delta = rbind(delta, t(xmat[, usex]))
}
#new:
if (caplv > 0) {
ch = shpsvx %in% c(3, 4, 11, 12)
if (any(ch)) {
vxin = vxmat[, which(ch)]
delta = rbind(delta, t(vxin))
}
}
np = dim(delta)[1]
#print (popmat[ipop, ])
#new:
if (capl > 0) {
for (l in 1:capl) {
if (popmat[ipop, l] > 0) {
if (popmat[ipop, l] == 1) {#incr
#print ('1')
deladd = delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 2) {#decr
#print ('2')
deladd = -delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 3) {#conv
#print ('3')
deladd = delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 4) {#conc
#print ('4')
deladd = -delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 5) {#incr.conv
#print ('5')
deladd = delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 8) {#decr.conc
#print ('8')
deladd = -delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 6) {#decr.conv
#print ('6')
deladd = delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 7) {#incr.conc
#print ('7')
deladd = -delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 9) {
#print ('9')
deladd = delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 10) {
#print ('10')
deladd = -delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 11) {
#print ('11')
deladd = delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 12) {
#print ('12')
deladd = -delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 13) {
#print ('13')
deladd = delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 16) {
#print ('16')
deladd = -delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 14) {
#print ('14')
deladd = delta_sincc[varlist_sincc == l, ]
} else if (popmat[ipop, l] == 15) {
#print ('15')
deladd = -delta_sincc[varlist_sincc == l, ]
}
delta = rbind(delta, deladd)
#print (paste('dim: ', dim(delta)))
}
}
}
if (caplv > 0) {
if (!is.null(vxcat)) {
delta = rbind(delta, t(vxcat))
}
}
#tree part for tree var
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 1) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (captv > 0) {
delta = rbind(delta, t(vtrcat))
}
#print (paste('dim: ', dim(t(trcat))))
#print (delta)
#print (cpar)
ans = irls(y, delta, np, nsim = 100, family = family, weights = weights, cpar = cpar)
ivals = ivals + 1
cicvals[ivals, 2] = ans$cic
cicvals[ivals, 1] = imod
fitness[ipop] = -cicvals[ivals, 2]
kpop[ivals, ] = popmat[ipop, ]
kfit[ivals] = -cicvals[ivals, 2]
#fits[[ivals]] = ans$fhat
}
}
#print (ipop - fitness[ipop])
}
#iter = 0
mxf = NULL
mnf = NULL
#mdf = NULL
#mq3f = NULL
if (!time.est) {
## Now loop through generations
nrep = 0
obs = 1:npop
q1 = trunc(npop/4)
q2 = 2 * q1
q3 = round(.98 * npop)
nbig = 100
nm = 10
check = TRUE
maxfit = -1000
while (nrep < nbig & check) {
#while (nrep < nbig) {
ord = order(-fitness)
popmat = popmat[ord, ,drop = FALSE]
fitness = fitness[ord]
nrep = nrep + 1
cat(paste("Iter =", nrep, " | Mean =", format(mean(fitness), digits = 6), " | Best =", format(max(fitness), digits = 6), "\n"))
# mutate! randomly throughout population ## don't mutate the most fit
# imut is the row # of popmat
# igene is the column # of x, z, and tree
#imut = trunc(runif(nm) * (npop - 1) + 2)
#new for imut
if (per.mutate <= 0 | per.mutate >= 0.5) {
warning('per.mutate should be a percentage > 0 and < 0.5! per.mute = 0.05 will be used!')
per.mutate = 0.05
}
nm = round(npop * per.mutate)
imut = sample(1:npop, size = nm, replace = FALSE)
#print (nm)
#print (paste('imute:',imut))
#igene = trunc(runif(nm) * (capk + capl) + 1)
#check!
igene = trunc(runif(nm) * (capk + capl + capt) + 1)
for (im in 1:nm) {
ipop = imut[im]
if (igene[im] <= capl) {
#popmat[imut[im], igene[im]] = trunc(runif(1)*9)
#pos = imut[im]
popmat[imut[im], igene[im]] = sample(shpsx[[igene[im]]], 1)
} else if (igene[im] > capl & igene[im] <= (capl + capk)) {
popmat[imut[im], igene[im]] = trunc(runif(1)*2)
} else if (igene[im] > (capl + capk)) {
popmat[imut[im], igene[im]] = trunc(runif(1)*3)
}
#ipop = imut[im]
# find fitness of mutated phenotype
#i1=0;for(l in 1:capl){i1=i1+9^(capl-l)*popmat[ipop,l]}
#i2=0
#if(capk>0){
# for(k in 1:capk){i2=i2+2^(capk-k)*popmat[ipop,capl+k]}
#}
#imod=i2*9^capl+i1+1
i1 = 0
if (capl > 0) {
for (i in 1:lbx) {
capli = numx[i]
bxi = ubx[i]
popi = (popmat[ipop, 1:capl, drop = FALSE])[which(bx == bxi)]
for (il in 1:capli) {i1 = i1 + bxi^(capli - il) * popi[il]}
}
}
i2 = 0
if (capk > 0) {
for (k in 1:capk) {i2 = i2 + 2^(capk - k) * popmat[ipop, capl + k]}
}
i3 = 0
if (capt > 0) {
for (tr in 1:capt) {i3 = i3 + 3^(capt - tr) * popmat[ipop, capl + capk + tr]}
}
mult = 1
if (capl > 0) {
for (i in 1:lbx) {
mult = mult * (ubx[i])^numx[i]
}
}
mult2 = 1
if (capk > 0) {
mult2 = 2^capk
}
imod = i3 * mult2 * mult + i2 * mult + i1 + 1
## if we've done this model before, read old CIC for fitness
if (!all(cicvals[, 1] != imod)) {
rownum = robs[cicvals[,1] == imod]
fitness[ipop] = -cicvals[rownum, 2]
#print("done")
## calculate fitness
} else {
if (sum(popmat[ipop, ]) == 0) {
#llh=-2*(nsuc*log(mu0)+(n-nsuc)*log(1-mu0))/n
#cic=llh+log(1+2/(n-1))
#fitness[ipop]=-cic
llh = llh.fun(y = y, muhat = rep(mean(y), n), etahat = rep(mean(y), n), phihat=NULL, n = n, weights = weights, fml = family$family)
cic = llh + log(1 + 2 / (n - 1))
fitness[ipop] = -cic
} else {
delta = matrix(1:n*0+1, nrow = 1)
if (capkv > 0) {
delta = rbind(delta, t(vzcat))
}
if (capk > 0) {
if (sum(popmat[ipop, (capl+1):(capl+capk)]) > 0) {
zuse = 1:ncol(zcat) < 0
for (i in 1:capk) {
if (popmat[ipop, capl+i] == 1) {
zuse[zvars == i] = TRUE
}
}
delta = rbind(delta, t(zcat[, zuse]))
#delta = rbind(1:n*0+1, t(zcat[, zuse]))
} #else {
# delta = matrix(1:n*0+1, nrow = 1)
#}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 2) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (sum(popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13) > 0) {
usex = popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13
delta = rbind(delta, t(xmat[, usex]))
}
#new:
if (caplv > 0) {
ch = shpsvx %in% c(3, 4, 11, 12)
if (any(ch)) {
vxin = vxmat[, which(ch)]
delta = rbind(delta, t(vxin))
}
}
np = dim(delta)[1]
if (capl > 0) {
for (l in 1:capl) {
if (popmat[ipop, l] > 0) {
if (popmat[ipop, l] == 1) {#incr
deladd = delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 2) {#decr
deladd = -delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 3) {#conv
deladd = delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 4) {#conc
deladd = -delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 5) {#incr.conv
deladd = delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 8) {#decr.conc
deladd = -delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 6) {#decr.conv
deladd = delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 7) {#incr.conc
deladd = -delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 9) {
deladd = delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 10) {
deladd = -delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 11) {
deladd = delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 12) {
deladd = -delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 13) {
deladd = delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 16) {
deladd = -delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 14) {
deladd = delta_sincc[varlist_sincc == l, ]
} else if (popmat[ipop, l] == 15) {
deladd = -delta_sincc[varlist_sincc == l, ]
}
delta = rbind(delta, deladd)
}
}
}
if (caplv > 0) {
if (!is.null(vxcat)) {
delta = rbind(delta, t(vxcat))
}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 1) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (captv > 0) {
delta = rbind(delta, t(vtrcat))
}
ans = irls(y, delta, np, nsim = 100, family = family, weights = weights, cpar = cpar)
ivals = ivals + 1
cicvals[ivals, 2] = ans$cic
cicvals[ivals, 1] = imod
fitness[ipop] = -cicvals[ivals, 2]
kpop[ivals, ] = popmat[ipop, ]
kfit[ivals] = -cicvals[ivals, 2]
#fits[[ivals]] = ans$fhat
}
}
}
# reproduction: replace middle half with offspring: offspring combine elite with other
for (ipop in q1:q3) {
mom = trunc(runif(1) * npop + 1)
dad = trunc(runif(1) * q1 + 1)
digits = runif(capl + capk + capt) > .5
popmat[ipop, digits] = popmat[mom, digits]
popmat[ipop, !digits] = popmat[dad, !digits]
# find fitness of baby
#i1=0;for(l in 1:capl){i1=i1+9^(capl-l)*popmat[ipop,l]}
#i2=0
#if(capk>0){
# for(k in 1:capk){i2=i2+2^(capk-k)*popmat[ipop,capl+k]}
#}
#imod=i2*9^capl+i1+1
i1 = 0
if (capl > 0) {
for (i in 1:lbx) {
capli = numx[i]
bxi = ubx[i]
popi = (popmat[ipop, 1:capl, drop = FALSE])[which(bx == bxi)]
for (il in 1:capli) {i1 = i1 + bxi^(capli - il) * popi[il]}
}
}
i2 = 0
if (capk > 0) {
for (k in 1:capk) {i2 = i2 + 2^(capk - k) * popmat[ipop, capl + k]}
}
i3 = 0
if (capt > 0) {
for (tr in 1:capt) {i3 = i3 + 3^(capt - tr) * popmat[ipop, capl + capk + tr]}
}
mult = 1
if (capl > 0) {
for (i in 1:lbx) {
mult = mult * (ubx[i])^numx[i]
}
}
mult2 = 1
if (capk > 0) {
mult2 = 2^capk
}
imod = i3 * mult2 * mult + i2 * mult + i1 + 1
## if we've done this model before, read old CIC for fitness
if (!all(cicvals[, 1] != imod)) {
rownum = robs[cicvals[, 1] == imod]
fitness[ipop] = -cicvals[rownum, 2]
#print("done")
## calculate fitness
} else {
if (sum(popmat[ipop, ]) == 0) {
#llh=-2*(nsuc*log(mu0)+(n-nsuc)*log(1-mu0))/n
#cic=llh+log(1+2/(n-1))
#fitness[ipop]=-cic
llh = llh.fun(y = y, muhat = rep(mean(y), n), etahat = rep(mean(y), n), phihat=NULL, n = n, weights = weights, fml = family$family)
cic = llh + log(1 + 2 / (n - 1))
fitness[ipop] = -cic
} else {
delta = matrix(1:n*0+1, nrow = 1)
if (capkv > 0) {
delta = rbind(delta, t(vzcat))
}
if (capk > 0) {
if (sum(popmat[ipop, (capl+1):(capl+capk)]) > 0) {
zuse = 1:ncol(zcat) < 0
for (i in 1:capk) {
if (popmat[ipop, capl+i] == 1) {
zuse[zvars == i] = TRUE
}
}
delta = rbind(delta, t(zcat[, zuse]))
#delta = rbind(1:n*0+1, t(zcat[, zuse]))
}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 2) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (sum(popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13) > 0) {
usex = popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13
delta = rbind(delta, t(xmat[, usex]))
}
#new:
if (caplv > 0) {
ch = shpsvx %in% c(3, 4, 11, 12)
if (any(ch)) {
vxin = vxmat[, which(ch)]
delta = rbind(delta, t(vxin))
}
}
np = dim(delta)[1]
if (capl > 0) {
for (l in 1:capl) {
if (popmat[ipop, l] > 0) {
if (popmat[ipop, l] == 1) {#incr
deladd = delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 2) {#decr
deladd = -delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 3) {#conv
deladd = delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 4) {#conc
deladd = -delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 5) {#incr.conv
deladd = delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 8) {#decr.conc
deladd = -delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 6) {#decr.conv
deladd = delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 7) {#incr.conc
deladd = -delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 9) {
deladd = delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 10) {
deladd = -delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 11) {
deladd = delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 12) {
deladd = -delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 13) {
deladd = delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 16) {
deladd = -delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 14) {
deladd = delta_sincc[varlist_sincc == l, ]
} else if (popmat[ipop, l] == 15) {
deladd = -delta_sincc[varlist_sincc == l, ]
}
delta = rbind(delta, deladd)
}
}
}
if (caplv > 0) {
if (!is.null(vxcat)) {
delta = rbind(delta, t(vxcat))
}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 1) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (captv > 0) {
delta = rbind(delta, t(vtrcat))
}
ans = irls(y, delta, np, nsim = 100, family = family, weights = weights, cpar = cpar)
ivals = ivals + 1
cicvals[ivals, 2] = ans$cic
cicvals[ivals, 1] = imod
fitness[ipop] = -cicvals[ivals, 2]
kpop[ivals, ] = popmat[ipop, ]
kfit[ivals] = -cicvals[ivals, 2]
#fits[[ivals]] = ans$fhat
}
}
}
## immigration
for (ipop in (q3 + 1):npop) {
if (capl > 0) {
for (l in 1:capl) {
popmat[ipop, l] = sample(shpsx[[l]], 1)
}
}
if (capk > 0) {
popmat[ipop, (capl + 1):(capl + capk)] = trunc(runif(capk)*2)
}
if (capt > 0) {
popmat[ipop, (capl + capk + 1):(capl + capk + capt)] = trunc(runif(capt)*3)
}
# find fitness of new immigrant
i1 = 0
if (capl > 0) {
for (i in 1:lbx) {
capli = numx[i]
bxi = ubx[i]
popi = (popmat[ipop, 1:capl, drop = FALSE])[which(bx == bxi)]
for (il in 1:capli) {i1 = i1 + bxi^(capli - il) * popi[il]}
}
}
i2 = 0
if (capk > 0) {
for (k in 1:capk) {i2 = i2 + 2^(capk - k) * popmat[ipop, capl + k]}
}
i3 = 0
if (capt > 0) {
for (tr in 1:capt) {i3 = i3 + 3^(capt - tr) * popmat[ipop, capl + capk + tr]}
}
mult = 1
if (capl > 0) {
for (i in 1:lbx) {
mult = mult * (ubx[i])^numx[i]
}
}
mult2 = 1
if (capk > 0) {
mult2 = 2^capk
}
imod = i3 * mult2 * mult + i2 * mult + i1 + 1
## if we've done this model before, read old CIC for fitness
if (!all(cicvals[, 1] != imod)) {
rownum = robs[cicvals[, 1] == imod]
fitness[ipop] = -cicvals[rownum, 2]
} else {
if (sum(popmat[ipop, ]) == 0) {
llh = llh.fun(y = y, muhat = rep(mean(y), n), etahat = rep(mean(y), n), phihat=NULL, n = n, weights = weights, fml = family$family)
cic = llh + log(1 + 2 / (n - 1))
fitness[ipop] = -cic
} else {
delta = matrix(1:n*0+1, nrow = 1)
if (capkv > 0) {
delta = rbind(delta, t(vzcat))
}
if (capk > 0) {
if (sum(popmat[ipop, (capl+1):(capl+capk)]) > 0) {
zuse = 1:ncol(zcat) < 0
for (i in 1:capk) {
if (popmat[ipop, capl+i] == 1) {
zuse[zvars == i] = TRUE
}
}
delta = rbind(delta, t(zcat[, zuse]))
#delta = rbind(1:n*0+1, t(zcat[, zuse]))
} #else {delta = matrix(1:n*0+1, nrow = 1)}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 2) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (sum(popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13) > 0) {
usex = popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13
delta = rbind(delta, t(xmat[, usex]))
}
#new:
if (caplv > 0) {
ch = shpsvx %in% c(3, 4, 11, 12)
if (any(ch)) {
vxin = vxmat[, which(ch)]
delta = rbind(delta, t(vxin))
}
}
np = dim(delta)[1]
if (capl > 0) {
for (l in 1:capl) {
if (popmat[ipop, l] > 0) {
if (popmat[ipop, l] == 1) {#incr
deladd = delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 2) {#decr
deladd = -delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 3) {#conv
deladd = delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 4) {#conc
deladd = -delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 5) {#incr.conv
deladd = delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 8) {#decr.conc
deladd = -delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 6) {#decr.conv
deladd = delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 7) {#incr.conc
deladd = -delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 9) {
deladd = delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 10) {
deladd = -delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 11) {
deladd = delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 12) {
deladd = -delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 13) {
deladd = delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 16) {
deladd = -delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 14) {
deladd = delta_sincc[varlist_sincc == l, ]
} else if (popmat[ipop, l] == 15) {
deladd = -delta_sincc[varlist_sincc == l, ]
}
delta = rbind(delta, deladd)
}
}
}
if (caplv > 0) {
if (!is.null(vxcat)) {
delta = rbind(delta, t(vxcat))
}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 1) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (captv > 0) {
delta = rbind(delta, t(vtrcat))
}
ans = irls(y, delta, np, nsim = 100, family = family, weights = weights, cpar = cpar)
ivals = ivals + 1
cicvals[ivals, 2] = ans$cic
cicvals[ivals, 1] = imod
fitness[ipop] = -cicvals[ivals, 2]
kpop[ivals, ] = popmat[ipop, ]
kfit[ivals] = -cicvals[ivals, 2]
#fits[[ivals]] = ans$fhat
}
}
}
## targeted mutation, add if capl > 0
if (capl > 0) {
#if (max(fitness) > maxfit + 1e-8) {
ord = order(-fitness)
popmat = popmat[ord, ,drop = FALSE]
fitness = fitness[ord]
repl = 0
for (ic in 1:capl) {
#for (ic in 1:(capl - 1)) {
tpop = popmat[1, ]
#??
#for (j in 1:9) {
for (j in 1:length(shpsx[[ic]])) {
#tpop[ic] = tpop[ic] + 1
#if (tpop[ic] >= 9) {
#if (tpop[ic] >= max(shpsx[[ic]])) {
#tpop[ic] = 1
# tpop[ic] = min(shpsx[[ic]])
#}
tpop[ic] = sample(shpsx[[ic]], 1)
#print(tpop)
# find fitness of mutated phenotype
# i1=0;for(l in 1:capl){i1=i1+9^(capl-l)*tpop[l]}
# i2=0
# if(capk>0){
# for(k in 1:capk){i2=i2+2^(capk-k)*tpop[capl+k]}
# }
# imod=i2*9^capl+i1+1
i1 = 0
if (capl > 0) {
for (i in 1:lbx) {
capli = numx[i]
bxi = ubx[i]
popi = (popmat[ipop, 1:capl, drop = FALSE])[which(bx == bxi)]
for (il in 1:capli) {i1 = i1 + bxi^(capli - il) * popi[il]}
}
}
i2 = 0
if (capk > 0) {
for (k in 1:capk) {i2 = i2 + 2^(capk - k) * popmat[ipop, capl + k]}
}
i3 = 0
if (capt > 0) {
for (tr in 1:capt) {i3 = i3 + 3^(capt - tr) * popmat[ipop, capl + capk + tr]}
}
mult = 1
for (i in 1:lbx) {
mult = mult * (ubx[i])^numx[i]
}
mult2 = 1
if (capk > 0) {
mult2 = 2^capk
}
imod = i3 * mult2 * mult + i2 * mult + i1 + 1
## if we've done this model before, read old CIC for fitness
if (!all(cicvals[, 1] != imod)) {
rownum = robs[cicvals[, 1] == imod]
tfit = -cicvals[rownum, 2]
} else {
if (sum(tpop) == 0) {
#llh=-2*(nsuc*log(mu0)+(n-nsuc)*log(1-mu0))/n
llh = llh.fun(y = y, muhat = rep(mean(y), n), etahat = rep(mean(y), n), phihat=NULL, n = n, weights = weights, fml = family$family)
cic = llh + log(1 + 2 / (n - 1))
tfit = -cic
} else {
delta = matrix(1:n*0+1, nrow = 1)
if (capkv > 0) {
delta = rbind(delta, t(vzcat))
}
if (capk > 0) {
if (sum(tpop[(capl+1):(capl+capk)]) > 0) {
zuse = 1:ncol(zcat) < 0
for (i in 1:capk) {
if (tpop[capl+i] == 1) {
zuse[zvars == i] = TRUE
}
}
delta = rbind(delta, t(zcat[, zuse]))
#delta = rbind(1:n*0+1, t(zcat[, zuse]))
} #else {delta = matrix(1:n*0+1, nrow = 1)}
}
if (capt > 0) {
if (sum(tpop[(capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (tpop[capl+capk+i] == 2) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (sum(tpop[1:capl] > 2 & tpop[1:capl] < 5 | tpop[1:capl] > 10 & tpop[1:capl] < 13) > 0) {
usex = tpop[1:capl] > 2 & tpop[1:capl] < 5 | tpop[1:capl] > 10 & tpop[1:capl] < 13
delta = rbind(delta, t(xmat[, usex]))
}
#new:
if (caplv > 0) {
ch = shpsvx %in% c(3, 4, 11, 12)
if (any(ch)) {
vxin = vxmat[, which(ch)]
delta = rbind(delta, t(vxin))
}
}
np = dim(delta)[1]
for (l in 1:capl) {
if (tpop[l] > 0) {
if (tpop[l] == 1) {#incr
deladd = delta_om[varlist_om == l, ]
} else if (tpop[l] == 2) {#decr
deladd = -delta_om[varlist_om == l, ]
} else if (tpop[l] == 3) {#conv
deladd = delta_ocv[varlist_ocv == l, ]
} else if (tpop[l] == 4) {#conc
deladd = -delta_ocv[varlist_ocv == l, ]
} else if (tpop[l] == 5) {#incr.conv
deladd = delta_oincv[varlist_oincv == l, ]
} else if (tpop[l] == 8) {#decr.conc
deladd = -delta_oincv[varlist_oincv == l, ]
} else if (tpop[l] == 6) {#decr.conv
deladd = delta_odecv[varlist_odecv == l, ]
} else if (tpop[l] == 7) {#incr.conc
deladd = -delta_odecv[varlist_odecv == l, ]
} else if (tpop[l] == 9) {
deladd = delta_sm[varlist_sm == l, ]
} else if (tpop[l] == 10) {
deladd = -delta_sm[varlist_sm == l, ]
} else if (tpop[l] == 11) {
deladd = delta_scv[varlist_scv == l, ]
} else if (tpop[l] == 12) {
deladd = -delta_scv[varlist_scv == l, ]
} else if (tpop[l] == 13) {
deladd = delta_sincv[varlist_sincv == l, ]
} else if (tpop[l] == 16) {
deladd = -delta_sincv[varlist_sincv == l, ]
} else if (tpop[l] == 14) {
deladd = delta_sincc[varlist_sincc == l, ]
} else if (tpop[l] == 15) {
deladd = -delta_sincc[varlist_sincc == l, ]
}
delta = rbind(delta, deladd)
}
}
if (caplv > 0) {
if (!is.null(vxcat)) {
delta = rbind(delta, t(vxcat))
}
}
#nsim2 = 100 for target part
if (capt > 0) {
if (sum(tpop[(capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (tpop[capl+capk+i] == 1) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (captv > 0) {
delta = rbind(delta, t(vtrcat))
}
ans = irls(y, delta, np, nsim = 100, family = family, weights = weights, cpar = cpar)
ivals = ivals + 1
cicvals[ivals, 2] = ans$cic
cicvals[ivals, 1] = imod
kpop[ivals, ] = tpop
kfit[ivals] = -cicvals[ivals, 2]
tfit = -cicvals[ivals, 2]
#fits[[ivals]] = ans$fhat
#print(tfit)
if (tfit > fitness[1]) {
#points(npop - repl, tfit, pch = 5, col = "darkgreen")
popmat[npop - repl, ] = tpop
fitness[npop - repl] = tfit
repl = repl + 1
}
}
}
}
}
}
maxfit = max(fitness)
if (fitness[q1] > maxfit - 1e-8){check = FALSE}
#if (fitness[q1] > maxfit - 1e-6){check = FALSE}
mxf = c(mxf, max(fitness))
mnf = c(mnf, mean(fitness))
#mdf = c(mdf, quantile(fitness, probs = .5))
#mq3f = c(mdf, quantile(fitness, probs = .75))
}
}
ord = order(-fitness)
# sort the pop by fitness
popmat = popmat[ord, ,drop = FALSE]
fitness = fitness[ord]
rslt = new.env()
rslt$fitness = fitness
#rslt$fhat = fits
pop2 = matrix(0, nrow = npop, ncol = (capl+capk+capt))
if (capl > 0) {
for (i in 1:npop) {
pop2[i, 1:capl] = apply(popmat[i, 1:capl, drop = FALSE], 2, ShapeToChar)
}
#names(pop2)[1:capl] = xnms
}
if (capk > 0) {
for (i in 1:npop) {
pop2[i, (capl+1):(capl+capk)] = apply(popmat[i, (capl+1):(capl+capk), drop = FALSE], 2, function(num) ShapeToChar(num, tag = "z"))
}
#names(pop2)[(capl+1):(capl+capk)] = znms
}
if (capt > 0) {
for (i in 1:npop) {
pop2[i, (capl+capk+1):(capl+capk+capt)] = apply(popmat[i, (capl+capk+1):(capl+capk+capt), drop = FALSE], 2, function(num) ShapeToChar(num, tag = "tree"))
}
#names(pop2)[(capl+capk+1):(capl+capk+capt)] = trnms
}
#colnames(pop2) = c(xnms, znms, trnms)
pop2 = as.data.frame(pop2, stringsAsFactors = FALSE)
rslt$pop = cbind(popmat, fitness)
pop2 = cbind(pop2, fitness)
rslt$pop2 = pop2
#rslt$top = pop2[1, stringsAsFactors = FALSE]
rslt$mxf = mxf
rslt$mnf = mnf
#rslt$mdf = mdf
#rslt$mq3f = mq3f
rslt$GA = TRUE
rslt$vzcat = vzcat
#print (paste('nrep: ', nrep))
#class(rslt) = "cgam"
return (rslt)
}
##############################
#go through models one-by-one#
##############################
ConstrALL = function(y, xmat, zmat, trmat, family = gaussian, shpsx = NULL, shpsvx = NULL, shpsz = NULL, shpst = NULL, cpar = 1.2, zfacs = NULL, weights = NULL, vzmat = NULL, vzfacs = NULL, vxmat = NULL, vtrmat = NULL) {
#linkfun = family$linkfun
cicfamily = CicFamily(family)
llh.fun = cicfamily$llh.fun
etahat.fun = cicfamily$etahat.fun
gr.fun = cicfamily$gr.fun
wt.fun = cicfamily$wt.fun
zvec.fun = cicfamily$zvec.fun
muhat.fun = cicfamily$muhat.fun
ysim.fun = cicfamily$ysim.fun
deriv.fun = cicfamily$deriv.fun
dev.fun = cicfamily$dev.fun
n = length(y)
sm = 1e-7
capl = length(xmat) / n
if (capl < 1) {capl = 0}
if (round(capl, 8) != round(capl, 1)) {
stop ("Incompatible dimensions for xmat!")
}
#check!
if (capl > 0) {
for(i in 1:capl) {
xmat[,i] = (xmat[,i] - min(xmat[,i])) / (max(xmat[,i]) - min(xmat[,i]))
#xmat[,i] = (xmat[,i] - mean(xmat[,i])) / sd(xmat[,i])
#xmat[,i] = xmat[,i] / sd(xmat[,i])
}
}
caplv = length(vxmat) / n
if (caplv < 1) {caplv = 0}
if (round(caplv, 8) != round(caplv, 1)) {
stop ("Incompatible dimensions for zmat!")
}
#new:
if (caplv > 0) {
for(i in 1:caplv) {
vxmat[,i] = (vxmat[,i] - min(vxmat[,i])) / (max(vxmat[,i]) - min(vxmat[,i]))
#vxmat[,i] = (vxmat[,i] - mean(vxmat[,i])) / sd(vxmat[,i])
#vxmat[,i] = vxmat[,i] / sd(vxmat[,i])
}
}
capk = length(zmat) / n
if (capk < 1) {capk = 0}
if (round(capk, 8) != round(capk, 1)) {
stop ("Incompatible dimensions for zmat!")
}
capkv = length(vzmat) / n
if (capkv < 1) {capkv = 0}
if (round(capkv, 8) != round(capkv, 1)) {
stop ("Incompatible dimensions for zmat!")
}
capt = length(trmat) / n
if (capt < 1) {capt = 0}
if (round(capt, 8) != round(capt, 1)) {
stop ("Incompatible dimensions for trmat!")
}
captv = length(vtrmat) / n
if (captv < 1) {captv = 0}
if (round(captv, 8) != round(captv, 1)) {
stop ("Incompatible dimensions for trmat!")
}
################################################################
##get basis functions for all allowed shapes for each component#
#not consider allowed shapes for now
################################################################
# get basis functions for the constrained components -- ordinal monotone
if (capl > 0) {
delta = varlist = NULL
if (1 %in% shpsx[[1]] | 2 %in% shpsx[[1]]) {
#print ('1')
del1 = makedelta(xmat[, 1], 1)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (1 %in% shpsx[[i]] | 2 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 1)$amat
m2 = length(del2) / n
} else {del2 = NULL; m2 = 0}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_om = delta
varlist_om = varlist
}
# get basis functions for the constrained components -- smooth monotone
if (capl > 0) {
delta = varlist = NULL
if (9 %in% shpsx[[1]] | 10 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 9)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (9 %in% shpsx[[i]] | 10 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 9)$amat
m2 = length(del2) / n
} else {del2 = NULL; m2 = 0}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_sm = delta
varlist_sm = varlist
}
# get basis functions for the constrained components -- ordinal convex
if (capl > 0) {
delta = varlist = NULL
if (3 %in% shpsx[[1]] | 4 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 3)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (3 %in% shpsx[[i]] | 4 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 3)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_ocv = delta
varlist_ocv = varlist
}
# get basis functions for the constrained components -- smooth convex
if (capl > 0) {
delta = varlist = NULL
if (11 %in% shpsx[[1]] | 12 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 11)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (11 %in% shpsx[[i]] | 12 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 11)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_scv = delta
varlist_scv = varlist
}
if (capl > 0) {
delta = varlist = NULL
# get basis functions for the constrained components -- ordinal increasing convex
if (5 %in% shpsx[[1]] | 8 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 5)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (5 %in% shpsx[[i]] | 8 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 5)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_oincv = delta
varlist_oincv = varlist
}
if (capl > 0) {
delta = varlist = NULL
# get basis functions for the constrained components -- smooth increasing convex
if (13 %in% shpsx[[1]] | 16 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 13)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (13 %in% shpsx[[i]] | 16 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 13)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_sincv = delta
varlist_sincv = varlist
}
if (capl > 0) {
delta = varlist = NULL
# get basis functions for the constrained components -- ordinal decreasing convex
if (6 %in% shpsx[[1]] | 7 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 6)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (6 %in% shpsx[[i]] | 7 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 6)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_odecv = delta
varlist_odecv = varlist
}
if (capl > 0) {
delta = varlist = NULL
# get basis functions for the constrained components -- smooth increasing concave
if (14 %in% shpsx[[1]] | 15 %in% shpsx[[1]]) {
del1 = makedelta(xmat[, 1], 14)$amat
m1 = length(del1) / n
var1 = 1:m1*0 + 1
} else {del1 = NULL; m1 = 0; var1 = 0}
delta = del1
varlist = var1
if (capl > 1) {
for (i in 2:capl) {
if (14 %in% shpsx[[i]] | 15 %in% shpsx[[i]]) {
del2 = makedelta(xmat[, i], 14)$amat
m2 = length(del2) / n
}
delta = rbind(del1, del2)
if (m1 > 0 | m2 > 0) {
varlist = 1:(m1+m2)*0
if (m1 > 0) {
varlist[1:m1] = var1
}
if (m2 > 0) {
varlist[(m1+1):(m1+m2)] = (1:m2)*0+i
}
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
}
delta_sincc = delta
varlist_sincc = varlist
}
if (capk > 0) {
zcat = NULL
zvars = NULL
for (k in 1:capk){
zk = zmat[, k]
is_fac = zfacs[k]
if (is_fac) {
zkmat = model.matrix(~ factor(zk))[, -1, drop = FALSE]
zvars = c(zvars, rep(k, ncol(zkmat)))
} else {
zkmat = zk
zvars = c(zvars, k)
}
zcat = cbind(zcat, zkmat)
}
}
vzcat = NULL
if (capkv > 0) {
for (k in 1:capkv){
vzk = vzmat[, k]
is_fac = vzfacs[k]
if (is_fac) {
vzkmat = model.matrix(~ factor(vzk))[, -1, drop = FALSE]
} else {
vzkmat = vzk
}
vzcat = cbind(vzcat, vzkmat)
}
}
vxcat = NULL
if (caplv > 0) {
for (l in 1:caplv) {
xl = vxmat[, l]
shpl = shpsvx[l]
vxdd = t(makedelta(xl, shpl)$amat)
if (shpl != 17) {
#caplv = caplv - 1
vxcat = cbind(vxcat, vxdd)
} else if (shpl == 17) {
capkv = capkv + 1
vzcat = cbind(vzcat, vxdd)
}
#print (dim(vxdd))
}
}
if (capt > 0) {
#trcat: work the same way as zcat, include in bigmat as the final part
trcat = NULL
trvars = NULL
for (k in 1:capt){
trk = trmat[, k]
#trkmat = model.matrix(~ factor(trk))[, -1, drop = FALSE]
trkmat = t(tree.fun(trk))
trcat = cbind(trcat, trkmat)
trvars = c(trvars, rep(k, ncol(trkmat)))
}
}
if (captv > 0) {
vtrcat = NULL
#vtrvars = NULL
for (k in 1:captv){
vtrk = vtrmat[, k]
#trkmat = model.matrix(~ factor(trk))[, -1, drop = FALSE]
vtrkmat = t(tree.fun(vtrk))
vtrcat = cbind(vtrcat, vtrkmat)
#trvars = c(trvars, rep(k, ncol(trkmat)))
}
}
# make the population of all models
listAll = vector("list", capl + capk + capt)
if (capl > 0) {
listAll[1:capl] = shpsx
}
if (capk > 0) {
listAll[(capl+1):(capl+capk)] = shpsz
}
if (capt > 0) {
listAll[(capl+capk+1):(capl+capk+capt)] = shpst
}
popmat = as.matrix(expand.grid(listAll, stringsAsFactors = FALSE))
#ord = ncol(popmat):1
#pop0 = unname(popmat[, ord])
npop = nrow(popmat)
popmat = cbind(popmat, 1:npop*0)
fitness = 1:npop*(-1)
## keep track of fitnesses already calculated
cat(paste("Evaluating the fitness of all models!", "\n"))
for (ipop in 1:npop) {
#print (ipop)
if (sum(popmat[ipop, ]) == 0) {
llh = llh.fun(y = y, muhat = rep(mean(y), n), etahat = rep(mean(y), n), phihat=NULL, n = n, weights = weights, fml = family$family)
cic = llh + log(1 + 2 / (n - 1))
fitness[ipop] = -cic
popmat[ipop, (capl+capk+capt+1)] = -cic
}
delta = matrix(1:n*0+1, nrow = 1)
if (capkv > 0 ) {
delta = rbind(delta, t(vzcat))
}
if (capk > 0) {
if (sum(popmat[ipop, (capl+1):(capl+capk)]) > 0) {
#zuse = 1:st < 0
zuse = 1:ncol(zcat) < 0
for (i in 1:capk) {
if (popmat[ipop, capl+i] == 1) {
zuse[zvars == i] = TRUE
}
}
delta = rbind(delta, t(zcat[, zuse]))
# delta = rbind(1:n*0+1, t(zcat[, zuse]))
}# else {delta = matrix(1:n*0+1, nrow = 1)}
} #else {delta = matrix(1:n*0+1, nrow = 1)}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 2) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (sum(popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13) > 0) {
usex = popmat[ipop, 1:capl] > 2 & popmat[ipop, 1:capl] < 5 | popmat[ipop, 1:capl] > 10 & popmat[ipop, 1:capl] < 13
delta = rbind(delta, t(xmat[, usex]))
}
#new:
if (caplv > 0) {
ch = shpsvx %in% c(3, 4, 11, 12)
if (any(ch)) {
vxin = vxmat[, which(ch)]
delta = rbind(delta, t(vxin))
}
}
np = dim(delta)[1]
if (capl > 0) {
for (l in 1:capl) {
if (popmat[ipop, l] > 0) {
if (popmat[ipop, l] == 1) {#incr
#print ('1')
deladd = delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 2) {#decr
#print ('2')
deladd = -delta_om[varlist_om == l, ]
} else if (popmat[ipop, l] == 3) {#conv
#print ('3')
deladd = delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 4) {#conc
#print ('4')
deladd = -delta_ocv[varlist_ocv == l, ]
} else if (popmat[ipop, l] == 5) {#incr.conv
#print ('5')
deladd = delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 8) {#decr.conc
#print ('8')
deladd = -delta_oincv[varlist_oincv == l, ]
} else if (popmat[ipop, l] == 6) {#decr.conv
#print ('6')
deladd = delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 7) {#incr.conc
#print ('7')
deladd = -delta_odecv[varlist_odecv == l, ]
} else if (popmat[ipop, l] == 9) {
#print ('9')
deladd = delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 10) {
#print ('10')
deladd = -delta_sm[varlist_sm == l, ]
} else if (popmat[ipop, l] == 11) {
#print ('11')
deladd = delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 12) {
#print ('12')
deladd = -delta_scv[varlist_scv == l, ]
} else if (popmat[ipop, l] == 13) {
#print ('13')
deladd = delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 16) {
#print ('16')
deladd = -delta_sincv[varlist_sincv == l, ]
} else if (popmat[ipop, l] == 14) {
#print ('14')
deladd = delta_sincc[varlist_sincc == l, ]
} else if (popmat[ipop, l] == 15) {
#print ('15')
deladd = -delta_sincc[varlist_sincc == l, ]
}
delta = rbind(delta, deladd)
#print (paste('dim: ', dim(delta)))
}
}
}
if (caplv > 0) {
if (!is.null(vxcat)) {
delta = rbind(delta, t(vxcat))
}
}
if (capt > 0) {
if (sum(popmat[ipop, (capl+capk+1):(capl+capk+capt)]) > 0) {
truse = 1:ncol(trcat) < 0
for (i in 1:capt) {
if (popmat[ipop, capl+capk+i] == 1) {
truse[trvars == i] = TRUE
}
}
delta = rbind(delta, t(trcat[, truse]))
}
}
if (captv > 0) {
delta = rbind(delta, t(vtrcat))
}
ans = irls(y, delta, np, nsim = 100, family = family, weights = weights, cpar = cpar)
fitness[ipop] = -ans$cic
popmat[ipop, (capl+capk+capt+1)] = -ans$cic
}
ord = order(-fitness)
popmat = popmat[ord, ,drop = FALSE]
fitness = fitness[ord]
rslt = new.env()
rslt$pop = unname(popmat)
rslt$fitness = fitness
pop2 = matrix(0, nrow = npop, ncol = (capl+capk+capt))
for (i in 1:npop) {
pop2[i, 1:capl] = apply(popmat[i, 1:capl, drop = FALSE], 2, ShapeToChar)
}
if (capk > 0) {
for (i in 1:npop) {
pop2[i, (capl+1):(capl+capk)] = apply(popmat[i, (capl+1):(capl+capk), drop = FALSE], 2, function(num) ShapeToChar(num, tag = "z"))
}
}
if (capt > 0) {
for (i in 1:npop) {
pop2[i, (capl+capk+1):(capl+capk+capt)] = apply(popmat[i, (capl+capk+1):(capl+capk+capt), drop = FALSE], 2, function(num) ShapeToChar(num, tag = "tree"))
}
}
#colnames(pop2) = c(xnms, znms, trnms)
#rslt$pop0 = pop0
pop2 = as.data.frame(pop2, stringsAsFactors = FALSE)
pop2 = cbind(pop2, fitness)
rslt$pop2 = pop2
#rslt$top = pop2[1,]
rslt$GA = FALSE
rslt$vzcat = vzcat
#class(rslt) = "cgam"
return (rslt)
}
##############################
#tranform shapes back to char
##############################
ShapeToChar = function(shp, tag = "x") {
#if (max(shp) > 16 | min(shp) < 0) {
# stop ('No such a shape! A shape value must be between 0 and 16.')
#}
if (tag == "x") {
if (shp == 0) {
shp = 18
}
switch(shp,
cs1 = {ch = 'incr'},
cs2 = {ch = 'decr'},
cs3 = {ch = 'conv'},
cs4 = {ch = 'conc'},
cs5 = {ch = 'incr.conv'},
cs6 = {ch = 'decr.conv'},
cs7 = {ch = 'incr.conc'},
cs8 = {ch = 'decr.conc'},
cs9 = {ch = 's.incr'},
cs10 = {ch = 's.decr'},
cs11 = {ch = 's.conv'},
cs12 = {ch = 's.conc'},
cs13 = {ch = 's.incr.conv'},
cs14 = {ch = 's.incr.conc'},
cs15 = {ch = 's.decr.conv'},
cs16 = {ch = 's.decr.conc'},
cs17 = {ch = 's'},
cs18 = {ch = 'flat'}
#{print ('No such a shape')}
)
} else if (tag == "z") {
if (shp == 0) {
shp = 2
}
switch(shp,
cs1 = {ch = 'in'},
cs2 = {ch = 'out'}
)
} else if (tag == "tree") {
if (shp == 0) {
shp = 3
}
switch(shp,
cs1 = {ch = 'tree'},
cs2 = {ch = 'unordered'},
cs3 = {ch = 'out'}
)
}
return (ch)
}
#
CharToShape = function(ch) {
shp = NULL
if (ch == 'flat') {
shp = 0
} else if (ch == 'incr') {
shp = 1
} else if (ch == 'decr') {
shp = 2
} else if (ch == 'conv') {
shp = 3
} else if (ch == 'conc') {
shp = 4
} else if (ch == 'incr.conv') {
shp = 5
} else if (ch == 'decr.conv') {
shp = 6
} else if (ch == 'incr.conc') {
shp = 7
} else if (ch == 'decr.conc') {
shp = 8
} else if (ch == 's.incr') {
shp = 9
} else if (ch == 's.decr') {
shp = 10
} else if (ch == 's.conv') {
shp = 11
} else if (ch == 's.conc') {
shp = 12
} else if (ch == 's.incr.conv') {
shp = 13
} else if (ch == 's.incr.conc') {
shp = 14
} else if (ch == 's.decr.conv') {
shp = 15
} else if (ch == 's.decr.conc') {
shp = 16
} else if (ch == 's') {
shp = 17
} else {
stop ('shape not defined!')
}
return (shp)
}
############################################################
#plot fitness vs iterations #
############################################################
plot.shapeselect = function(x,...)
{
object = x
if (!object$GA) {
stop("plot.shapeselect won't work for objects not fitted by genetic algorithm ...")
}
par(mfrow = c(1, 1))
#iters = 1:100
cex.points = 0.7
col = c("slategrey","mediumorchid4")
pch = c(16, 1)
lty = c(1, 2)
mx = object$mxf
mn = object$mnf
iters = 1:length(mx)
ylim = c(min(mn), max(mx) + (max(mx) - min(mn)) * .01)
plot(iters, mx, type = "n", ylim = ylim, xlab = "Generation", ylab = "Fitness value")
grid()
legend("bottomright", bty = "n", legend = c("Best", "Mean"), col = col, pch = pch, lty = lty, pt.cex = cex.points, inset = 0.01)
points(iters, mx, type = "o", pch = pch[1], lty = lty[1], col = col[1], cex = cex.points)
for (i in 1:length(mx)) {
if (i < length(mx)) {
points(iters[i], mn[i], type = "o", pch = pch[2], lty = lty[2], col = col[2], cex = cex.points)
segments(iters[i], mn[i], iters[i+1], mn[i+1], col = "mediumorchid4", lty = lty[2])
} else {
points(iters[i], mn[i], type = "o", pch = "*", col = col[2], cex = 2.1)
Sys.sleep(.5)
points(iters[i], mn[i], type = "o", pch = "*", col = "white", cex = 2.1)
Sys.sleep(.5)
points(iters[i], mn[i], type = "o", pch = "*", col = col[2], cex = 2.5)
Sys.sleep(.5)
points(iters[i], mn[i], type = "o", pch = "*", col = "white", cex = 2.5)
Sys.sleep(.5)
points(iters[i], mn[i], type = "o", pch = "*", col = col[2], cex = 2.9)
#Sys.sleep(.5)
#points(iters[i], mn[i], type = "o", pch = "*", col = "white", cex = 2.9)
#Sys.sleep(.5)
#points(iters[i], mn[i], type = "o", pch = "*", col = col[2], cex = 3.3)
}
Sys.sleep(.03)
}
}
########################################################################
# iteratively re-weighted least squares -- binary likelihood
########################################################################
irls = function(y, bigmat, np, nsim = 100, family = gaussian, weights = NULL, cpar = 1.2) {
#linkfun = family$linkfun
cicfamily = CicFamily(family)
linkfun = cicfamily$linkfun
llh.fun = cicfamily$llh.fun
etahat.fun = cicfamily$etahat.fun
gr.fun = cicfamily$gr.fun
wt.fun = cicfamily$wt.fun
zvec.fun = cicfamily$zvec.fun
muhat.fun = cicfamily$muhat.fun
ysim.fun = cicfamily$ysim.fun
deriv.fun = cicfamily$deriv.fun
dev.fun = cicfamily$dev.fun
if (family$family == "binomial" | family$family == "poisson" | family$family == "Gamma") {
wt.iter = TRUE
} else {wt.iter = FALSE}
n = length(y)
if (is.null(weights)) {
weights = 1:n*0 + 1
}
sm = 1e-8
m = dim(bigmat)[1] - np
# new: initialize cvec
cvec = NULL
if (wt.iter) {
etahat = etahat.fun(n, y, fml = family$family)
gr = gr.fun(y, etahat, weights, fml = family$family)
wt = wt.fun(y, etahat, n, weights, fml = family$family)
cvec = wt * etahat - gr
} else {wt = wt.fun(y, etahat, n, weights, fml = family$family)}
zvec = zvec.fun(cvec, wt, y, fml = family$family)
gmat = t(bigmat %*% sqrt(diag(wt)))
if (m > 0) {
#np always >= 1
dsend = gmat[, (np + 1):(np + m), drop = FALSE]
zsend = gmat[, 1:np, drop = FALSE]
#ans = coneB(zvec, t(dsend), zsend, msg = FALSE)
ans = coneB(zvec, dsend, zsend, msg = FALSE)
face = ans$face
#ans = hingep(zvec, t(dsend), zsend)
coef = ans$coefs
etahat = t(bigmat) %*% coef
muhat = muhat.fun(etahat, fml = family$family)
if (wt.iter) {
#muhat = muhat.fun(etahat, fml = family$family)
diff = 1
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
nrep = 0
##########
#iterate!#
##########
while (diff > sm & mdiff & nrep < n^2) {
oldmu = muhat
nrep = nrep + 1
gr = gr.fun(y, etahat, weights, fml = family$family)
wt = wt.fun(y, etahat, n, weights, fml = family$family)
cvec = wt * etahat - gr
zvec = zvec.fun(cvec, wt, y, fml = family$family)
gmat = t(bigmat %*% sqrt(diag(wt)))
dsend = gmat[, (np + 1):(np + m), drop = FALSE]
zsend = gmat[, 1:np, drop = FALSE]
#ans = coneB(zvec, t(dsend), zsend, msg = FALSE)
ans = coneB(zvec, dsend, zsend, msg = FALSE, face = face)
coef = ans$coefs
etahat = t(bigmat) %*% coef
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
mdiff = abs(max(muhat) - 1)
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
}
}
} else {
prior.w = weights
vmat = t(bigmat[1:np, , drop = FALSE])
w = diag(prior.w)
coef = solve(t(vmat) %*% w %*% vmat) %*% t(vmat) %*% w %*% y
etahat = vmat %*% coef
muhat = muhat.fun(etahat, fml = family$family)
if (wt.iter) {
nrep = 0
muhat = mean(y) + 1:n*0
etahat = linkfun(muhat)
diff = 1
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
while (diff > sm & mdiff & nrep < n^2) {
nrep = nrep + 1
oldmu = muhat
zhat = etahat + (y - muhat) * deriv.fun(muhat, fml = family$family)
#w <- diag(as.vector(prior.w / deriv.fun(muhat)))
w = diag(as.vector(prior.w * (deriv.fun(muhat, fml = family$family))^(-1)))
coef = solve(t(vmat) %*% w %*% vmat) %*% t(vmat) %*% w %*% zhat
etahat = vmat %*% coef
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
mdiff = abs(max(muhat) - 1)
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
}
}
}
#muhat = muhat.fun(etahat, fml = family$family)
llh = llh.fun(y, muhat, etahat, phihat=NULL, n, weights, fml = family$family)
mukeep = muhat
coefkeep = coef
if (np > 0) {zcoefs = coefkeep[1:np]}
### get edf0
if (m > 0) {
dfs = 1:nsim*0
sm = 1e-5
if (family$family == "poisson") {
mu0 = mean(y)
eta0 = log(mu0)
} else {mu0 = NULL}
for (isim in 1:nsim) {
#print (isim)
ysim = ysim.fun(n, mu0 = mu0, fml = family$family)
if (wt.iter) {
etahat = etahat.fun(n, ysim, fml = family$family)
gr = gr.fun(ysim, etahat, weights, fml = family$family)
wt = wt.fun(ysim, etahat, n, weights, fml = family$family)
cvec = wt * etahat - gr
} else {wt = wt.fun(ysim, etahat, n, weights, fml = family$family)}
zvec = zvec.fun(cvec, wt, ysim, fml = family$family)
gmat = t(bigmat %*% sqrt(diag(wt)))
dsend = gmat[, (np + 1):(np + m), drop = FALSE]
zsend = gmat[, 1:np, drop = FALSE]
#ans = try(coneB(zvec, t(dsend), zsend, msg = FALSE))
ans = try(coneB(zvec, dsend, zsend, msg = FALSE))
face = ans$face
#if (class(ans) == "try-error") next
if(inherits(ans, "try-error")) next
if (wt.iter) {
etahat = t(bigmat) %*% ans$coefs
muhat = muhat.fun(etahat, fml = family$family)
diff = 1
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
##########
#iterate!#
##########
nrep = 0
while (diff > sm & nrep < n^2 & mdiff > sm) {
nrep = nrep + 1
oldmu = muhat
gr = gr.fun(ysim, etahat, weights, fml = family$family)
wt = wt.fun(ysim, etahat, n, weights, fml = family$family)
cvec = wt * etahat - gr
#zvec <- cvec / sqrt(wt)
zvec = zvec.fun(cvec, wt, y, fml = family$family)
gmat = t(bigmat %*% sqrt(diag(wt)))
dsend = gmat[, (np + 1):(np + m), drop = FALSE]
zsend = gmat[, 1:np, drop = FALSE]
#ans = try(coneB(zvec, t(dsend), zsend, msg = FALSE))
ans = try(coneB(zvec, dsend, zsend, msg = FALSE, face = face))
#if (class(ans) == "try-error") next
if(inherits(ans, "try-error")) next
etahat = t(bigmat) %*% ans$coefs
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
}
}
dfs[isim] = sum(abs(ans$coefs) > 0)
}
dfmean = mean(dfs)
} else {dfmean = np}
rslt = new.env()
rslt$edf0 = dfmean
rslt$llh = llh
rslt$fhat = mukeep
rslt$coefs = coefkeep
#cdose$cic = llh+log(1+2*dfmean/(n-np-1.5*(dfmean-np)))
if ((n - np - cpar * (dfmean - np)) <= 0) {
rslt$cic <- llh + log(1 + 2 * dfmean / (dfmean - np))
} else {
rslt$cic <- llh + log(1 + 2 * dfmean / (n - np - cpar * (dfmean - np)))
}
rslt
}
#### TRIANGLE SPLINE ######
## y is response
## x1, x2 are continuous predictors
## zmat is matrix of parametrically modeled covariates
## for fixed covariate values, E(y) is convex in (x1,x2) -- nonadditive!
####
trispl.fit = function(x1t, x2t, y, zmat = NULL, xmat_add = NULL, delta_add = NULL, varlist_add = NULL, shapes_add = NULL, np_add = 0, xmat_wp = NULL, delta_wp = NULL, varlist_wps = NULL, amat_wp = NULL, dmat_wp = NULL, w = NULL, lambda = 0, pnt = TRUE, cpar = 1.2, cvss = c(TRUE, TRUE), delta = NULL, kts = NULL, nkts = NULL, wt.iter = FALSE, family = gaussian(), nsim = 0, nprs = 1) {
#additive + tri surface + z(exclude one) + warp surface
cicfamily = CicFamily(family)
linkfun = cicfamily$linkfun
llh.fun = cicfamily$llh.fun
etahat.fun = cicfamily$etahat.fun
gr.fun = cicfamily$gr.fun
wt.fun = cicfamily$wt.fun
zvec.fun = cicfamily$zvec.fun
muhat.fun = cicfamily$muhat.fun
ysim.fun = cicfamily$ysim.fun
deriv.fun = cicfamily$deriv.fun
dev.fun = cicfamily$dev.fun
n = length(y)
#zmat not includes one
if (!is.null(zmat)){
if (length(zmat) == n) {
zmat = matrix(zmat, ncol = 1)
}
p = dim(zmat)[2]
} else{p = 0}
#print (p)
#one = 1:n*0 + 1
#if (is.null(zmat)) {
# zmat = matrix(one, ncol = 1)
#} else {
# if (dim(zmat)[1] != n) {
# stop ("Error: # rows of zmat must equal length of y")
# }
# zproj = zmat %*% solve(crossprod(zmat), t(zmat))
# onep = one - zproj %*% one
# if the one vector is not in the space of zmat, then include the one vector in zmat
# if (sum(onep^2) > 1e-12) {
# zmat = cbind(one, zmat)
# }
#}
#p = dim(zmat)[2]
dimnames(zmat)[[2]] = NULL
if (nprs >= 1) {
amat_lst = list()
#penalty matrix
#Pmat = NULL
pmat_lst = list()
knots_lst = list()
m12_lst = list()
trimat_lst = list()
bmat_lst = list()
capk_lst = list()
#design matrix
Dmat = NULL
varlist = NULL
#print (nkts)
for (ipr in 1:nprs) {
cvs = cvss[[ipr]]
x1 = x1t[,ipr]
x2 = x2t[,ipr]
nktsi = nkts[[ipr]]
if (length(x1) != n | length(x2) != n) {
stop ("ERROR -- x1, x2, and y must have same lengths")
}
xmat = cbind(x1, x2)
#temp:
#if (nktsi[1] > 0) {
# m1 = nktsi[i]
#} else {
#m1 = 2 + round(n^(1/3))
m1 = round(5*n^(1/6))
#}
s = (max(x1) - min(x1)) / (m1-1)
h = s*sqrt(3) / 2
m2 = trunc((max(x2) - min(x2)) / h) + 2
m0 = trunc(m2/2)
capk = 2*m0*m1+m0
if (m0 < m2/2) {
capk = capk+m1+1
}
knots = matrix(0, nrow = capk, ncol = 2)
l1 = min(x1)-s/2
u1 = max(x1)+s/2
l2 = min(x2)
u2 = l2 + (m2-1)*h
rw = 0
for (i in 1:m0) {
for (j in 1:(m1 + 1)) {
rw = rw + 1
knots[rw,1] = l1 + (j - 1) * s
knots[rw,2] = l2 + (i - 1) * 2 * h
}
for (j in 1:m1) {
rw = rw + 1
knots[rw,1] = l1 + s/2 + (j - 1) * s
knots[rw,2] = l2 + (i - 1) * 2 * h + h
}
}
if (m0 < m2/2) {
i = m0 + 1
for (j in 1:(m1 + 1)) {
rw = rw + 1
knots[rw,1] = l1 + (j - 1) * s
knots[rw,2] = l2 + (i - 1) * 2 * h
}
}
knots[,2] = knots[,2] - (u2 - max(x2))/2
u2 = max(knots[,2])
l2 = min(knots[,2])
# plot(c(l1,u1),c(l2,u2),pch = "")
# points(x1,x2,col = "slategray")
# points(knots[,1],knots[,2],pch = 20)
### now number the triangles and give knots for each
ntri = (m2 - 1) * (2 * m1 - 1)
trimat = matrix(0, nrow = ntri, ncol = 3)
if (m0 == m2/2) {
mlim = m0 - 1
} else {mlim = m0}
rt = 0
for (i in 1:mlim) {
for (j in 1:m1) {
rt = rt + 1
trimat[rt,1] = (2*m1 + 1)*(i - 1) + j
trimat[rt,2] = (2*m1 + 1)*(i - 1) + j + 1
trimat[rt,3] = (2*m1 + 1)*(i - 1) + m1 + 1 + j
}
for (j in 1:(m1 - 1)) {
rt = rt + 1
trimat[rt,1] = (2*m1 + 1)*(i - 1) + j + 1
trimat[rt,2] = (2*m1 + 1)*(i - 1) + m1 + 1 + j
trimat[rt,3] = (2*m1 + 1)*(i - 1) + m1 + 2 + j
}
for (j in 1:(m1 - 1)) {
rt = rt + 1
trimat[rt,1] = (2*m1 + 1)*i + j + 1
trimat[rt,2] = (2*m1 + 1)*(i - 1) + m1 + 1 + j
trimat[rt,3] = (2*m1 + 1)*(i - 1) + m1 + 2 + j
}
for (j in 1:m1) {
rt = rt + 1
trimat[rt,1] = (2*m1 + 1)*(i - 1) + m1 + 1 + j
trimat[rt,2] = (2*m1 + 1)*i + j
trimat[rt,3] = (2*m1 + 1)*i + j + 1
}
}
if (m0 == m2/2) {
i = m0
for (j in 1:m1) {
rt = rt + 1
trimat[rt,1] = (2*m1 + 1)*(i - 1) + j
trimat[rt,2] = (2*m1 + 1)*(i - 1) + j + 1
trimat[rt,3] = (2*m1 + 1)*(i - 1) + m1 + 1 + j
}
for (j in 1:(m1 - 1)) {
rt = rt + 1
trimat[rt,1] = (2*m1 + 1)*(i - 1) + j + 1
trimat[rt,2] = (2*m1 + 1)*(i - 1) + m1 + 1 + j
trimat[rt,3] = (2*m1 + 1)*(i - 1) + m1 + 2 + j
}
}
#### for each triangle, list adjacent knots (up to three)
#print (trimat)
adjk = matrix(0,nrow = ntri,ncol = 3)
kij = 1:6
s1 = 1:3
s2 = 1:3
found = 1:ntri*0
for (i in 1:(ntri - 1)) {
for (j in (i + 1):ntri) {
kij[1:3] = trimat[i,]
kij[4:6] = trimat[j,]
if (length(unique(kij)) == 4) {
found[i] = found[i] + 1
found[j] = found[j] + 1
s1[1] = sum(kij == trimat[i,1])
s1[2] = sum(kij == trimat[i,2])
s1[3] = sum(kij == trimat[i,3])
s2[1] = sum(kij == trimat[j,1])
s2[2] = sum(kij == trimat[j,2])
s2[3] = sum(kij == trimat[j,3])
adjk[i,found[i]] = (kij[4:6])[s2 == 1]
adjk[j,found[j]] = (kij[1:3])[s1 == 1]
}
}
}
#### now determine which triangle contains each point
xtri = 1:n*0;still = 1:n>0
for (j in 1:ntri) {
for (i in 1:n) {
if (still[i]) {
if (intri(xmat[i,],knots[trimat[j,1],],knots[trimat[j,2],],knots[trimat[j,3],])) {
still[i] = FALSE
xtri[i] = j
}
}
}
}
### make the design matrix
dmat = matrix(0, nrow = n, ncol = capk)
bmat = matrix(1, nrow = 3, ncol = 3)
a = 1:3
for (i in 1:n) {
for (j in 1:3) {
a[j] = trimat[xtri[i],j]
bmat[j,2] = knots[a[j],1]
bmat[j,3] = knots[a[j],2]
}
binv = solve(bmat)
for (j in 1:3) {
dmat[i,a[j]] = binv[1,j] + binv[2,j]*x1[i] + binv[3,j]*x2[i]
}
}
#dmatc = cbind(dmat,zmat)
Dmat = cbind(Dmat, dmat)
vari = 1:capk*0 + ipr
varlist = c(varlist, vari)
#print (head(dmatc))
### make the constraint matrix
nconstr = sum(adjk > 0)
amat = matrix(0, nrow = nconstr, ncol = capk)
nr = 0
for (itri in 1:ntri) {
a = trimat[itri,]
for (j in 1:3) {
bmat[j,2] = knots[a[j],1]
bmat[j,3] = knots[a[j],2]
}
binv = solve(bmat)
for (i in 1:3) {
k = adjk[itri,i]
if(k > 0) {
nr = nr + 1
amat[nr,k] = 1
for (j in 1:3) {
amat[nr,a[j]] = -(binv[1,j] + binv[2,j]*knots[k,1] + binv[3,j]*knots[k,2])
}
}
}
}
#m = dim(amat)[1]
#a0 = matrix(0, nrow = m, ncol = p)
#new: s.conc.conc
if (all(!cvs)) {
amat = -amat
} else if (any(cvs) & any(!cvs)) {
stop ('Convex-concave or concave-convex fit is not implemented!')
}
amat_lst[[ipr]] = amat
#amatc = cbind(amat, a0)
## make the penalty matrix
# find common edges & penalize change in slope
pmat = matrix(0, nrow = 4 * m1 * m2,ncol = capk)
six = 1:6;nu = 1:4;obs = 1:4
nr = 0
for (i in 1:(ntri-1)) {
for (j in (i + 1):ntri) {
six[1:3] = trimat[i,]
six[4:6] = trimat[j,]
sixu = unique(six)
if (length(sixu) == 4) {
nr = nr + 1
for (ii in 1:4) {nu[ii] = sum(six == sixu[ii])}
a = sixu[min(obs[nu == 2])]
b = sixu[max(obs[nu == 2])]
c = sixu[min(obs[nu == 1])]
d = sixu[max(obs[nu == 1])]
bmat[1,2] = knots[a,1]
bmat[1,3] = knots[a,2]
bmat[2,2] = knots[b,1]
bmat[2,3] = knots[b,2]
bmat[3,2] = knots[c,1]
bmat[3,3] = knots[c,2]
binv = solve(bmat)
pmat[nr,a] = binv[1,1] + binv[2,1] * knots[d,1] + binv[3,1] * knots[d,2]
pmat[nr,b] = binv[1,2] + binv[2,2] * knots[d,1] + binv[3,2] * knots[d,2]
pmat[nr,c] = binv[1,3] + binv[2,3] * knots[d,1] + binv[3,3] * knots[d,2]
pmat[nr,d] = -1
}
}
}
pmat = pmat[1:nr,]
#p0 = matrix(0, nrow = nr, ncol = p)
#Pmat = cbind(Pmat, pmat)
#pmatc = cbind(pmat, p0)
pmat_lst[[ipr]] = pmat
#print (paste('nr: ', nr))
knots_lst[[ipr]] = knots
m12_lst[[ipr]] = c(m1,m2)
trimat_lst[[ipr]] = trimat
bmat_lst[[ipr]] = bmat
capk_lst[[ipr]] = capk
}
amat = as.matrix(bdiag(amat_lst))
m = dim(amat)[1]
if (p > 0) {
a0 = matrix(0, nrow = m, ncol = p)
} else {a0 = NULL}
amatc = cbind(amat, a0)
#one = 1:n*0 + 1
#pm = one %*% solve(crossprod(one), t(one))
#Dmat = Dmat - pm %*% Dmat
dmatc = cbind(Dmat, zmat)
pmat = as.matrix(bdiag(pmat_lst))
if (p > 0) {
p0 = matrix(0, nrow = nrow(pmat), ncol = p)
} else {p0 = NULL}
pmatc = cbind(pmat, p0)
#capk is for all columns of tri-surfaces pairs
capk = sum(unlist(capk_lst))
}
#print (dim(amatc))
nr = nrow(amatc); nc = ncol(amatc)
pb = 0
if (!is.null(delta_add)) {
pb = nrow(delta_add)
dmatc = cbind(t(delta_add), dmatc)
}
if (pb >= 1) {
tmp = matrix(0, nrow = (nr+pb), ncol = (nc+pb))
amatb = diag(pb)
#np_add is shape == 17
if (np_add > 0) {
amatb[1:np_add,1:np_add] = 0
}
tmp[1:pb,1:pb] = amatb
tmp[(pb+1):(nr+pb), (pb+1):(nc+pb)] = amatc
amatc = tmp
}
if (pb >= 1) {
pmatb = matrix(0, nrow = dim(pmatc)[1], ncol = pb)
pmatc = cbind(pmatb, pmatc)
}
if (!is.null(amat_wp)) {
pwp = ncol(delta_wp)
dmatc = cbind(dmatc, delta_wp)
amatc = as.matrix(bdiag(amatc, amat_wp))
pmatc = as.matrix(bdiag(pmatc, dmat_wp))
} else {pwp = 0}
#new: always let lambda > 0
if (round(lambda, 6) > 1e-6) {
ps = lambda
#} else if (pnt & (round(lambda, 6) == 0)) {
#mat = cbind(1, x1, x2, x1*x2)
#mat = cbind(1, x1t[,1], x2t[,1], x1t[,1]*x2t[,1])
#if (nprs >= 2) {
# for (ipr in 2:nprs) {
# mat = cbind(mat, x1t[,ipr], x2t[,ipr], x1t[,ipr]*x2t[,ipr])
# }
#}
#mu_para = mat %*% solve(t(mat) %*% mat) %*% t(mat) %*% y
#ssr = sum((y - mu_para)^2)
#sc = ssr / (n - ncol(mat))
#ps = max(1e-6, 1 * sc)
} else {
ps = 10*1/n^(1/3)
#ps = 1e-6
}
lambda = ps
#print (paste('pen:',lambda))
if (!wt.iter) {
# weight
yw = y
dw = dmatc
if (!is.null(w)) {
if (min(w) > 1e-8) {
yw = y * sqrt(w)
for (i in 1:n) {
dw[i, ] = dmatc[i, ] * sqrt(w[i])
}
} else {print ("check the user-defined weights!")}
}
#print (dim(dmatc))
umatc = chol(t(dw) %*% dw + lambda * t(pmatc) %*% pmatc)
uinv = solve(umatc)
atil = amatc %*% uinv
zvec = t(uinv) %*% t(dw) %*% yw
ans = coneA(zvec, atil)
thhat = uinv %*% ans$thetahat
muhat = dmatc %*% thhat
etahat = muhat
} else {
etahat = etahat.fun(n, y, fml = family$family)
gr = gr.fun(y, etahat, weights = w, fml = family$family)
wt = wt.fun(y, etahat, n, weights = w, fml = family$family)
cvec = crossprod(dmatc, (wt * etahat - gr))
umatc = chol(t(dmatc) %*% diag(wt) %*% dmatc + lambda * t(pmatc) %*% pmatc)
uinv = solve(umatc)
atil = amatc %*% uinv
zvec = t(uinv) %*% t(dmatc) %*% y
ans = coneA(zvec, atil)
thhat = uinv %*% ans$thetahat
etahat = dmatc %*% thhat
muhat = muhat.fun(etahat, fml = family$family)
diff = 1
nrep = 0
sm = 1e-6
while (diff > sm & nrep < 100) {
oldmu = muhat
nrep = nrep + 1
gr = gr.fun(y, etahat, weights = w, fml = family$family)
wt = wt.fun(y, etahat, n, weights = w, fml = family$family)
cvec = crossprod(dmatc, (wt * etahat - gr))
umatc = chol(t(dmatc) %*% diag(wt) %*% dmatc + lambda * t(pmatc) %*% pmatc)
uinv = solve(umatc)
atil = amatc %*% uinv
zvec = t(uinv) %*% t(dmatc) %*% y
ans = coneA(zvec, atil)
thhat = uinv %*% ans$thetahat
etahat = dmatc %*% thhat
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
}
#llh = llh.fun(y, muhat, etahat, n, w, fml = family$family)
}
llh = llh.fun(y, muhat, etahat, phihat=NULL, n, w, fml = family$family)
coefkeep = ans$thetahat
muhatkeep = muhat
etahatkeep = etahat
thhatkeep = thhat
if (pb > 0) {
#print (dim(delta_add))
#print (varlist_add)
coef_add = thhat[1:pb]
capl = ncol(xmat_add)
thvecs = matrix(0, nrow = capl, ncol = n)
ncon = 0
#vcoef_add = coef_add[1:capl]
vcoef_add = coef_add[1:np_add]
lconv = sum(shapes_add > 2 & shapes_add < 5 | shapes_add > 10 & shapes_add < 13)
if (lconv > 0) {
dcoefs = coef_add[-c(1:lconv)]
delta_add2 = delta_add[-c(1:lconv), ,drop = FALSE]
} else {
dcoefs = coef_add
delta_add2 = delta_add
}
for (i in 1:capl) {
thvecs[i,] = t(delta_add2[varlist_add == i,]) %*% dcoefs[varlist_add == i]
if (shapes_add[i] > 2 & shapes_add[i] < 5 | shapes_add[i] > 10 & shapes_add[i] < 13) {
ncon = ncon + 1
thvecs[i,] = thvecs[i,] + vcoef_add[ncon] * xmat_add[,i]
}
}
} else {coef_add = 0; thvecs = NULL}
if (p > 0) {
zcoefs = thhat[(pb+capk+1):(pb+capk+p)]
} else {zcoefs = 0}
if (pwp > 0) {
nth = length(thhat)
coef_wp = thhat[(nth-pwp+1):nth]
} else {coef_wp = 0}
#vcoefs include zcoefs and shape = 17
vcoefs = zcoefs
#vmat = dmatc[,(pb+capk+1):(pb+capk+p), drop=F]
#vmat = cbind(1:n*0+1, zmat)
vmat = zmat
if (np_add > 0) {
vcoefs = c(thhat[1:np_add], vcoefs)
vmat = cbind(dmatc[, 1:np_add, drop=F], vmat)
}
#pv = vmat %*% solve(crossprod(vmat), t(vmat))
if (is.null(vmat)) {
muvhat = 0
} else {
muvhat = muhat.fun(vmat %*% vcoefs, fml = family$family)
}
if (is.null(w)) {
w = rep(1, n)
}
sse1 = sum(w*(y - muhat)^2)
sse0 = sum(w*(y - muvhat)^2)
#new use edf instead if (n - cpar * edf) < 0
if (!is.null(vmat)) {
np = ncol(vmat)
} else {np = 0}
### find the GCV
atil0 = atil[round(atil %*% coefkeep, 8) == 0,]
ans1 = qr(t(atil0))
ared = qr.Q(ans1)[,1:ans1$rank]
prmat = ared %*% solve(t(ared) %*% ared) %*% t(ared)
#imat = matrix(0, nrow = capk+p, ncol = capk+p)
#for (i in 1:(capk+p)) {imat[i,i] = 1}
#diag(imat) = 1
imat = diag(ncol(dmatc))
bigpr = dmatc %*% uinv %*% (imat - prmat) %*% t(uinv) %*% t(dmatc)
edf = sum(diag(bigpr))
gcv = sse1 / (1 - edf/n)^2
#if ((n - np - cpar * edf) <= 0) {
if ((n - cpar * edf) <= 0) {
sig2hat = sse1 / edf
} else {
sig2hat = sse1 / (n - cpar * edf)
}
#print (sig2hat)
#if (p >= 1) {
# #inmat = matrix(0, nrow = n, ncol = n)
# #diag(inmat) = 1
# inmat = diag(n)
# one = 1:n*0+1
# pm = one %*% solve(crossprod(one)) %*% t(one)
#print (dim(zmat))
#print (dim(bigpr))
# covmat = solve(t(zmat) %*% (inmat - bigpr) %*% zmat)
# print (covmat)
# print (sig2hat)
# sez = sqrt(diag(covmat) * sig2hat)
# tz = zcoef / sez
#new use edf instead if (n - cpar * edf) < 0
# if ((n - p - cpar * edf) <= 0) {
# pz = 2 * (1 - pt(abs(tz), edf))
# if (p > 1) {
# warning ('Effective degrees of freedom is close to the number of observations! Inference about parametric covariates is not reliable!')
# }
#print ('Check pz!')
# } else {
# pz = 2 * (1 - pt(abs(tz), n - p - cpar * edf))
# }
#} else {pz = NULL; sez = NULL}
pz = NULL; sez = NULL
#new: get cic
cic = NULL
if (is.null(w)) {
w = rep(1, n)
}
dw = dmatc
for (i in 1:n) {
dw[i, ] = dmatc[i, ] * sqrt(w[i])
}
if (nsim > 0) {
edfs = 1:nsim*0
if (!wt.iter) {
for (isim in 1:nsim) {
ysim = rnorm(n)
ysim = ysim * sqrt(w)
zvec = t(uinv) %*% t(dw) %*% ysim
ansi = coneA(zvec, atil, msg=FALSE)
thhati = uinv %*% ansi$thetahat
muhati = dmatc %*% thhati
etahati = muhati
edfi = tri_getedf(cf = ansi$thetahat, atil, dmatc, uinv, ncol(dmatc))
edfs[isim] = edfi
}
#cic = log(sse1) + log(2 * (mean(edfs) + p) / (n - p - 1.5 * mean(edfs)) + 1)
#cic = llh + log(2 * (mean(edfs) + p) / (n - p - 1.5 * mean(edfs)) + 1)
cic = llh + log(2 * (mean(edfs)) / (n - np - 1.5 * (mean(edfs) - np)) + 1)
} else {
if (family$family == "poisson") {
mu0 = mean(y)
} else {mu0 = NULL}
for (isim in 1:nsim) {
ysim = ysim.fun(n, mu0, fml = family$family)
etahat = etahat.fun(n, ysim, fml = family$family)
gr = gr.fun(ysim, etahat, weights = w, fml = family$family)
wt = wt.fun(ysim, etahat, n, weights = w, fml = family$family)
cvec = crossprod(dmatc, (wt * etahat - gr))
umatc = chol(t(dmatc) %*% diag(wt) %*% dmatc + lambda * t(pmatc) %*% pmatc)
uinv = solve(umatc)
atil = amatc %*% uinv
zvec = t(uinv) %*% t(dmatc) %*% ysim
ansi = coneA(zvec, atil, msg=FALSE)
thhat = uinv %*% ansi$thetahat
etahat = dmatc %*% thhat
muhat = muhat.fun(etahat, fml = family$family)
diff = 1
nrep = 0
while (diff > sm & nrep < 100) {
oldmu = muhat
nrep = nrep + 1
gr = gr.fun(ysim, etahat, weights = w, fml = family$family)
wt = wt.fun(ysim, etahat, n, weights = w, fml = family$family)
cvec = crossprod(dmatc, (wt * etahat - gr))
umatc = chol(t(dmatc) %*% diag(wt) %*% dmatc + lambda * t(pmatc) %*% pmatc)
uinv = solve(umatc)
atil = amatc %*% uinv
zvec = t(uinv) %*% t(dmatc) %*% ysim
ansi = coneA(zvec, atil)
thhat = uinv %*% ansi$thetahat
etahat = dmatc %*% thhat
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
}
edfi = tri_getedf(cf = ansi$thetahat, atil, dmatc, uinv, ncol(dmatc))
edfs[isim] = edfi
}
#cic = llh + log(2 * (mean(edfs) + p) / (n - p - 1.5 * mean(edfs)) + 1)
cic = llh + log(2 * (mean(edfs)) / (n - np - 1.5 * (mean(edfs) - np)) + 1)
}
}
ans = new.env()
ans$family = family
ans$edf = edf
if (nsim > 0) {
ans$edf0 = mean(edfs) #+ p
} else {ans$edf0 = p}
ans$zcoefs = zcoefs
ans$pvals.beta = pz
ans$se.beta = sez
ans$muhat = muhatkeep
ans$etahat = etahatkeep
ans$gcv = gcv
#ans$knots = knots
ans$thhat = thhatkeep
ans$coef_tri = thhatkeep[(pb+1):(pb+capk)]
ans$trimat = trimat
ans$x1 = x1
ans$x2 = x2
ans$d0 = p
ans$zmat = zmat
ans$capk = capk
ans$cic = cic
ans$sse1 = sse1
#ans$sse0 = sse0
ans$varlist = varlist
ans$coef_add = coef_add
ans$coef_wp = coef_wp
ans$etacomps = thvecs
ans$pen = lambda
ans$knots_lst = knots_lst
#new: in trispl, knots' length is not m1 or m2, it's much larger
ans$m12_lst = m12_lst
ans$trimat_lst = trimat_lst
ans$bmat_lst = bmat_lst
ans$capk_lst = capk_lst
#new
ans$dmatc = dmatc
ans$pmatc = pmatc
ans$amatc = amatc
ans$sig2hat = sig2hat
ans
}
tri_getedf = function(cf = NULL, atil, dmatc, uinv, nc) {
atil0 = atil[round(atil %*% cf, 8) == 0,]
ans1 = qr(t(atil0))
ared = qr.Q(ans1)[,1:ans1$rank]
prmat = ared %*% solve(t(ared) %*% ared) %*% t(ared)
imat = diag(nc)
bigpr = dmatc %*% uinv %*% (imat - prmat) %*% t(uinv) %*% t(dmatc)
edf = sum(diag(bigpr))
return (edf)
}
###
#trispl makedelta: used in predict.trispl
###
makedelta_tri = function(x1, x2, m1 = 0, m2 = 0, k1 = NULL, k2 = NULL, trimat = NULL, capk = NULL, space = c("E",
"E"), cvs = c(TRUE, TRUE), interp = TRUE) {
n = length(x1)
xmat = cbind(x1, x2)
delta = NULL
#### now determine which triangle contains each point
xtri = 1:n*0;still = 1:n>0
ntri = (m2 - 1) * (2 * m1 - 1)
knots = cbind(k1, k2)
for (j in 1:ntri) {
for (i in 1:n) {
if (still[i]) {
if (intri(xmat[i,],knots[trimat[j,1],],knots[trimat[j,2],],knots[trimat[j,3],])) {
still[i] = FALSE
xtri[i] = j
}
}
}
}
### make the design matrix
dmat = matrix(0, nrow = n, ncol = capk)
bmat = matrix(1, nrow = 3, ncol = 3)
a = 1:3
for (i in 1:n) {
for (j in 1:3) {
a[j] = trimat[xtri[i],j]
bmat[j,2] = knots[a[j],1]
bmat[j,3] = knots[a[j],2]
}
binv = solve(bmat)
for (j in 1:3) {
dmat[i,a[j]] = binv[1,j] + binv[2,j]*x1[i] + binv[3,j]*x2[i]
}
}
delta = cbind(delta, dmat)
return (delta)
}
##
s.conv.conv <- function(x1, x2, numknots = c(0, 0), knots = list(k1 = 0, k2 = 0), space = c("E", "E"))
{
cl <- match.call()
pars1 <- match.call()[2]
pars2 <- match.call()[3]
xm <- cbind(x1, x2)
attr(xm, "name") <- c(deparse(pars1$x1), deparse(pars2$x2))
attr(xm, "shape") <- "tri_cvs"
attr(xm, "numknots") <- numknots
attr(xm, "knots") <- knots
attr(xm, "space") <- space
attr(xm, "cvs") <- c(TRUE, TRUE)
attr(xm, "categ") <- "tri"
#warp <<- TRUE
#class(xm) <- "tri"
return (xm)
}
s.conc.conc <- function(x1, x2, numknots = c(0, 0), knots = list(k1 = 0, k2 = 0), space = c("E", "E"))
{
cl <- match.call()
pars1 <- match.call()[2]
pars2 <- match.call()[3]
xm <- cbind(x1, x2)
attr(xm, "name") <- c(deparse(pars1$x1), deparse(pars2$x2))
attr(xm, "shape") <- "tri_ccs"
attr(xm, "numknots") <- numknots
attr(xm, "knots") <- knots
attr(xm, "space") <- space
attr(xm, "cvs") <- c(FALSE, FALSE)
attr(xm, "categ") <- "tri"
#warp <<- TRUE
#class(xm) <- "tri"
return (xm)
}
################
#summary.trispl#
################
#summary.trispl <- function(object,...) {
# if (!is.null(object$zcoefs)) {
# coefs <- object$zcoefs
# se <- object$se.beta
# #tval <- object$tz
# pvalbeta <- object$pvals.beta
# tval <- coefs / se
# n <- length(coefs)
# #sse0 <- object$SSE0
# #sse1 <- object$SSE1
# zid <- object$zid
#new: zid1, zid2 just index zmat not bigmat
# zid1 <- object$zid1
# zid2 <- object$zid2
# #tms <- object$tms
# #zmat <- object$zmat
# #is_mat <- object$is_mat
# is_param <- object$is_param
# is_fac <- object$is_fac
# vals <- object$vals
# tms <- object$tms
#new:
# cic <- object$cic
# rslt1 <- data.frame("Estimate" = round(coefs, 4), "StdErr" = round(se, 4), "t.value" = round(tval, 4), "p.value" = round(pvalbeta, 4))
# rownames(rslt1)[1] <- "(Intercept)"
# if (n > 1) {
# lzid <- length(zid1)
# for (i in 1:lzid) {
# pos1 <- zid1[i]; pos2 <- zid2[i]
# for (j in pos1:pos2) {
# if (!is_param[i]) {
# rownames(rslt1)[j + 1] <- paste(attributes(tms)$term.labels[zid[i] - 1], rownames(rslt1)[j + 1], sep = "")
# } else {
# rownames(rslt1)[j + 1] <- paste(attributes(tms)$term.labels[zid[i] - 1], vals[j], sep = "")
# }
# }
# }
# }
# rslt1 <- as.matrix(rslt1)
# #if (!is.null(sse0) & !is.null(sse1)) {
# # rslt2 <- data.frame("SSE.Linear" = sse0, "SSE.Full" = sse1)
#new:
# # rownames(rslt2)[1] <- ""
# #rslt2 <- as.matrix(rslt2)
# # ans <- list(call = object$call, coefficients = rslt1, residuals = rslt2, zcoefs = coefs)
# # class(ans) <- "summary.wps"
# # ans
# #} else {
# ans <- list(call = object$call, coefficients = rslt1, zcoefs = coefs, cic = cic)
# class(ans) <- "summary.trispl"
# ans
# #}
# } else {
# ans <- list(zcoefs = object$zcoefs)
# class(ans) <- "summary.trispl"
# ans
# }
#}
#######################
#print.summary.trispl #
#######################
#print.summary.trispl <- function(x,...) {
# if (!is.null(x$zcoefs)) {
# #if (!is.null(x$se.beta)) {
# cat("Call:\n")
# print(x$call)
# cat("\n")
# cat("Coefficients:")
# cat("\n")
# printCoefmat(x$coefficients, P.values = TRUE, has.Pvalue = TRUE)
# cat("\n")
# if (!is.null(x$cic)) {
# cat("CIC: ", round(x$cic,4), "\n", sep = "")
# }
# } else {
# print ("No linear predictor is defined")
# }
#}
#################
#plotpersp.tri#
################
plotpersp.trispl = function(object, x1 = NULL, x2 = NULL, x1nm = NULL, x2nm = NULL,
data = NULL, surface = "C", categ = NULL, col = NULL,
random = FALSE, ngrid = 12, xlim = range(x1),
ylim = range(x2), zlim = NULL, xlab = NULL,
ylab = NULL, zlab = NULL, th = NULL, ltheta = NULL,
main = NULL, ticktype = "simple",...) {
if (!inherits(object, "trispl")) {
warning("calling plotpersp(<fake-trisp-object>) ...")
}
#x1nm = deparse(substitute(x1))
#x2nm = deparse(substitute(x2))
xnms = object$xnms_tri
xmat = object$xmat_tri
#if (x1nm == "NULL" | x2nm == "NULL") {
if (is.null(x1nm) | is.null(x2nm)) {
if (length(xnms) >= 2) {
x1nm = xnms[1]
x2nm = xnms[2]
x1id = 1
x2id = 2
x1 = xmat[, 1]
x2 = xmat[, 2]
} else {stop ("Number of non-parametric predictors must >= 2!")}
}
#x1nm0 = xnms[1]
#x2nm0 = xnms[2]
#x1 = xmat[, 1]
#x2 = xmat[, 2]
is_fac = object$is_fac
ynm = object$ynm
#xmat is delta
#delta = object$delta
znms = object$znms
kznms = length(znms)
#zmat not include 1 vector
zmat = object$zmat
#zmat0 = zmat[, -1, drop = FALSE]
zmat0 = zmat
#zcoefs = object$zcoefs[-1]
zcoefs = object$zcoefs
zid1 = object$zid1
zid2 = object$zid2
p = object$d0
cvss = object$cvss
labels = object$labels
labels = labels[which(grepl("tri", labels, fixed = TRUE))]
varlist = object$varlist_tri
#varlist = varlist[-1]
#knots = object$kts
#trimat = object$trimat
family = object$family
fml = family$family
#print (family)
cicfamily = CicFamily(family)
muhat.fun = cicfamily$muhat.fun
#if (!is.null(categ)) {
# if (!is.character(categ)) {
# warning("categ must be a character argument!")
# } else if (!any(znms == categ)) {
#print ('TRUE')
# warning(paste(categ, "is not an exact character name defined in the cgam fit!"))
# categ = NULL
# } else {
# obsz = 1:kznms
# zid = obsz[znms == categ]
# if (!(is_fac[zid])) {
# categ = NULL
# }
# }
#}
if (!is.null(categ)) {
if (!is.character(categ)) {
warning("categ must be a character argument!")
} else if (!any(znms == categ)) {
if (any(grepl(categ, znms))) {
id = which(grepl(categ, znms))
znmi = znms[id]
if (grepl("as.factor", znmi)) {
categ = paste("as.factor(", categ, ")", sep = "")
} else if (grepl("factor", znmi)) {
categ = paste("factor(", categ, ")", sep = "")
} else {print(paste(categ, "is not an exact character name defined in the cgam fit!"))}
} else {print(paste(categ, "is not an exact character name defined in the cgam fit!"))}
} else {
obsz = 1:kznms
zid = obsz[znms == categ]
#linear term:
if (!(is_fac[zid])) {
categ = NULL
}
}
}
#new: switch xnms
if (!is.null(data)) {
if (!is.data.frame(data)) {
stop ("User need to make the data argument a data frame with names for each variable!")
}
datnms = names(data)
if (!any(datnms == x1nm) | !any(datnms == x2nm)) {
stop ("Check the accuracy of the names of x1 and x2!")
}
x1 = data[ ,which(datnms == x1nm)]
x2 = data[ ,which(datnms == x2nm)]
} else {
if (all(xnms != x1nm)) {
#stop (paste(paste("'", x1nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
#new: in case of wrong data fame
if (length(x1) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x1!")
}
bool = apply(xmat, 2, function(x) all(x1 == x))
if (any(bool)) {
#x1id = obs[bool]
x1nm = xnms[bool]
} else {
stop (paste(paste("'", x1nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
if (all(xnms != x2nm)) {
#stop (paste(paste("'", x2nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
if (length(x2) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x2!")
}
bool = apply(xmat, 2, function(x) all(x2 == x))
if (any(bool)) {
#x2id = obs[bool]
x2nm = xnms[bool]
} else {
stop (paste(paste("'", x2nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
}
xnm12 = c(x1nm, x2nm)
#print (xnms)
#print(xnm12)
id_lab = which(xnms %in% xnm12)
#print (labels)
#print (xnm12)
xnm12_lab = labels[id_lab]
id1 = id2 = ipr = NULL
if (length(unique(xnm12_lab)) > 1 | length(id_lab) != 2) {
stop ("Two non-parametric predictors do not form a triangle-spline surface!")
} else {
id1 = sort(id_lab)[1]
id2 = sort(id_lab)[2]
ipr = id2 / 2
}
#decrs = decrs0[[ipr]]
#ktsi = kts[[ipr]]
#k1 = ktsi[[1]]
#k2 = ktsi[[2]]
knots_lst = object$knots_lst
trimat_lst = object$trimat_lst
bmat_lst = object$bmat_lst
thhat_all = object$coef_tri
capk_lst = object$capk_lst
knots = knots_lst[[ipr]]
trimat = trimat_lst[[ipr]]
bmat = bmat_lst[[ipr]]
capk = capk_lst[[ipr]]
cvs = cvss[[ipr]]
thhat = thhat_all[which(varlist == ipr)]
if (p > 0) {
thhat = c(thhat, zcoefs)
}
#additive
thvecs = object$etacomps
xnms_add = object$xnms_add
xmat_add = object$xmat_add
knms = length(xnms_add)
x3_add = 0
if (knms >= 1) {
#x3id <- obs[-c(x1id, x2id)]
#kx3 <- length(x3id)
for (i in 1:knms) {
x3i = xmat_add[, i]
x3i_use = max(x3i[x3i <= median(x3i)])
x3i_add = min(thvecs[i, x3i == x3i_use])
x3_add = x3_add + x3i_add
}
}
ntri = nrow(trimat)
if (x1nm != xnms[1] & x2nm != xnms[2]) {
nm = x1nm
x1nm = x2nm
x2nm = nm
tmp = x1
x1 = x2
x2 = tmp
} else {x1nm = x1nm; x2nm = x2nm}
if (is.null(th) | !is.numeric(th)) {
ang = NULL
if (cvs[1] & cvs[2]) {
if (is.null(ang)) {
ang = 140
}
} else if (!cvs[1] & !cvs[2]) {
if (is.null(ang)) {
ang = 25
}
}
} else {ang = th}
if (is.null(ltheta) | !is.numeric(ltheta)) {
ltheta <- -135
}
#make the surface
g = ngrid
ng = g^2
x1g = 0:(g-1)/(g-1) * (max(x1)-min(x1)) + min(x1)
x2g = 0:(g-1)/(g-1) * (max(x2)-min(x2)) + min(x2)
gg = matrix(0, nrow = ng, ncol = 2)
for (i in 1:g) {
gg[((i-1) * g + 1):(i * g),1] = x1g
gg[((i-1) * g + 1):(i * g),2] = 1:g * 0 + x2g[i]
}
gtri = 1:ng * 0
still = 1:ng>0
for (j in 1:ntri) {
for (i in 1:ng) {
if (still[i]) {
if (intri(gg[i,],knots[trimat[j,1],],knots[trimat[j,2],],knots[trimat[j,3],])) {
still[i] = FALSE
gtri[i] = j
}
}
}
}
gmat = matrix(0,nrow = ng,ncol = capk)
#print (gmat)
bmat = matrix(1,nrow = 3,ncol = 3)
a = 1:3
for (i in 1:ng) {
for (j in 1:3) {
#if (gtri[i] > 0) {
a[j] = trimat[gtri[i],j]
bmat[j,2] = knots[a[j],1]
bmat[j,3] = knots[a[j],2]
#}
}
binv = solve(bmat)
for (j in 1:3) {
gmat[i,a[j]] = binv[1,j] + binv[2,j] * gg[i,1] + binv[3,j] * gg[i,2]
}
}
#?
#if (p > 0) {
g0 = matrix(0,nrow = dim(gmat)[1],ncol = p)
#} else {g0 = NULL}
#print (g0)
#print (dim(gmat))
#print (dim(thhat))
gvals = cbind(gmat, g0) %*% thhat
#print (gvals)
mupl = matrix(gvals, nrow = g)
m1 = g
m2 = ncol(mupl)
if (fml != "gaussian") {
for (i1 in 1:m1) {
for (i2 in 1:m2) {
mupl[i1, i2] = muhat.fun(mupl[i1, i2], fml = fml)
}
}
#mupl = muhat.fun(mupl, fml = fml)
}
if (is.null(categ)) {
z_add = 0
if (!is.null(znms)) {
#if (p > 0) {
#print ('skip')
kzids = length(zid1)
for (i in 1:kzids) {
pos1 = zid1[i]; pos2 = zid2[i]
#zi is a factor
zi = zmat0[, pos1:pos2, drop = FALSE]
zcoefsi = zcoefs[pos1:pos2]
for (j in 1:ncol(zi)){
#find the 'mode' of the jth column of zi; add the coef corresponding to the 'mode'
uzij = unique(zi[,j])
kuzij = length(uzij)
nmodej = sum(zi[,j] == uzij[1])
zij_mode = uzij[1]
for (u in 2:kuzij) {
if (sum(zi[,j] == uzij[u]) > nmodej) {
zij_mode = uzij[u]
nmodej = sum(zi[,j] == uzij[u])
}
}
obsuzij = 1:length(uzij)
uzhatij = uzij * zcoefsi[j]
zij_add = uzhatij[obsuzij[uzij == zij_mode]]
z_add = z_add + zij_add
}
}
}
mupl = mupl + as.numeric(z_add) + as.numeric(x3_add)
#print (mupl)
m1 = nrow(mupl)
m2 = ncol(mupl)
if (fml != "gaussian") {
for (i1 in 1:m1) {
for (i2 in 1:m2) {
mupl[i1, i2] = muhat.fun(mupl[i1, i2], fml = fml)
}
}
#mupl = muhat.fun(mupl, fml = fml)
}
mins = min(mupl); maxs = max(mupl)
} else {
mupls = list()
mins = maxs = NULL
obsz = 1:kznms
zid = obsz[znms == categ]
pos1 = zid1[zid]; pos2 = zid2[zid]
zcoefsi = zcoefs[pos1:pos2]
#include the base level
zcoefsi = c(0, zcoefsi)
z_add = sort(zcoefsi)
kz_add = length(z_add)
for (iz in 1:kz_add) {
mupls[[iz]] = mupl + z_add[iz] + as.numeric(x3_add)
mins = c(mins, min(mupls[[iz]]))
maxs = c(maxs, max(mupls[[iz]]))
}
m1 = nrow(mupl)
m2 = ncol(mupl)
if (fml != "gaussian") {
for (iz in 1:kz_add) {
mupli = mupls[[iz]]
for (i1 in 1:m1) {
for (i2 in 1:m2) {
mupli[i1, i2] = muhat.fun(mupli[i1, i2], fml = fml)
}
}
#mupli = muhat.fun(mupli, fml = fml)
mupls[[iz]] = mupli
}
}
}
palette = c("peachpuff", "lightblue", "limegreen", "grey", "wheat", "yellowgreen", "seagreen1", "palegreen", "azure", "whitesmoke")
if (is.null(xlab)) {
xlab = x1nm
}
if (is.null(ylab)) {
ylab = x2nm
}
if (is.null(zlab)) {
if (fml == "binomial") {
zlab = paste("Pr(", ynm, ")")
} else if (fml == "poisson" | fml == "gaussian" | fml == "Gamma") {
zlab = paste("Est mean of", ynm)
}
}
if (is.null(categ)) {
if (is.null(col)) {
if (random) {
col = sample(palette, size = 1, replace = FALSE)
} else {
#col = "white"
musurf = mupl
nr = nrow(musurf)
nc = ncol(musurf)
ncol = 100
facet = musurf[-1,-1] + musurf[-1,-nc] + musurf[-nr,-1] + musurf[-nr,-nc]
#print (facet)
facetcol = cut(facet, ncol)
col = heat.colors(ncol)[facetcol]
}
} else {
if (col == "heat" | col == "topo" | col == "terrain" | col == "cm") {
nr = nrow(mupl)
nc = ncol(mupl)
ncol = 100
facet = mupl[-1,-1] + mupl[-1,-nc] + mupl[-nr,-1] + mupl[-nr,-nc]
facetcol = cut(facet, ncol)
if (col == "heat") {
col = heat.colors(ncol)[facetcol]
} else if (col == "topo") {
col = topo.colors(ncol)[facetcol]
} else if (col == "terrain") {
col = terrain.colors(ncol)[facetcol]
} else {
col = cm.colors(ncol)[facetcol]
}
}
if (random) {
print ("User defined color is used!")
}
}
#if (surface == 'C') {
musurf = mupl
#if (is.null(main)) {
# main = 'Constrained Warped-Plane Spline Surface'
#}
if (is.null(zlim)) {
lwr = min(mins)
upp = max(maxs)
zlim0 = c(lwr - (upp-lwr)/5, upp + (upp-lwr)/5)
} else {
zlim0 = zlim
}
#}
#persp(k1, k2, musurf, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype,...)
persp(x1g, x2g, musurf, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype,...)
res = list(musurf = mupl, gg = gg, x1g=x1g, x2g=x2g, z_add = z_add, x3_add = x3_add, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = col, cex.axis = .75, main = main, ticktype = ticktype)
invisible(res)
} else {
kxgm = length(mupls)
if (is.null(col)) {
if (random) {
#new:
col = topo.colors(kxgm)
} else {
if (kxgm > 1 & kxgm < 11) {
col = palette[1:kxgm]
} else {
#new:
col = topo.colors(kxgm)
}
}
} else {
col0 = col
if (col0 == "heat" | col0 == "topo" | col0 == "terrain" | col0 == "cm") {
#col0 <- col
ncol = 100
facets = facetcols = list()
col = list()
for (i in 1:kxgm) {
nr = nrow(mupls[[i]])
nc = ncol(mupls[[i]])
facets[[i]] = (mupls[[i]])[-1,-1] + (mupls[[i]])[-1,-nc] + (mupls[[i]])[-nr,-1] + (mupls[[i]])[-nr,-nc]
facetcols[[i]] = cut(facets[[i]], ncol)
#print (head(facetcols[[i]]))
if (col0 == "heat") {
col[[i]] = (heat.colors(ncol))[facetcols[[i]]]
#print (head(col[[i]]))
} else if (col0 == "topo") {
col[[i]] = (topo.colors(ncol))[facetcols[[i]]]
} else if (col0 == "terrain") {
col[[i]] = (terrain.colors(ncol))[facetcols[[i]]]
} else {
col[[i]] = (cm.colors(ncol))[facetcols[[i]]]
}
}
} else if (length(col0) < kxgm) {
#new:
col = topo.colors(kxgm)
} else if (length(col0) > kxgm) {
col = col0[1:kxgm]
}
}
for (i in 1:kxgm) {
mupli = mupls[[i]]
#if (surface == 'C') {
musurf = mupli
#if (is.null(main)) {
# main = 'Constrained Warped-Plane Spline Surface'
#}
if (is.null(zlim)) {
lwr = min(mins)
upp = max(maxs)
zlim0 = c(lwr - (upp-lwr)/5, upp + (upp-lwr)/5)
} else {
zlim0 = zlim
}
#}
if (is.list(col)) {
coli = unlist(col[[i]])
#print (head(coli))
} else {coli = col[i]}
#persp(k1, k2, musurf, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = col[i], cex.axis = .75, main = main, ticktype = ticktype,...)
persp(x1g, x2g, musurf, xlim = xlim, ylim = ylim, zlim = zlim0, xlab = x1nm, ylab = x2nm, zlab = ynm, theta = ang, ltheta = ltheta, col = coli, cex.axis = .75, main = main, ticktype = ticktype,...)
par(new = TRUE)
}
par(new = FALSE)
}
}
##########################################
#apply plotpersp on a trispl.predict object
#not done: >= 1 tri pair + additive + z, ignore wps
#one pair + z only
##########################################
plotpersp.trisplp = function(object, x1=NULL, x2=NULL, x1nm=NULL, x2nm=NULL, data=NULL, up = TRUE, main=NULL, cex.main=.8, xlab = NULL, ylab = NULL, zlab = NULL, th = NULL, ltheta = NULL, ticktype = "simple",...) {
#obj is prediction for trispl
if (!inherits(object, "trisplp")) {
warning("calling plotpersp(<fake-trisplp-object>) ...")
}
t_col = function(color, percent = 50, name = NULL) {
rgb.val <- col2rgb(color)
## Make new color using input color as base and alpha set by transparency
t.col <- rgb(rgb.val[1], rgb.val[2], rgb.val[3],
maxColorValue = 255,
alpha = (100-percent)*255/100,
names = name)
## Save the color
invisible(t.col)
}
if (up) {
mycol = t_col("green", perc = 90, name = "lt.green")
} else {
mycol = t_col("pink", perc = 80, name = "lt.pink")
}
acov = object$acov
mult = object$mult
#obj is the wps fit
obj = object$object
xnms = obj$xnms_tri
xmat = obj$xmat_tri
xnms_add = obj$xnms_add
xmat_add = obj$xmat_add
delta = obj$dmatc
#if (x1nm == "NULL" | x2nm == "NULL") {
if (is.null(x1nm) | is.null(x2nm)) {
if (length(xnms) >= 2) {
x1nm = xnms[1]
x2nm = xnms[2]
x1id = 1
x2id = 2
x1 = xmat[, 1]
x2 = xmat[, 2]
} else {stop ("Number of non-parametric predictors must >= 2!")}
}
labels = obj$labels
labels = labels[which(grepl("tri", labels, fixed = TRUE))]
is_fac = obj$is_fac
ynm = obj$ynm
varlist = obj$varlist_tri
kts = obj$knots_lst
np = obj$d0
#switch xnms
if (!is.null(data)) {
if (!is.data.frame(data)) {
stop ("User need to make the data argument a data frame with names for each variable!")
}
datnms = names(data)
if (!any(datnms == x1nm) | !any(datnms == x2nm)) {
stop ("Check the accuracy of the names of x1 and x2!")
}
x1 = data[ ,which(datnms == x1nm)]
x2 = data[ ,which(datnms == x2nm)]
} else {
if (all(xnms != x1nm)) {
#stop (paste(paste("'", x1nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
#new: in case of wrong data fame
if (length(x1) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x1!")
}
bool = apply(xmat, 2, function(x) all(x1 == x))
if (any(bool)) {
#x1id = obs[bool]
x1nm = xnms[bool]
} else {
stop (paste(paste("'", x1nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
if (all(xnms != x2nm)) {
#stop (paste(paste("'", x2nm0, "'", sep = ''), "is not an exact predictor name defined in the cgam fit!"))
if (length(x2) != nrow(xmat)) {
stop ("Number of observations in the data set is not the same as the number of elements in x2!")
}
bool = apply(xmat, 2, function(x) all(x2 == x))
if (any(bool)) {
#x2id = obs[bool]
x2nm = xnms[bool]
} else {
stop (paste(paste("'", x2nm, "'", sep = ''), "is not a predictor defined in the wps fit!"))
}
}
}
xnm12 = c(x1nm, x2nm)
id_lab = which(xnms %in% xnm12)
xnm12_lab = labels[id_lab]
#new:
xnm_other = xnms[-id_lab]
id1 = id2 = ipr = NULL
if (length(unique(xnm12_lab)) > 1 | length(id_lab) != 2) {
stop ("Two non-parametric predictors do not form a triangle-spline surface!")
} else {
id1 = sort(id_lab)[1]
id2 = sort(id_lab)[2]
ipr = id2 / 2
}
#find the pairs to be plotted
if (x1nm != xnms[1] & x2nm != xnms[2]) {
nm = x1nm
x1nm = x2nm
x2nm = nm
tmp = x1
x1 = x2
x2 = tmp
#new:
xnm12 = c(x1nm, x2nm)
} else {x1nm = x1nm; x2nm = x2nm}
newz = object$newz
npr = round(length(xnms) / 2, 0L)
#zlwr = min(object$lower) - (max(object$fit) - min(object$fit)) / 4
#zupp = max(object$upper) + (max(object$fit) - min(object$fit)) / 4
res = plotpersp.trispl(obj, x1, x2, ngrid = 7, col='white', xlab=xlab, ylab=ylab, zlab=zlab, th=th, ltheta=ltheta, ticktype=ticktype)
newData = as.data.frame(res$gg)
#if (!is.null(newz)) {
# znms = obj$znms
# nz = matrix(0, nrow=nrow(gg), ncol=ncol(newz))
# nznm = gsub("[\\(\\)]", "", regmatches(znms, gregexpr("\\(.*?\\)", znms))[[1]])
# gg = cbind(gg, nz)
# colnames(gg) = c(x1nm, x2nm, nznm)
#} else {
# colnames(gg) = c(x1nm, x2nm)
#}
if (npr > 1) {
new_other = matrix(0, nrow=nrow(newData), ncol=(2*(npr-1)))
kts_other = kts[,-c(ipr*2-1,ipr*2)]
for (i in 1:(npr-1)) {
for (j in 1:2) {
newi = mean(kts_other[,(i-1)*2+j])
new_other[,(i-1)*2+j] = newi
}
}
newd = cbind(newData, new_other)
colnames(newd) = c(xnm12, xnm_other)
newData = as.data.frame(newd)
}
if (length(xnms_add) > 0) {
#new_add = matrix(0, nrow=nrow(newData), ncol=ncol(xmat_add))
means = apply(xmat_add, 2, mean)
new_add = matrix(rep(means, nrow(newData)), ncol=ncol(xmat_add), byrow=T)
nms = colnames(newData)
newd = cbind(newData, new_add)
colnames(newd) = c(nms, xnms_add)
newData = as.data.frame(newd)
}
if (!is.null(newz)) {
znms = obj$znms
nz = matrix(0, nrow=nrow(newData), ncol=ncol(newz))
nznm = gsub("[\\(\\)]", "", regmatches(znms, gregexpr("\\(.*?\\)", znms))[[1]])
nms = colnames(newData)
newData = cbind(newData, nz)
colnames(newData) = c(nms, nznm)
}
gg = newData
pfit.gg = predict.trispl(obj, gg, interval='none')
#upper = pfit.gg$upper
#lower = pfit.gg$lower
xmatpr = pfit.gg$xmatpr
muhat = pfit.gg$fit
lower = muhat - mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
upper = muhat + mult*sqrt(diag(xmatpr%*%acov%*%t(xmatpr)))
#spls = pfit.bb$spls
#ignore z
#spl_use = cbind(1, spls[[ipr]])
#get the fit for each pair
#mus = pfit.knots$mus
#muhat_use = mus[[ipr]]
#get the acov for each pair
#acov_use = acov[c(1, which(varlist == ipr)+np), c(1, which(varlist == ipr)+np)]
#lower = muhat_use - mult*sqrt(diag(spl_use%*%acov_use%*%t(spl_use)))
#upper = muhat_use + mult*sqrt(diag(spl_use%*%acov_use%*%t(spl_use)))
x1g = res$x1g
x2g = res$x2g
k1 = length(x1g)
k2 = length(x2g)
surf = matrix(0, k1, k2)
for(i2 in 1:k2) {
for(i1 in 1:k1) {
if (up) {
surf[i1,i2] = upper[(i2-1)*k1 + i1]
} else {
surf[i1,i2] = lower[(i2-1)*k1 + i1]
}
}
}
#gaussian only
z_add = res$z_add
x3_add = res$x3_add
surf = surf + z_add + x3_add
if (up) {
if (is.null(main)) {
main = "Triangle-Spline Surface with Upper 95% Confidence Surface"
}
}
if (!up) {
if (is.null(main)) {
main = "Triangle-Spline Surface with Lower 95% Confidence Surface"
}
}
par(new = TRUE)
persp(x1g, x2g, surf, zlim = res$zlim, xlab = "", ylab = "", zlab = "", theta = res$theta,
ltheta = res$ltheta, cex.axis = res$cex.axis, main = main, cex.main = cex.main,
ticktype = res$ticktype, col=mycol, box=FALSE, axes=FALSE,...)
par(new=FALSE)
}
#####################################################################################
#### SUBROUTINES
#####################################################################################
### subroutine to determine if point p is inside the triangle formed by a,b,c
intri = function(p, a, b, c) {
if (sameside(p, a, b, c) & sameside(p, b, a, c) & sameside(p, c, a, b)) {
ins = TRUE
} else {ins = FALSE}
ins
}
### subroutine to determine if p1 and p2 are on the same side of the line formed by a,b
sameside = function(p1, p2, a, b) {
cp1 = cpfun(b-a, p1-a)
cp2 = cpfun(b-a, p2-a)
if (cp1 * cp2 >= 0) {ss = TRUE} else {ss = FALSE}
ss
}
## subroutine to find 3rd value of cross product of a and b, where a=(a1,a2,0) and b=(b1,b2,0)
cpfun = function(a, b) {
c = a[1] * b[2] - a[2] * b[1]
c
}
###########
#prop odds#
###########
cgam.polr <- function(formula, data = NULL, weights = NULL, family = NULL, nsim = 0, cpar = 1.2)
{
cl <- match.call()
mf <- match.call(expand.dots = FALSE)
m <- match(c("formula", "data"), names(mf), 0L)
mf <- mf[c(1L, m)]
#print (mf)
mf[[1L]] <- as.name("model.frame")
#print (class(eval.parent(mf$data)))
#if(is.matrix(eval.parent(mf$data))) {
# mf$data <- as.data.frame(data)
#} else {mf$data <- data}
mf <- eval(mf, parent.frame())
ynm <- names(mf)[1]
mt <- attr(mf, "terms")
y <- model.response(mf, "any")
shapes1 <- NULL; shapes2 <- NULL
xmat <- NULL; xnms <- NULL
nums <- NULL; ks <- list(); sps <- NULL; xid <- 1
zmat <- NULL; zid <- NULL; zid0 <- NULL; zid1 <- NULL; zid2 <- NULL; znms <- NULL; is_param <- NULL; is_fac <- NULL; vals <- NULL; st <- 1; ed <- 1
ztb <- list(); iztb <- 1
pl <- NULL
tree.delta <- NULL
tid1 <- NULL; tid2 <- NULL; tpos2 <- 0
tr <- NULL
umbrella.delta <- NULL
uid1 <- NULL; uid2 <- NULL; upos2 <- 0
umb <- NULL
for (i in 2:ncol(mf)) {
if (is.numeric(attributes(mf[,i])$shape)) {
shapes1 <- c(shapes1, attributes(mf[,i])$shape)
xmat <- cbind(xmat, mf[,i])
xnms <- c(xnms, attributes(mf[,i])$nm)
nums <- c(nums, attributes(mf[,i])$numknots)
sps <- c(sps, attributes(mf[,i])$space)
ks[[xid]] <- attributes(mf[,i])$knots
xid <- xid + 1
}
if (is.character(attributes(mf[,i])$shape)) {
shapes2 <- c(shapes2, attributes(mf[,i])$shape)
if (attributes(mf[,i])$shape == "tree") {
pl <- c(pl, attributes(mf[,i])$pl)
treei <- tree.fun(mf[,i], attributes(mf[,i])$pl)
tree.delta <- rbind(tree.delta, treei)
tpos1 <- tpos2 + 1
tpos2 <- tpos2 + nrow(treei)
tid1 <- c(tid1, tpos1)
tid2 <- c(tid2, tpos2)
tr <- cbind(tr, mf[,i])
}
if (attributes(mf[,i])$shape == "umbrella") {
umbi <- umbrella.fun(mf[,i])
umbrella.delta <- rbind(umbrella.delta, umbi)
upos1 <- upos2 + 1
upos2 <- upos2 + nrow(umbi)
uid1 <- c(uid1, upos1)
uid2 <- c(uid2, upos2)
umb <- cbind(umb, mf[,i])
}
}
if (is.null(attributes(mf[, i])$shape)) {
if (!is.null(names(mf)[i])) {
znms <- c(znms, names(mf)[i])
}
if (!is.matrix(mf[, i])) {
zid <- c(zid, i)
is_param <- c(is_param, TRUE)
if (is.factor(mf[, i])) {
is_fac <- c(is_fac, TRUE)
ch_char <- suppressWarnings(is.na(as.numeric(levels(mf[, i]))))
if (any(ch_char)) {
vals <- c(vals, unique(levels(mf[, i]))[-1])
} else {
vals <- c(vals, as.numeric(levels(mf[, i]))[-1])
}
nlvs <- length(attributes(mf[, i])$levels)
ed <- st + nlvs - 2
zid1 <- c(zid1, st)
zid2 <- c(zid2, ed)
st <- st + nlvs - 1
zmat0 <- model.matrix(~ mf[, i])[, -1, drop = FALSE]
zmat <- cbind(zmat, zmat0)
} else {
is_fac <- c(is_fac, FALSE)
zmat <- cbind(zmat, mf[, i])
ed <- st
zid1 <- c(zid1, st)
zid2 <- c(zid2, ed)
st <- st + 1
vals <- c(vals, "")
}
} else {
is_param <- c(is_param, FALSE)
is_fac <- c(is_fac, FALSE)
zmat0 <- mf[, i]
zmat <- cbind(zmat, zmat0)
zid <- c(zid, i)
nlvs <- ncol(zmat0) + 1
ed <- st + nlvs - 2
zid1 <- c(zid1, st)
zid2 <- c(zid2, ed)
st <- st + nlvs - 1
}
}
}
dimnames(zmat)[[2]] <- NULL
xmat0 <- xmat; shapes0 <- shapes1; nums0 <- nums; ks0 <- ks; sps0 <- sps; xnms0 <- xnms; idx_s <- NULL; idx <- NULL
if (any(shapes1 == 17)) {
kshapes <- length(shapes1)
obs <- 1:kshapes
idx_s <- obs[which(shapes1 == 17)]; idx <- obs[which(shapes1 != 17)]
xmat0[ ,1:length(idx_s)] <- xmat[ ,idx_s]
shapes0[1:length(idx_s)] <- shapes1[idx_s]
nums0[1:length(idx_s)] <- nums[idx_s]
sps0[1:length(idx_s)] <- sps[idx_s]
ks0[1:length(idx_s)] <- ks[idx_s]
xnms0[1:length(idx_s)] <- xnms[idx_s]
if (length(idx) > 0) {
xmat0[ ,(1 + length(idx_s)):kshapes] <- xmat[ ,idx]
shapes0[(1 + length(idx_s)):kshapes] <- shapes1[idx]
nums0[(1 + length(idx_s)):kshapes] <- nums[idx]
sps0[(1 + length(idx_s)):kshapes] <- sps[idx]
ks0[(1 + length(idx_s)):kshapes] <- ks[idx]
xnms0[(1 +length(idx_s)):kshapes] <- xnms[idx]
}
#xmat <- xmat0; nums <- nums0; ks <- ks0; sps <- sps0; xnms <- xnms0
}
ans <- cgam.polr.fit(y, xmat0, zmat, umbrella.delta = umbrella.delta, tree.delta = tree.delta, shapes = shapes1, nums0, ks0, sps0, family, idx_s, idx, nsim, cpar, weights)
rslt <- list(muhat = ans$muhat, zeta = ans$ac, wta = ans$wta, lev = ans$lev, vcoefs = ans$vcoefs, xcoefs = ans$xcoefs, zcoefs = ans$zcoefs, coefs = ans$coefs, ucoefs = ans$ucoefs, tcoefs = ans$tcoefs, cic = ans$cic, d0 = ans$d0, edf0 = NULL, etacomps = ans$etacomps, xmat = xmat, zmat = zmat, ztb = ztb, tr = tr, umb = umb, tree.delta = tree.delta, umbrella.delta = umbrella.delta, bigmat = ans$bigmat, shapes = shapes1, shapesx = shapes1, wt = ans$wt, wt.iter = TRUE, family = family, SSE0 = NULL, SSE1 = NULL, pvals.beta = NULL, se.beta = NULL, df.null = ans$df.null, df = ans$df, df.residual = ans$df.residual, null.deviance = ans$dev.null, deviance = ans$dev, tms = mt, capm = ans$capm, capms = ans$capms, capk = ans$capk, capt = ans$capt, capu = ans$capu, xid1 = ans$xid1, xid2 = ans$xid2, tid1 = tid1, tid2 = tid2, uid1 = uid1, uid2 = uid2, zid = zid, vals = vals, zid1 = zid1, zid2 = zid2, nsim = nsim, xnms = xnms, ynm = ynm, znms = znms, is_param = is_param, is_fac = is_fac, knots = ans$knots, numknots = ans$numknots, sps = sps, ms = NULL, cpar = cpar, pl = pl, idx_s = idx_s, idx = idx, xmat0 = ans$xmat2, knots0 = ans$knots2, numknots0 = ans$numknots2, sps0 = ans$sps2, ms0 = ans$ms2)
rslt$call <- cl
class(rslt) <- "cgam.polr"
return (rslt)
}
#
cgam.polr.fit = function(y = NULL, xmat = NULL, zmat = NULL, umbrella.delta = NULL, tree.delta = NULL, shapes = NULL, numknots = NULL, knots = NULL, space = NULL, family = NULL, idx_s = NULL, idx = NULL, nsim = 0, cpar = 1.2, weights = NULL) {
fmin = function(a) {
nc = length(a) + 1
y_id = t(col(matrix(0, length(y), nc)) == y)
llh = 0
for (i in 1:nc) {
if (i == 1) {
llhi = sum(w * y_id[i,] * log(pfun(a[1] - eta)))
} else if (i == nc) {
llhi = sum(w * y_id[i,] * log(1 - pfun(a[nc-1] - eta)))
} else {
llhi = sum(w * y_id[i,] * log(pfun(a[i] - eta) - pfun(a[i-1] - eta)))
}
llh = llh + llhi
}
-2*llh
}
gmin = function(a) {
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == y)
gr = NULL
for (i in 1:(nc-1)) {
if (i == 1) {
gri = -sum(y_id[1,] * w * (1 - pfun(a[1] - eta))) + sum(y_id[2,] * w * dfun(a[1] - eta) / (pfun(a[2] - eta) - pfun(a[1] - eta)))
} else if (i == (nc-1)) {
gri = -sum(y_id[nc-1,] * w * dfun(a[nc-1] - eta) / (pfun(a[nc-1] - eta) - pfun(a[nc-2] - eta))) + sum(I(y == nc) * w * dfun(a[nc-1] - eta) / (1 - pfun(a[nc-1] - eta)))
#gri = -sum(y_id[nc-1,id] * w[id] * dfun(a[nc-1] - eta[id]) / (pfun(a[nc-1] - eta[id]) - pfun(a[nc-2] - eta[id]))) + sum(y_id[nc,id] * w[id] * dfun(a[nc-1] - eta[id]) / (1 - pfun(a[nc-1] - eta[id])))
} else {
gri = -sum(y_id[i,] * w * dfun(a[i] - eta) / (pfun(a[i] - eta) - pfun(a[i-1] - eta))) + sum(y_id[i+1,] * w * dfun(a[i] - eta) / (pfun(a[i+1] - eta) - pfun(a[i] - eta)))
}
gr = c(gr, gri)
}
return (gr)
}
if (is.factor(y)) {
lev = levels(y)
y = unclass(y)
} else {
lev = attributes(factor(y))$levels
}
n = length(y)
w = weights
if(is.null(w)) {
w = rep(1, n)
}
sc_x = FALSE
capl = length(xmat) / n
#print (dim(xmat))
if (capl < 1) {capl = 0}
if (round(capl, 8) != round(capl, 1)) {stop ("Incompatible dimensions for xmat!")}
if (capl > 0 & sc_x) {
for (i in 1:capl) {xmat[,i] = (xmat[,i] - min(xmat[,i])) / (max(xmat[,i]) - min(xmat[,i]))}
}
capk = length(zmat) / n
#print (capk)
if (capk < 1) {capk = 0}
if (round(capk, 8) != round(capk, 1)) {stop ("Incompatible dimensions for zmat!")}
#smooth only
#if (!is.null(shapes)) {
capls = sum(shapes == 17)
#} else {capls = 0}
bigmat = NULL; delta = NULL
varlist = NULL
xid1 = NULL; xid2 = NULL; xpos2 = 0
knotsuse = list(); numknotsuse = NULL
mslst = list()
capm = 0
capms = 0
if (capl - capls > 0) {
#print (class(xmat[,1]))
#print (head(xmat))
del1_ans = makedelta(xmat[, 1], shapes[1], numknots[1], knots[[1]], space = space[1], interp=T)
#del1_ans = makedelta(xmat[, 1], shapes[1])
del1 = del1_ans$amat
knotsuse[[1]] = del1_ans$knots
mslst[[1]] = del1_ans$ms
numknotsuse = c(numknotsuse, length(del1_ans$knots))
m1 = length(del1) / n
#new code: record the number of columns of del1 if shapes0[1] == 17:
if (shapes[1] == 17) {capms = capms + m1}
var1 = 1:m1*0 + 1
xpos1 = xpos2 + 1
xpos2 = xpos2 + m1
xid1 = c(xid1, xpos1)
xid2 = c(xid2, xpos2)
if (capl == 1) {
delta = del1
varlist = var1
} else {
for (i in 2:capl) {
#new code:
del2_ans = makedelta(xmat[,i], shapes[i], numknots[i], knots[[i]], space = space[i], interp=T)
#del2_ans = makedelta(xmat[,i], shapes[i])
del2 = del2_ans$amat
knotsuse[[i]] = del2_ans$knots
mslst[[i]] = del2_ans$ms
numknotsuse = c(numknotsuse, length(del2_ans$knots))
m2 = length(del2) / n
#new code: record the number of columns of del2 if shapes0[i] == 17:
if (shapes[i] == 17) {capms = capms + m2}
xpos1 = xpos2 + 1
xpos2 = xpos2 + m2
xid1 = c(xid1, xpos1)
xid2 = c(xid2, xpos2)
delta = rbind(del1, del2)
varlist = 1:(m1 + m2)*0
varlist[1:m1] = var1
varlist[(m1 + 1):(m1 + m2)] = (1:m2)*0 + i
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
np = 0
if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0 & capk > 0) {
bigmat = rbind(t(zmat), t(xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13]), delta)
np = capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0 & capk == 0) {
bigmat = rbind(t(xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13]), delta)
np = sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0 & capk > 0) {
bigmat = rbind(t(zmat), delta)
np = capk + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0 & capk == 0) {
bigmat = delta
np = capms
} else {
print ("error in capk, shapes!")
}
#new:
capm = length(delta) / n - capms
} else {
if (capk + capls > 0) {
#new:
if (capls < 1 & capk > 0) {
#bigmat = rbind(1:n*0 + 1, t(zmat))
bigmat = t(zmat)
#np = 1 + capk
np = capk
} else if (capls > 0) {
delta = NULL; varlist = NULL
del1_ans = makedelta(xmat[,1], 17, numknots[1], knots[[1]], space = space[1], interp=T)
#del1_ans = makedelta(xmat[,i], 9)
del1 = del1_ans$amat
knotsuse[[1]] = del1_ans$knots
mslst[[1]] = del1_ans$ms
numknotsuse = c(numknotsuse, length(del1_ans$knots))
m1 = length(del1) / n
var1 = 1:m1*0 + 1
xpos1 = xpos2 + 1
xpos2 = xpos2 + m1
xid1 = c(xid1, xpos1)
xid2 = c(xid2, xpos2)
if (capls == 1) {
delta = del1
varlist = var1
} else {
for (i in 2:capls) {
del2_ans = makedelta(xmat[,i], 17, numknots[i], knots[[i]], space = space[i], interp=T)
#del2_ans = makedelta(xmat[,i], 9)
del2 = del2_ans$amat
knotsuse[[i]] = del2_ans$knots
mslst[[i]] = del2_ans$ms
numknotsuse = c(numknotsuse, length(del2_ans$knots))
m2 = length(del2) / n
xpos1 = xpos2 + 1
xpos2 = xpos2 + m2
xid1 = c(xid1, xpos1)
xid2 = c(xid2, xpos2)
delta = rbind(del1, del2)
varlist = 1:(m1 + m2)*0
varlist[1:m1] = var1
varlist[(m1 + 1):(m1 + m2)] = (1:m2)*0 + i
var1 = varlist
m1 = m1 + m2
del1 = delta
}
}
if (capk < 1){
#bigmat = rbind(1:n*0 + 1, delta)
bigmat = delta
capms = length(delta) / n
#np = 1 + capms
np = capms
} else {
#bigmat = rbind(1:n*0 + 1, t(zmat), delta)
bigmat = rbind(t(zmat), delta)
capms = length(delta) / n
#np = 1 + capk + capms
np = capk + capms
}
}
} else {bigmat = NULL; capm = 0; capms = 0; np = 0}
}
#print (head(zmat))
#print (head(t(bigmat)))
#new:
if (!is.null(umbrella.delta)) {
bigmat <- rbind(bigmat, umbrella.delta)
capu <- length(umbrella.delta) / n
} else {capu <- 0}
if (!is.null(tree.delta)) {
bigmat <- rbind(bigmat, tree.delta)
capt <- length(tree.delta) / n
} else {capt <- 0}
if (!is.null(umbrella.delta) | !is.null(tree.delta))
delta_ut <- rbind(umbrella.delta, tree.delta)
#coneB:
#n = length(y)
nc = length(unique(y)) - 1
#lev = attributes(factor(y))$levels
#initialize a
if (all(w == 1)) {
a = sapply(1:nc, function(ct) log(sum(y <= ct) / (n - sum(y <= ct))))
} else {
#a = sapply(1:nc, function(ct) log(w * sum(y <= ct) / (n - sum(y <= ct))))
a = 1:nc*0
for (i in 1:nc) {
#idi = which(y <= i)
a[i] = log(sum((y <= i)* w) / (sum(w) - sum((y <= i)* w)))
}
}
gr = 1:n*0
wt = 1:n*0
eta = 1:n*0
diff = 100
nrep = 0
olddev = 100
oldmu = 1:n*0+1
face = NULL
while(diff > 1e-8 & nrep < 400){
nrep = nrep+1
#eta step:
gr = fgr(a, y, eta, w)
wt = fwt(a, y, eta, w)
q0 = diag(as.vector(wt))
cvec = wt * eta - gr
zvec = 1:n*0
zvec[wt == 0] = 1 / 1e-4
zvec[wt > 0] = cvec[wt > 0] / sqrt(wt[wt > 0])
gmat = t(bigmat)
for (j in 1:n) {gmat[j,] = bigmat[,j] * sqrt(wt[j])}
if (np > 0) {
zsend = gmat[, 1:np]
if ((capm + capt + capu) > 0) {
dsend = t(gmat[, (np+1):(nrow(bigmat))])
} else {dsend = NULL}
} else {
dsend = t(gmat)
zsend = NULL
}
if ((capm + capt + capu) > 0) {
#ans = coneB(zvec, dsend, vmat = zsend)
if (nrep > 1) {
ans = coneB(zvec, t(dsend), vmat = zsend, face = face)
} else {
ans = coneB(zvec, t(dsend), vmat = zsend)
face = ans$face
}
#ans = coneB(zvec, t(dsend))
bh = coef(ans)
} else {
bh = solve(t(zsend) %*% zsend, t(zsend) %*% zvec)
}
eta = t(bigmat) %*% bh
#a step:
#res = optim(a, fmin, gr = gmin, hessian = TRUE)
#a = res$par
gr_a = fgr_a(a, y, eta, w)
wt_a = fwt_a(a, y, eta, w)
qmat_a = wt_a
a = a - solve(qmat_a, gr_a)
#a = atil + bh[1]
#if (a[1] >= a[2]) {
if (any(a != sort(a))) {
print ('a wrong!')
break
}
#dev = res$value
#diff = (dev-olddev)^2
#olddev = dev
mu = predict_polr(a, eta)$mu
diff = mean((mu-oldmu)^2)
oldmu = mu
}
names(a) = paste(lev[-length(lev)], lev[-1L], sep="|")
#print (diff)
yhat = eta
coefskeep = bh
#df_obs = sum(abs(coefskeep) > 0) + length(a)
#print (coefskeep)
########################
#if capk > 0, we have:#
########################
zcoefs = NULL
if (capk > 0) {
zcoefs = coefskeep[1:capk]
}
#print (zcoefs)
vcoefs = NULL
if (np > 0) {
vcoefs = coefskeep[1:np]
}
#######################
#if capm > 0, we have:#
#######################
xcoefs = NULL
#new:
if (capl > 0) {
xcoefs = coefskeep[(np - capms + 1):(np + capm)]
}
#######################
#if capu > 0, we have:#
#######################
ucoefs = NULL
if (capu > 0) {
ucoefs = coefskeep[(np + 1 + capm):(np + capm + capu)]
}
#######################
#if capt > 0, we have:#
#######################
tcoefs = NULL
if (capt > 0) {
tcoefs =
coefskeep[(np + 1 + capm + capu):(np + capm + capu + capt)]
}
#########################################################
#if we have at least one constrained predictor, we have:#
#########################################################
thvecs = NULL
if (capl > 0) {
#new code:
dcoefs = coefskeep[(np - capms + 1):(np + capm)]
#####################################################
#thvecs is f(x), where x has one of the eight shapes#
#####################################################
thvecs = matrix(0, nrow = capl, ncol = n)
ncon = 1
for (i in 1:capl) {
thvecs[i,] = t(delta[varlist == i,]) %*% dcoefs[varlist == i]
if (shapes[i] > 2 & shapes[i] < 5 | shapes[i] > 10 & shapes[i] < 13) {
ncon = ncon + 1
thvecs[i,] = thvecs[i,] + vcoefs[capk + ncon] * xmat[,i]
}
}
}
#new:order thvecs back
#if (!is.null(idx_s)) {
if (length(idx_s) > 0) {
thvecs0 = thvecs
thvecs0[idx_s,] = thvecs[1:length(idx_s), ]
#if (!is.null(idx)) {
if (length(idx) > 0) {
thvecs0[idx,] = thvecs[(1+length(idx_s)):capl, ]
}
thvecs = thvecs0
}
thvecs_ut = NULL
if (capu + capt > 0) {
thvecs_ut = t(delta_ut) %*% coefskeep[(np + 1 + capm):(np + capm + capu + capt)]
}
if (!is.null(thvecs_ut)) {
thvecs = rbind(thvecs, t(thvecs_ut))
}
etakeep = eta
muhatkeep = eta
df_obs = sum(abs(coefskeep) > 0) + length(a)
#deviance
dev = dev_fun(y, a = a, eta = eta, flat = FALSE, w = w)
#print (dev)
llh = dev/n
#null deviance
dev.null = dev_fun(y, a = a, eta = eta, flat = TRUE, w = w)
#print (dev.null)
cic = NULL
dfmean = 0
if (nsim > 0) {
if (capm + capms > 0) {
dfs = 1:nsim*0
for (isim in 1:nsim) {
#print (isim)
ysti = rlogis(n, scale = 1)
#print (nc)
cts = quantile(ysti, probs = seq(0, 1, length = (nc+2)))
#print (cts)
yordi = cut(ysti, breaks=cts, include.lowest = TRUE, labels = c(1:(nc+1)), ordered = TRUE)
ysim = as.numeric(levels(yordi))[yordi]
edfi = polr_getedf(ysim, bigmat, np, capm, shapes, w)
#dfs[isim] = sum(abs(bhi) > 0)
dfs[isim] = edfi
}
if (any(shapes == 11) | any(shapes == 12)) {
dfmean = mean(dfs) - sum(shapes > 10 & shapes < 13)
} else {dfmean = mean(dfs)}
} else {dfmean = 0}
#cic = llh + log(1 + 2 * (dfmean + np) / (n - np - cpar * dfmean))
#check! length(a)?
if ((n - np - 1.5 * (dfmean - np)) <= 0) {
cic = llh + log(1 + 2 * dfmean / (dfmean - np))
} else {
cic = llh + log(1 + 2 * dfmean / (n - np - 1.5 * (dfmean - np)))
}
}
#print (cic)
env = new.env()
#tm=proc.time()-tm0
#env$tm=tm
env$dev=dev
env$dev.null=dev.null
#print (lev)
env$lev=lev
env$etacomps=thvecs
env$zcoefs=zcoefs
env$ac=a
env$etahat=eta
env$muhat=eta
env$vcoefs=vcoefs
env$xcoefs=xcoefs
env$zcoefs=zcoefs
env$ucoefs=ucoefs
env$tcoefs=tcoefs
env$coefs=coefskeep
env$cic=cic
env$d0=np
env$capm = capm
env$capms = capms
env$capk = capk
env$capu = capu
env$capt = capt
env$edf=df_obs
env$edf0=dfmean
env$bigmat=bigmat
#env$family=family
env$sse0=NULL
env$sse1=NULL
env$pvals.beta=NULL
env$se.beta=NULL
env$wt=wt
env$gr=gr
env$mu=mu
env$oldmu=oldmu
env$diff=diff
env$bh=bh
env$thvecs=thvecs
#gr_a=NULL
env$gra=gr_a
env$wta=wt_a
knotsuse2=knotsuse
numknotsuse2=numknotsuse
mslst2=mslst
xmat2=xmat
#if (!is.null(idx_s)) {
if (length(idx_s) > 0) {
knotsuse0 = knotsuse
numknotsuse0 = numknotsuse
mslst0 = mslst
knotsuse0[idx_s] = knotsuse[1:length(idx_s)]
numknotsuse0[idx_s] = numknotsuse[1:length(idx_s)]
mslst0[idx_s] = mslst[1:length(idx_s)]
#if (!is.null(idx)) {
if (length(idx) > 0) {
knotsuse0[idx] = knotsuse[(1+length(idx_s)):capl]
numknotsuse0[idx] = numknotsuse[(1+length(idx_s)):capl]
mslst0[idx] = mslst[(1+length(idx_s)):capl]
}
knotsuse = knotsuse0
numknotsuse = numknotsuse0
mslst = mslst0
}
env$knots = knotsuse
env$numknots = numknotsuse
env$xid1 = xid1
env$xid2 = xid2
env$xmat2 = xmat2
env$knotsuse2 = knotsuse2
env$numknotsuse2 = numknotsuse2
env$df = n - length(a)
env$df.null = n - length(a)
env$df.residual = n - cpar * df_obs
#env$df.residual = n - np - length(a) - cpar * df_obs
#env$sps2 = sps2
#env$ms2 = ms2
return(env)
}
###################
#summary.cgam.polr#
###################
summary.cgam.polr = function(object,...) {
coefs = object$zcoefs
n = length(coefs)
zid = object$zid
zid1 = object$zid1
zid2 = object$zid2
tms = object$tms
is_param = object$is_param
is_fac = object$is_fac
vals = object$vals
zeta = object$zeta
hess = object$wta
pc = length(zeta)
np = object$d0
df_obs = object$df_obs
cpar = object$cpar
#pvals = object$pvals
#if ((n - np - cpar * df_obs) <= 0) {
# pvals.beta[i] <- 2 * (1 - pt(abs(tstat[i]), df_obs))
# warning ('Effective degrees of freedom is close to the number of observations! Inference about parametric covariates is not reliable!')
#} else {
# pvals.beta[i] <- 2 * (1 - pt(abs(tstat[i]), n - np - cpar * df_obs))
#}
if (length(coefs) >= 1) {
rslt1 = data.frame("Estimate" = round(coefs, 4))
#rownames(rslt1)[1] <- "(Intercept)"
if (n >= 1) {
lzid = length(zid1)
for (i in 1:lzid) {
pos1 = zid1[i]
pos2 = zid2[i]
for (j in pos1:pos2) {
if (!is_param[i]) {
rownames(rslt1)[j] = paste(attributes(tms)$term.labels[zid[i] - 1], rownames(rslt1)[j], sep = "")
} else {
rownames(rslt1)[j] = paste(attributes(tms)$term.labels[zid[i] - 1], vals[j], sep = "")
}
}
}
}
rslt1 = as.matrix(rslt1)
} else {rslt1 = NULL}
rslt = matrix(0, pc, 3L, dimnames = list(names(zeta), c("Estimate", "StdErr", "t.value")))#"p.value"
rslt[, 1L] = round(zeta, 4)
hess = object$wta
covmat = solve(hess)
rslt[, 2L] = round(sqrt(diag(covmat)), 4)
rslt[, 3L] = round(rslt[, 1L]/rslt[, 2L], 4)
#tstat = rslt[, 3L]
#pvals = 2 * (1 - pt(abs(tstat), n - np - pc - cpar * (nzeta+df_obs)))
#rslt[, 4L] = pvals
#object$coefficients = coefs
#object$pc = pc
#if(correlation)
# object$correlation <- (vc/sd)/rep(sd, rep(pc+q, pc+q))
ans = list(call = object$call, coefficients = rslt, cic = object$cic, pc=pc, deviance=object$deviance, df.residual=object$df.residual, rslt1 = rslt1)
class(ans) = "summary.cgam.polr"
return (ans)
}
#########################
#print.summary.cgam.polr#
#########################
print.summary.cgam.polr = function(x,...) {
#rslt = x$coefficients
#pc = x$pc
#if(pc > 0) {
# cat("\nCoefficients:\n")
# print(x$coefficients[seq_len(pc), , drop=FALSE], quote = FALSE,
# digits = digits, ...)
#} else {
# cat("\nNo coefficients\n")
#}
cat("Call:\n")
print(x$call)
if (!is.null(x$rslt1)) {
cat("\n")
cat("Coefficients:")
cat("\n")
print (x$rslt1)
}
cat("\nIntercepts:\n")
#print(rslt[(pc+1L):nrow(rslt), , drop=FALSE], quote = FALSE)
printCoefmat(x$coefficients, P.values = FALSE, has.Pvalue = FALSE)
#cat("\nResidual Deviance:", format(x$deviance, nsmall=2L), "\n")
cat("\nResidual deviance: ", round(x$deviance, 4), " ", "on ", x$df.residual, " ", "observed degrees of freedom", sep="", "\n")
if (!is.null(x$cic)) {
cat("CIC:", format(x$cic), "\n")
}
#if(nzchar(mess <- naprint(x$na.action))) cat("(", mess, ")\n", sep="")
#if(!is.null(correl <- x$correlation)) {
# cat("\nCorrelation of Coefficients:\n")
# ll <- lower.tri(correl)
# correl[ll] <- format(round(correl[ll], digits))
# correl[!ll] <- ""
# print(correl[-1L, -ncol(correl)], quote = FALSE, ...)
#}
invisible(x)
}
dev_fun = function(y, a = NULL, eta = NULL, flat = TRUE, w = NULL) {
n = length(y)
if (is.null(w)) {
w = rep(1, n)
}
if (flat) {
eta = rep(0, n)
luy = length(unique(y))-1
if (all(w == 1)) {
a = sapply(1:luy, function(ct) log(sum(y <= ct)/(n-sum(y <= ct))))
} else {
a = 1:luy*0
for (i in 1:luy) {
a[i] = log(sum((y <= i)* w) / (sum(w) - sum((y <= i)* w)))
}
}
}
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == y)
llh = 0
for (i in 1:nc) {
if (i == 1) {
llhi = sum(w * y_id[i,] * log(pfun(a[1] - eta)))
} else if (i == nc) {
llhi = sum(w * y_id[i,] * log(1 - pfun(a[nc-1] - eta)))
} else {
llhi = sum(w * y_id[i,] * log(pfun(a[i] - eta) - pfun(a[i-1] - eta)))
}
llh = llh + llhi
}
#llh = -2/n*llh
dev = -2*llh
return (dev)
}
##
predict_polr = function(a, eta) {
nc = length(a) + 1
n = length(eta)
ps = matrix(0, nrow = nc, ncol = n)
cums = matrix(0, nrow = nc, ncol = n)
for (i in 1:nc) {
if (i == 1) {
ps[i,] = pfun(a[1] - eta)
#cums[, i] = ps[, i]
} else if (i == nc) {
ps[i,] = 1 - pfun(a[nc-1] - eta)
} else {
ps[i,] = pfun(a[i] - eta) - pfun(a[i-1] - eta)
#cums[, i] = ps[, i] + ps[, i-1]
}
}
cums = apply(ps, 2, cumsum)
rhs = a[nc-1] - eta
mu = exp(rhs) / (1 + exp(rhs))
rslt = new.env()
rslt$ps = ps
rslt$mu = mu
rslt$cums = cums
return (rslt)
}
polr_getedf = function(ysim, bigmat, np, capm, shapes, w = NULL) {
fmin = function(a) {
nc = length(a) + 1
y_id = t(col(matrix(0, length(ysim), nc)) == ysim)
llh = 0
for (i in 1:nc) {
if (i == 1) {
llhi = sum(w * y_id[i,] * log(pfun(a[1] - eta)))
} else if (i == nc) {
llhi = sum(w * y_id[i,] * log(1 - pfun(a[nc-1] - eta)))
} else {
llhi = sum(w * y_id[i,] * log(pfun(a[i] - eta) - pfun(a[i-1] - eta)))
}
llh = llh + llhi
}
-2*llh
}
gmin = function(a) {
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == ysim)
gr = NULL
for (i in 1:(nc-1)) {
if (i == 1) {
gri = -sum(y_id[1,] * w * (1 - pfun(a[1] - eta))) + sum(y_id[2,] * w * dfun(a[1] - eta) / (pfun(a[2] - eta) - pfun(a[1] - eta)))
} else if (i == (nc-1)) {
gri = -sum(y_id[nc-1,] * w * dfun(a[nc-1] - eta) / (pfun(a[nc-1] - eta) - pfun(a[nc-2] - eta))) + sum(I(ysim == nc) * w * dfun(a[nc-1] - eta) / (1 - pfun(a[nc-1] - eta)))
#gri = -sum(y_id[nc-1,id] * w[id] * dfun(a[nc-1] - eta[id]) / (pfun(a[nc-1] - eta[id]) - pfun(a[nc-2] - eta[id]))) + sum(y_id[nc,id] * w[id] * dfun(a[nc-1] - eta[id]) / (1 - pfun(a[nc-1] - eta[id])))
} else {
gri = -sum(y_id[i,] * w * dfun(a[i] - eta) / (pfun(a[i] - eta) - pfun(a[i-1] - eta))) + sum(y_id[i+1,] * w * dfun(a[i] - eta) / (pfun(a[i+1] - eta) - pfun(a[i] - eta)))
}
gr = c(gr, gri)
}
return (gr)
}
nc = length(unique(ysim)) - 1
n = length(ysim)
if (is.null(w)) {
w = rep(1, n)
}
if (all(w == 1)) {
a = sapply(1:nc, function(ct) log(sum(ysim <= ct) / (n - sum(ysim <= ct))))
} else {
a = 1:nc*0
for (i in 1:nc) {
a[i] = log(sum((ysim <= i)* w) / (sum(w) - sum((ysim <= i)* w)))
}
}
gr = 1:n*0
wt = 1:n*0
eta = 1:n*0
diff = 100
nrep = 0
oldmu = 1:n*0+1
face = NULL
while(diff > 1e-8 & nrep < 400){
nrep = nrep+1
#eta step:
gr = fgr(a, ysim, eta, w)
wt = fwt(a, ysim, eta, w)
q0 = diag(as.vector(wt))
cvec = wt * eta - gr
zvec = 1:n*0
zvec[wt == 0] = 1 / 1e-4
zvec[wt > 0] = cvec[wt > 0] / sqrt(wt[wt > 0])
gmat = t(bigmat)
for (j in 1:n) {gmat[j,] = bigmat[,j] * sqrt(wt[j])}
if (np > 0) {
zsend = gmat[, 1:np]
if (capm > 0) {
dsend = t(gmat[, (np+1):(nrow(bigmat))])
} else {dsend = NULL}
} else {
dsend = t(gmat)
zsend = NULL
}
#print (dsend)
if (capm > 0) {
#ans = coneB(zvec, dsend, vmat = zsend)
if (nrep > 1) {
ans = coneB(zvec, t(dsend), vmat = zsend, face = face)
} else {
ans = coneB(zvec, t(dsend), vmat = zsend)
face = ans$face
}
bh = coef(ans)
} else {
bh = solve(t(zsend) %*% zsend, t(zsend) %*% zvec)
}
#print (bh)
eta = t(bigmat) %*% bh
#a step:
#res = optim(a, fmin, gr = gmin)
#a = res$par
#print (a)
gr_a = fgr_a(a, ysim, eta, w)
wt_a = fwt_a(a, ysim, eta, w)
qmat_a = wt_a
a = a - solve(qmat_a, gr_a)
#a = atil + bh[1]
#if (a[1] >= a[2]) {
if (any(a != sort(a))) {
print ('a wrong!')
break
}
mu = predict_polr(a, eta)$mu
diff = mean((mu-oldmu)^2)
oldmu = mu
}
edf = sum(abs(bh) > 0)
return (edf)
}
#big phi
pfun = function(x, sc = 1) {
if (sc == 1) {
#return (exp(x) / (1 + exp(x)))
return (1 - 1 / (1 + exp(x)))
} else {
xtil = x / sc
return (exp(xtil) / (1 + exp(xtil)))
}
}
#small phi
dfun = function(x, sc = 1) {
#d1 = exp(x) / (1 + exp(x))
d1 = 1 - 1 / (1 + exp(x))
d2 = 1 / (1 + exp(x))
if (sc == 1) {
#print (range(d1*d2))
return (d1 * d2)
} else {
xtil = x / sc
d1 = exp(xtil) / (1 + exp(xtil))
d2 = 1 / (1 + exp(xtil))
return (1 / sc * d1 * d2)
}
}
#derivative of small phi
ddfun = function(x, sc = 1) {
if (sc == 1) {
#dd = dfun(x) * (1 - exp(x)) / (1 + exp(x))
dd = dfun(x) * (2 / (1 + exp(x)) - 1)
return (dd)
} else {
xtil = x / sc
dd = 1 / sc * dfun(xtil, sc = sc) * (1 - exp(xtil)) / (1 + exp(xtil))
return (dd)
}
}
#k = 4: gr w.r.t eta
fgr = function(a, y, eta, w = NULL) {
n = length(y)
if (is.null(w)) {
w = rep(1, n)
}
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == y)
gr = 1:n*0
for (i in 1:nc) {
if (i == 1) {
gri = y_id[i,] * (1 - pfun(a[1] - eta)) * w
} else if (i == nc) {
gri = -y_id[i,] * (pfun(a[nc-1] - eta)) * w
} else {
gri = y_id[i,] * (1 - pfun(a[i-1] - eta) - pfun(a[i] - eta)) * w
}
gr = gr + gri
}
gr = round(gr, 6)
return (gr)
}
#k = 4: Hess w.r.t eta
fwt = function(a, y, eta, w = NULL) {
n = length(y)
if (is.null(w)) {
w = rep(1, n)
}
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == y)
wt = 1:n*0
for (i in 1:nc) {
if (i == 1) {
wti = y_id[i,] * dfun(a[1] - eta) * w
} else if (i == nc) {
wti = y_id[i,] * dfun(a[nc-1] - eta) * w
} else {
wti = y_id[i,] * (dfun(a[i-1] - eta) + dfun(a[i] - eta)) * w
}
wt = wt + wti
}
wt = round(wt, 6)
return (wt)
}
#k = 4: gr w.r.t a1, a2, a3
fgr_a = function(a, y, eta, w = NULL) {
n = length(y)
if (is.null(w)) {
w = rep(1, n)
}
gr = NULL
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == y)
for (i in 1:(nc-1)) {
if (i == 1) {
id = (pfun(a[2] - eta) - pfun(a[1] - eta)) != 0
gri = -sum(y_id[1,id] * w[id] * (1 - pfun(a[1] - eta[id]))) + sum(y_id[2,id] * w[id] * dfun(a[1] - eta[id]) / (pfun(a[2] - eta[id]) - pfun(a[1] - eta[id])))
} else if (i == (nc-1)) {
id = (pfun(a[nc-1] - eta) - pfun(a[nc-2] - eta)) != 0
gri = -sum(y_id[nc-1,id] * w[id] * dfun(a[nc-1] - eta[id]) / (pfun(a[nc-1] - eta[id]) - pfun(a[nc-2] - eta[id]))) + sum(I(y[id] == nc) * w[id] * dfun(a[nc-1] - eta[id]) / (1 - pfun(a[nc-1] - eta[id])))
#gri = -sum(y_id[nc-1,id] * w[id] * dfun(a[nc-1] - eta[id]) / (pfun(a[nc-1] - eta[id]) - pfun(a[nc-2] - eta[id]))) + sum(y_id[nc,id] * w[id] * dfun(a[nc-1] - eta[id]) / (1 - pfun(a[nc-1] - eta[id])))
} else {
id1 = (pfun(a[i] - eta) - pfun(a[i-1] - eta)) != 0
id2 = (pfun(a[i+1] - eta) - pfun(a[i] - eta)) != 0
id12 = id1 & id2
gri = -sum(y_id[i,id12] * w[id12] * dfun(a[i] - eta[id12]) / (pfun(a[i] - eta[id12]) - pfun(a[i-1] - eta[id12]))) + sum(y_id[i+1,id12] * w[id12] * dfun(a[i] - eta[id12]) / (pfun(a[i+1] - eta[id12]) - pfun(a[i] - eta[id12])))
}
gr = c(gr, gri)
}
return (gr)
}
#k = 4: Hess diagonal w.r.t a1, a2, a3 and off-diagonal
fwt_a = function(a, y, eta, w = NULL) {
n = length(y)
if (is.null(w)) {
w = rep(1, n)
}
nc = length(a) + 1
y_id = t(col(matrix(0, n, nc)) == y)
wt = matrix(0, (nc-1), (nc-1))
for (i in 1:(nc-1)) {
if (i == 1) {
id = (pfun(a[2] - eta) - pfun(a[1] - eta)) != 0
wt[1,1] = sum(y_id[1,id] * w[id] * dfun(a[1] - eta[id])) + sum(y_id[2,id] * w[id] * (ddfun(a[1] - eta[id]) / (pfun(a[2] - eta[id]) - pfun(a[1] - eta[id])) + (dfun(a[1] - eta[id]) / (pfun(a[2] - eta[id]) - pfun(a[1] - eta[id])))^2))
wt[1,2] = wt[2,1] = -sum(y_id[2,id] * w[id] * (dfun(a[2] - eta[id]) * dfun(a[1] - eta[id])) / (pfun(a[2] - eta[id]) - pfun(a[1] - eta[id]))^2)
} else if (i == (nc-1)) {
id = (pfun(a[nc-1] - eta) - pfun(a[nc-2] - eta)) != 0
wt[nc-1, nc-1] = -sum(y_id[nc-1,id] * w[id] * (ddfun(a[nc-1] - eta[id]) / (pfun(a[nc-1] - eta[id]) - pfun(a[nc-2] - eta[id])) - (dfun(a[nc-1] - eta[id]) / (pfun(a[nc-1] - eta[id]) - pfun(a[nc-2] - eta[id])))^2)) + sum(y_id[nc,id] * w[id] * dfun(a[nc-1] - eta[id]))
} else {
id1 = (pfun(a[i] - eta) - pfun(a[i-1] - eta)) != 0
id2 = (pfun(a[i+1] - eta) - pfun(a[i] - eta)) != 0
id12 = id1 & id2
wt[i,i] = -sum(y_id[i,id12] * w[id12] * (ddfun(a[i] - eta[id12]) / (pfun(a[i] - eta[id12]) - pfun(a[i-1] - eta[id12])) - (dfun(a[i] - eta[id12]) / (pfun(a[i] - eta[id12]) - pfun(a[i-1] - eta[id12])))^2)) + sum(y_id[i+1,id12] * w[id12] * (ddfun(a[i] - eta[id12]) / (pfun(a[i+1] - eta[id12]) - pfun(a[i] - eta[id12])) + (dfun(a[i] - eta[id12]) / (pfun(a[i+1] - eta[id12]) - pfun(a[i] - eta[id12])))^2))
wt[i,i+1] = wt[i+1,i] = -sum(y_id[i+1,id12] * w[id12] * (dfun(a[i+1] - eta[id12]) * dfun(a[i] - eta[id12])) / (pfun(a[i+1] - eta[id12]) - pfun(a[i] - eta[id12]))^2)
}
}
return (wt)
}
####
#estimate the probability of the latent variable lying
#between cut-points
####
#predict.cgam.polr = function(object,...) {
#fitted.cgam.polr = function(object) { #
# a = object$zeta
# eta = object$muhat
# lev = object$lev
# nc = length(a) + 1
# n = length(eta)
# ps = matrix(0, nrow = nc, ncol = n)
# for (i in 1:nc) {
# if (i == 1) {
# ps[i,] = pfun(a[1] - eta)
# } else if (i == nc) {
# ps[i,] = 1 - pfun(a[nc-1] - eta)
# } else {
# ps[i,] = pfun(a[i] - eta) - pfun(a[i-1] - eta)
# }
# }
# ps = t(ps)
# dimnames(ps) = list(1:n, lev)
# return (ps)
#}
#####
Ord = function(link = "identity") {
linktemp <- substitute(link)
if (!is.character(linktemp))
linktemp <- deparse(linktemp)
if (linktemp %in% c("identity"))
stats <- make.link(linktemp)
else if (is.character(link)) {
stats <- make.link(link)
linktemp <- link
}
else {
if (inherits(link, "link-glm")) {
stats <- link
if (!is.null(stats$name))
linktemp <- stats$name
}
else stop(linktemp, " link not available for ordered categorical family; available links are \"identity\"")
}
structure(list(family = "ordered", link = linktemp), class = "family")
}
#########################################
#subroutines for confidence interval
#########################################
makebin = function(x) {
k = length(x)
r = 0
for (i in 1:k) {
r = r + x[k-i+1]*2^(i-1)
}
r
}
getvars = function(num) {
i = num
digits = 0
power = 0
while (digits == 0) {
if (i < 2^power) {
digits = power
}
power = power+1
}
binry = 1:digits*0
if (num > 0) {
binry[1] = 1
}
i = i - 2^(digits - 1)
power = digits - 2
for (p in power:0) {
if (i >= 2^p) {
i = i - 2^p
binry[digits-p] = 1
}
}
binry
}
getbin = function(num, capl) {
br = getvars(num-1)
digits = length(br)
binrep = 1:capl*0
binrep[(capl-digits+1):capl] = br
binrep
}
########################################################
#cgam.pv:get p-values for smooth-constrained components#
#when there is only one x and one z, and test for x
#then it's not a sub-cone test and we don't use amat0 and coneA
#include mixed-effect for gaussian: weights is uinv_mat
###############################################################
cgam.pv = function(y, xmat, zmat, shapes, delta=NULL, np=NULL, capms=NULL,
numknotsuse=NULL, varlist=NULL, family=gaussian(),
weights=NULL, test_id=1, nsims=1000, skip=TRUE) {
n = length(y)
cicfamily <- CicFamily(family)
llh.fun <- cicfamily$llh.fun
#new: use log link in gamma
linkfun <- cicfamily$linkfun
etahat.fun <- cicfamily$etahat.fun
gr.fun <- cicfamily$gr.fun
wt.fun <- cicfamily$wt.fun
zvec.fun <- cicfamily$zvec.fun
muhat.fun <- cicfamily$muhat.fun
ysim.fun <- cicfamily$ysim.fun
deriv.fun <- cicfamily$deriv.fun
dev.fun <- cicfamily$dev.fun
capl = length(xmat) / n
if (capl < 1) {capl = 0}
capk = length(zmat) / n
if (capk < 1) {capk = 0}
capls = sum(shapes == 17)
one = 1:n*0 + 1
if (!skip) {
#numknots = c(0,0,0)
#knots = list(); for (i in 1:3) knots[[i]] = 0
#space = rep('E',3)
numknots <- rep(0, capl)
knots <- list(); for (i in 1:capl) knots[[i]] <- 0
space <- rep('E',capl)
delta <- NULL
varlist <- NULL
xid1 <- NULL; xid2 <- NULL; xpos2 <- 0
knotsuse <- list(); numknotsuse <- NULL
mslst <- list()
#new:
capm <- 0
capms <- 0
del1_ans <- makedelta(xmat[, 1], shapes[1], numknots[1], knots[[1]], space = space[1])
del1 <- del1_ans$amat
knotsuse[[1]] <- del1_ans$knots
mslst[[1]] <- del1_ans$ms
if(shapes[1] >= 9 & shapes[1] <= 17) {
numknotsuse <- c(numknotsuse, length(del1_ans$knots))
} else{
numknotsuse <- c(numknotsuse, nrow(del1))
}
m1 <- length(del1) / n
#new code: record the number of columns of del1 if shapes0[1] == 17:
if (shapes[1] == 17) {capms <- capms + m1}
var1 <- 1:m1*0 + 1
xpos1 <- xpos2 + 1
xpos2 <- xpos2 + m1
xid1 <- c(xid1, xpos1)
xid2 <- c(xid2, xpos2)
if (capl == 1) {
delta <- del1
varlist <- var1
} else {
for (i in 2:capl) {
#new code:
del2_ans <- makedelta(xmat[,i], shapes[i], numknots[i], knots[[i]], space = space[i])
del2 <- del2_ans$amat
knotsuse[[i]] <- del2_ans$knots
mslst[[i]] <- del2_ans$ms
if(shapes[i] >= 9 & shapes[i] <= 17) {
numknotsuse <- c(numknotsuse, length(del2_ans$knots))
} else{
numknotsuse <- c(numknotsuse, nrow(del2))
}
m2 <- length(del2) / n
#new code: record the number of columns of del2 if shapes0[i] == 17:
if (shapes[i] == 17) {capms <- capms + m2}
xpos1 <- xpos2 + 1
xpos2 <- xpos2 + m2
xid1 <- c(xid1, xpos1)
xid2 <- c(xid2, xpos2)
delta <- rbind(del1, del2)
varlist <- 1:(m1 + m2)*0
varlist[1:m1] <- var1
varlist[(m1 + 1):(m1 + m2)] <- (1:m2)*0 + i
var1 <- varlist
m1 <- m1 + m2
del1 <- delta
}
}
}
umbrella.delta = tree.delta = NULL
#ignore ut for now
delta_ut = NULL; caput = 0
if (!is.null(umbrella.delta) | !is.null(tree.delta)) {
delta_ut = rbind(umbrella.delta, tree.delta)
caput = nrow(delta_ut)
}
#del1 is edges for the component being tested; del0 is the cone with del1 removed
del1 = t(delta[varlist == test_id, ])
if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0 & capk > 0) {
del0 = cbind(t(delta[varlist != test_id, ]), one, zmat, xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13])
del = cbind(t(delta), one, zmat, xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13])
np = 1 + capk + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) > 0 & capk == 0) {
del0 = cbind(t(delta[varlist != test_id, ]), one, xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13])
del = cbind(t(delta), one, xmat[, shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13])
np = 1 + sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0 & capk > 0) {
del0 = cbind(t(delta[varlist != test_id, ]), one, zmat)
del = cbind(t(delta), one, zmat)
np = 1 + capk + capms
} else if (sum(shapes > 2 & shapes < 5 | shapes > 10 & shapes < 13) == 0 & capk == 0) {
del0 = cbind(t(delta[varlist != test_id, ]), one)
del = cbind(t(delta), one)
np = 1 + capms
} else {
print ("error in capk, shapes!")
}
m0 = dim(del0)[2]
m = dim(del)[2]
#nkts is the col number of edges for each component
nkts = numknotsuse
id_add = which(shapes >= 13 & shapes <= 17)
if (length(id_add) >= 1) {
nkts[id_add] = nkts[id_add] + 1
}
nr = sum(nkts)
nc = nr + np
amat = matrix(0, nrow=nr, ncol=nc)
for(i in 1:nr){amat[i,i]=1}
#if (capl>1) {
nr0 = sum(nkts) - nkts[test_id]
#} else {nr0 = sum(nkts)}
#nc0 = nr0 + np
#debugged
if (any(shapes == 17)) {
nc0 = nr0 + np - capms
} else {
nc0 = nr0 + np
}
amat0 = matrix(0, nrow=nr0, ncol=nc0)
#when there is only one component, flat vs s.incr
if (nr0 > 0) {
for(i in 1:nr0){amat0[i,i]=1}
} #else {'Use shapereg in coneproj'}
wt.iter = FALSE
if (family$family %in% c("binomial", "poisson")) {
wt.iter = TRUE
}
if (!wt.iter) {
if (is.null(weights)) {
weights = 1:n*0 + 1
}
w = weights
#new: to check if w is a matrix or not to include the mixed-effect case
### null hyp fit
if(!is.matrix(w)){
ytil = y*sqrt(w)
deltil = del0
for(i in 1:m0){deltil[,i] = deltil[,i]*sqrt(w)}
} else {
#w is uinv_mat
ytil = w %*% y
deltil = w %*% del0
}
#print (m0)
#print (np)
#print (head(del0))
if (m0 > np) {
umat = chol(crossprod(deltil))
uinv = solve(umat)
ytiltil = t(uinv) %*% crossprod(deltil, ytil)
atil = amat0 %*% uinv
ans = coneA(ytiltil, atil)
chat = uinv %*% ans$thetahat
mu1 = del0 %*% chat
#d0 = cbind(del2, del3)
} else {
cvec = t(deltil) %*% ytil
chat = solve(crossprod(deltil), cvec)
mu1 = del0 %*% chat
}
if (m0 > np) {
d0 = t(delta[varlist != test_id, ])
pr0 = -d0 %*% solve(crossprod(d0), t(d0))
for(i in 1:n){pr0[i,i] = 1+pr0[i,i]}
d1tr = pr0 %*% del1
#} else {
#d1tr = del1
#}
## do weighted projection of xi=z, weights w, onto d1tr cone
d1trw = d1tr
nk1 = nkts[test_id]
#new
if(!is.matrix(w)){
for(i in 1:nk1){d1trw[,i] = d1tr[,i]*sqrt(w)}
} else {
d1trw = w %*% d1trw
}
ans1 = coneB(ytil, d1trw)
num = sum((d1trw%*%ans1$coef)^2)
## do weighted projection of xi=z, weights w, onto big cone
delw = del
#new
if(!is.matrix(w)){
for(i in 1:m){delw[,i] = del[,i]*sqrt(w)}
} else {
delw = w %*% delw
}
ans2 = coneB(ytil,delw[,1:(m-np)],delw[,(m-np+1):m])
coef0 = ans2$coef
coef = coef0
coef[1:(m-np)] = coef0[(np+1):m]
coef[(m-np+1):m] = coef0[1:np]
ss2 = sum((ytil-delw%*%coef)^2)
#ss2 = sum((ytil-delw[,1:(m-np)]%*%ans2$coef[(np+1):m]-delw[,(m-np+1):m]*ans2$coef[1:np])^2)
df2 = n-sum(abs(ans2$coef)>1e-8)
#df2 = n - m
bstat = num/(num+ss2)
## get mixing distn
mdist = 0:nk1*0
for(isims in 1:nsims){
ysim = rnorm(n)
anss = coneB(ysim, d1trw)
d = sum(anss$coef>1e-8)
mdist[d+1] = mdist[d+1]+1
}
mdist = mdist/nsims
pval = mdist[1]
for(i in 1:nk1){
pval = pval+pbeta(bstat,i/2,df2/2)*mdist[i+1]
}
pv = 1-pval
} else {
#print (dim(del))
del2 = del
#new
if(!is.matrix(w)){
for(i in 1:m){del2[,i] = del2[,i] * sqrt(w)}
} else {
del2 = w %*% del2
}
nk = ncol(del1)
ans2 = coneB(ytil, del2[,1:nk], deltil)
chat2 = ans2$coefs
#nd = np?
nd = ncol(deltil)
that1 = deltil%*%chat2[1:nd]+del2[,1:nk]%*%chat2[(nd+1):m]
ss1 = sum((ytil-that1)^2)
ss0 = sum((ytil-deltil%*%chat)^2)
bstat = (ss0-ss1)/ss0
## get mixing distribution
mdist = 0:nk*0
keepd = 1:nsims
for(isims in 1:nsims){
ysim = rnorm(n)
anss = coneB(ysim, del2[,1:nk], deltil)
d = sum(abs(round(anss$coef,8))>0)
#mdist[d-2] = mdist[d-2]+1
mdist[d+1-np] = mdist[d+1-np]+1
#mdist[d] = mdist[d]+1
keepd[isims] = d
if(d < 3){zkeep=ysim}
}
mdist = mdist/nsims
pval = mdist[1]
for(i in 1:nk) {
pval = pval + pbeta(bstat,i/2,(n-np-i)/2)*mdist[i+1]
}
pv = 1-pval
}
} else {
#print (head(del0))
### null hyp fit
eta0 = 1:n*0
z = 1:n
#mu0 = muhat.fun(eta0, fml=family$family)
mu0 = 1:n*0 + 1/2
mu1 = mu0
if (is.null(weights)) {
weights = 1:n*0 + 1
}
prior.w = weights
end = FALSE; nrep = 0; face = NULL
while (!end & nrep < 100) {
nrep = nrep+1
if (family$famil == "binomial") {
ch = mu0>1e-5 & mu0<1-1e-5
}
if (family$famil == "poisson") {
ch = mu0>1e-5
}
z[ch] = eta0[ch] + (y[ch]-mu0[ch]) * deriv.fun(mu0[ch], fml = family$family)
z[!ch] = eta0[!ch]
w = as.vector(prior.w * (deriv.fun(mu0, fml = family$family))^(-1))
#w = mu0*(1-mu0)
#to avoid deltil to be singular; test!
w[which(round(w, 7) == 0)] = 1e-7
ztil = z*sqrt(w)
deltil = del0
#print (m0)
#print (any(round(w, 7) == 0))
#print (w[round(w, 7) == 0])
for(i in 1:m0){deltil[,i] = deltil[,i]*sqrt(w)}
if (m0 > np) {
#print ('True')
#print (qr(crossprod(deltil))$rank)
umat = chol(crossprod(deltil))
uinv = solve(umat)
ztiltil = t(uinv) %*% crossprod(deltil, ztil)
atil = amat0 %*% uinv
#if (nrep > 1) {
ans = coneA(ztiltil, atil, face=face)
#} else {
# ans = coneA(ztiltil, atil)
# face = ans$face
#if (nrep == 107 | nrep == 108) {
# print (face)
#}
#}
chat = uinv %*% ans$thetahat
} else {
#cvec = t(deltil) %*% ztil
#chat = solve(crossprod(deltil), cvec)
chat = solve(t(deltil)%*%deltil)%*%t(deltil)%*%ztil
}
eta1 = del0 %*% chat
mu1 = muhat.fun(eta1, fml=family$family)
#tb=eta1>50
#mu1=eta1
#mu1[!tb]=exp(eta1[!tb])/(1+exp(eta1[!tb]))
#mu1[tb]=1
ch2 = mu1 > 2*max(y)
if (length(ch2) >= 1) {
mu1[ch2] = 2*max(y)
}
dist = sqrt(sum(mu0-mu1)^2/sum(mu0^2))
#print (dist)
if (dist < 1e-5){end = TRUE} else {eta0=eta1;mu0=mu1}
}
#print (head(mu1,10))
#if m0 > np, del0 is a cone containing a linear space
if (m0 > np) {
d0 = t(delta[varlist != test_id, ])
#pr0 = -d0%*%solve(crossprod(d0), t(d0))
#for(i in 1:n){pr0[i,i] = 1+pr0[i,i]}
#d1tr = pr0%*%del1
## do weighted projection of xi=z, weights w, onto d1tr cone
#d1trw = d1tr
#nk1 = nkts[test_id]
#for(i in 1:nk1){d1trw[,i] = d1tr[,i]*sqrt(w)}
#to make sure edges are orthogonal:
m0a = dim(d0)[2]
d0w = d0
for(i in 1:m0a){d0w[,i] = d0[,i]*sqrt(w)}
pr0 = -d0w %*% solve(t(d0w) %*% d0w) %*% t(d0w)
for(i in 1:n){pr0[i,i]=1+pr0[i,i]}
#}
del1w = del1
nk1 = nkts[test_id]
for(i in 1:nk1){del1w[,i] = del1[,i]*sqrt(w)}
#if (capl > 1) {
d1trw = pr0%*%del1w
#} else {
#d1trw = del1w
ans1 = coneB(ztil, d1trw)
num = sum((d1trw %*% ans1$coef)^2)
## do weighted projection of xi=z, weights w, onto big cone
delw = del
for(i in 1:m){delw[,i] = del[,i]*sqrt(w)}
ans2 = coneB(ztil,delw[,1:(m-np)],delw[,(m-np+1):m])
coef0 = ans2$coef
coef = coef0
coef[1:(m-np)] = coef0[(np+1):m]
coef[(m-np+1):m] = coef0[1:np]
#ss2 = sum((ztil-delw[,1:(m-np)]%*%ans2$coef[(np+1):m]-delw[,(m-np+1):m]*ans2$coef[1:np])^2)
ss2 = sum((ztil-delw%*%coef)^2)
#df2=n-sum(abs(ans2$coef)>1e-8)
df2 = n - m
bstat = num/(num+ss2)
#print (bstat)
#print (dim(amat))
#print (dim(amat0))
mdist = 0:nk1*0
for(isims in 1:nsims){
zsim = rnorm(n)
anss = coneB(zsim, d1trw)
d = sum(anss$coef>1e-8)
mdist[d+1] = mdist[d+1]+1
}
mdist = mdist/nsims
pval = mdist[1]
for(i in 1:nk1){
pval = pval+pbeta(bstat,i/2,df2/2)*mdist[i+1]
}
pv = 1-pval
} else {
#print (head(del))
#only one x and >= one z; del2 is a copy of del
del2 = del
#print (head(del))
#print (head(w))
for(i in 1:m){del2[,i] = del2[,i]*sqrt(w)}
nk = ncol(del1)
#print (nk)
#print (head(del2))
#print (nk)
#print (head(deltil))
#print (nrep)
#print (head(ztil))
#print (head(del2))
ans2 = coneB(ztil, del2[,1:nk], deltil)
chat2 = ans2$coefs
#print (chat2)
#nd = np?
nd = ncol(deltil)
that1 = deltil%*%chat2[1:nd]+del2[,1:nk]%*%chat2[(nd+1):m]
ss1 = sum((ztil - that1)^2)
ss0 = sum((ztil - deltil %*% chat)^2)
#print (ss0)
#print (ss1)
bstat = (ss0 - ss1)/ss0
#print (bstat)
## get mixing distribution
#set.seed(123)
mdist = 0:nk*0
keepd = 1:nsims
for(isims in 1:nsims){
zsim = rnorm(n)
ans = coneB(zsim, del2[,1:nk], deltil)
d = sum(abs(round(ans$coef,8))>0)
#mdist[d-2] = mdist[d-2]+1
mdist[d+1-np] = mdist[d+1-np]+1
#mdist[d] = mdist[d]+1
keepd[isims] = d
if(d < 3){zkeep=zsim}
}
mdist = mdist/nsims
pval = mdist[1]
for(i in 1:nk) {
pval = pval + pbeta(bstat,i/2,(n-np-i)/2)*mdist[i+1]
}
pv = 1-pval
#print (pv)
}
}
ans = list(pv = pv, edf = sum(abs(ans2$coef)>1e-8), coef=ans2$coef, bstat=bstat)
return (ans)
}
############################################################
#cgam.pvz is to test categorical predictors, not every level
#for mixed-effect model, use uinv_mat as w
############################################################
cgam.pvz = function(y, bigmat, df_obs, sse1 = NULL, np = 1, zid = 1, zid1 = 1, zid2 = 1, muhat = NULL,
etahat = NULL, coefskeep = NULL, wt.iter=FALSE, family=gaussian(), weights=NULL,
uinv_mat=NULL) {
n = length(y)
cicfamily = CicFamily(family)
llh.fun = cicfamily$llh.fun
#new: use log link in gamma
linkfun = cicfamily$linkfun
etahat.fun = cicfamily$etahat.fun
gr.fun = cicfamily$gr.fun
wt.fun = cicfamily$wt.fun
zvec.fun = cicfamily$zvec.fun
muhat.fun = cicfamily$muhat.fun
ysim.fun = cicfamily$ysim.fun
deriv.fun = cicfamily$deriv.fun
dev.fun = cicfamily$dev.fun
m = nrow(bigmat)
df_full = min(m, 1.2*df_obs)
if (is.null(weights)) {
weights = 1:n*0 + 1
}
prior.w = weights
#n = ncol(bigmat)
lz = length(zid)
#we only need to get ssers in the following code
pvs = ssers = ssefs = fstats = edfs = rep(0, lz)
#sse_f = NULL
for(iz in 1:lz){
pos1 = zid1[iz]
pos2 = zid2[iz]
bigmat0 = bigmat[-c((pos1+1):(pos2+1)), ,drop = FALSE]
#np0 is the # of columns remaining in the vmat; it's for H_0
np0 = np - (pos2-pos1+1)
#lvs is the # of levels in a z, including the reference level
lvs = (pos2-pos1+1)
edfs[iz] = lvs
#initialize
cvec = NULL
etahat = NULL
if (wt.iter) {
etahat = etahat.fun(n, y, fml = family$family)
gr = gr.fun(y, etahat, weights, fml = family$family)
wt = wt.fun(y, etahat, n, weights, fml = family$family)
cvec = wt * etahat - gr
} else {wt = wt.fun(y, etahat, n, weights, fml = family$family)}
#new:
if(is.null(uinv_mat)){
zvec = zvec.fun(cvec, wt, y, fml = family$family)
gmat = t(bigmat0)
for (i in 1:n) {gmat[i,] = bigmat0[,i] * sqrt(wt[i])}
} else {
#only used for gaussian
zvec = uinv_mat %*% y
gmat = t(bigmat0)
gmat = uinv_mat %*% gmat
}
dsend = gmat[, -c(1:np0), drop = FALSE]
zsend = gmat[,1:np0 , drop = FALSE]
ans = coneB(zvec, dsend, zsend)
face = ans$face
etahat = t(bigmat0) %*% ans$coefs
#coefs = ans$coefs
#muhat = t(bigmat0) %*% coefs
muhat = etahat
if(is.null(uinv_mat)){
sse_r = sum(prior.w * (y - muhat)^2)
}else {
sse_r = sum(uinv_mat %*% (y - muhat)^2)
}
sse_f = sse1
fstati = (sse_r - sse_f) / lvs / sse_f*(n-df_full)
#print (sse_r)
#print (sse_f)
#print (lvs)
#print (n-df_full)
#print (dim(bigmat0))
#print (dim(bigmat))
pvi = 1 - pf(fstati, lvs, n-df_full)
if (wt.iter) {
sm = 1e-7
muhat = muhat.fun(etahat, fml = family$family)
diff = 1
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
nrep = 0
##########
#iterate!#
##########
while (diff > sm & mdiff & nrep < n^2){
oldmu = muhat
nrep = nrep + 1
gr = gr.fun(y, etahat, weights, fml = family$family)
wt = wt.fun(y, etahat, n, weights, fml = family$family)
cvec = wt * etahat - gr
#zvec <- cvec / sqrt(wt)
zvec = zvec.fun(cvec, wt, y, fml = family$family)
#gmat <- t(bigmat %*% sqrt(diag(wt)))
gmat = t(bigmat0)
for (i in 1:n) {gmat[i,] = bigmat0[,i] * sqrt(wt[i])}
dsend = gmat[, -c(1:np0), drop = FALSE]
zsend = gmat[,1:np0 , drop = FALSE]
#ans <- coneB(zvec, t(dsend), zsend)
ans = coneB(zvec, dsend, zsend, face = face)
etahat = t(bigmat0) %*% ans$coefs
muhat = muhat.fun(etahat, fml = family$family)
diff = mean((muhat - oldmu)^2)
mdiff = abs(max(muhat) - 1)
if (family$family == "binomial") {
mdiff = abs(max(muhat) - 1) > sm
} else {mdiff = TRUE}
}
z = 1:n*0
if (family$famil == "binomial") {
ch = muhat>1e-7 & muhat<1-1e-7
}
if (family$famil == "poisson") {
ch = muhat>1e-7
}
z[ch] = etahat[ch] + (y[ch]-muhat[ch]) * deriv.fun(muhat[ch], fml = family$family)
z[!ch] = etahat[!ch]
w = as.vector(prior.w * (deriv.fun(muhat, fml = family$family))^(-1))
#to avoid deltil to be singular
w[which(round(w, 7) == 0)] = 1e-7
ztil = z*sqrt(w)
deltil = t(bigmat0)
m0 = nrow(bigmat0)
for(i in 1:m0){deltil[,i] = deltil[,i]*sqrt(w)}
sse_r = sum((ztil - deltil %*% ans$coefs)^2)
deltil = t(bigmat)
m = nrow(bigmat)
for(i in 1:m){deltil[,i] = deltil[,i]*sqrt(w)}
umat = chol(t(deltil)%*%deltil)
#umat = chol(crossprod(deltil))
uinv = solve(umat)
ztiltil = t(uinv) %*% t(deltil) %*% ztil
#amat = matrix(0, nrow = m, ncol = m)
#nk = m - np
#for(ik in 1:nk){amat[ik,ik] = 1}
amat = diag(m-np)
zerom = matrix(0, nrow=nrow(amat), ncol=np)
amat = cbind(zerom, amat)
atil = amat %*% uinv
ans = coneA(ztiltil, atil)
sse_f = sum((ztil - deltil %*% uinv %*% ans$thetahat)^2)
df_full = min(m, 1.2*ans$df)
fstati = (sse_r - sse_f) / lvs / sse_f*(n-df_full)
pvi = 1 - pf(fstati, lvs, n-df_full)
}
ssers[iz] = sse_r
ssefs[iz] = sse_f
fstats[iz] = fstati
#pvi = 1 - pf(fstati, lvs, n-df_full)
pvs[iz] = pvi
}
rslt = list(pvs = pvs, ssers = ssers, ssefs = ssefs, fstats = fstats, edfs = edfs, mu1 = muhat)
return (rslt)
}
#############
#anova.cgam#
############
anova.cgam <- function(object,...){
family <- object$family
call <- object$call
pvs <- object$pvs
pvsz <- object$pvsz
capl <- object$capl
capk <- object$capk
s.edf <- object$s.edf
z.edf <- object$z.edf
bstats <- object$bstats
fstats <- object$fstats
zid <- object$zid
#zid1 <- object$zid1 - 1 - length(shapes)
#zid2 <- object$zid2 - 1 - length(shapes)
#new: zid1, zid2 just index zmat not bigmat
zid1 <- object$zid1
zid2 <- object$zid2
tms <- object$tms
is_param <- object$is_param
is_fac <- object$is_fac
vals <- object$vals
#new:
rslt1 <- pTerms.pv <- NULL
if (!is.null(pvsz)) {
rslt1 <- data.frame("df" = z.edf, "F-stat" = round(fstats, 4), "p.value" = round(pvsz, 4))
lzid <- length(zid1)
for (i in 1:lzid) {
rownames(rslt1)[i] <- attributes(tms)$term.labels[zid[i] - 1]
}
rslt1 <- as.matrix(rslt1)
pTerms.pv <- pvsz
#rownames(pTerms.pv) <- rownames(rslt1)
}
rslt2 <- s.pv <- NULL
if (!is.null(pvs)) {
rslt2 <- data.frame("edf" = round(s.edf, 4), "mixture of Beta" = round(bstats, 4), "p.value" = round(pvs, 4))
#rownames(rslt2) <- attributes(tms)$term.labels
#debugged: check more
if (!is.null(zid)) {
if(inherits(object, "cgamm")){
rownames(rslt2) <- rev(rev((attributes(tms)$term.labels)[-(zid-1)])[-1])
} else {
rownames(rslt2) <- (attributes(tms)$term.labels)[-(zid-1)]
}
} else {
if(inherits(object, "cgamm")){
rownames(rslt2) <- rev(rev((attributes(tms)$term.labels))[-1])
} else{
rownames(rslt2) <- (attributes(tms)$term.labels)
}
}
s.pv <- pvs
#rownames(s.pv) <- rownames(rslt2)
}
ans <- list(call = call, coefficients1 = rslt1, coefficients2 = rslt2, family = family, s.pv = s.pv, pTerms.pv = pTerms.pv)
class(ans) <- "anova.cgam"
return(ans)
}
print.anova.cgam <- function(x,...){
print(x$family)
cat("Formula:\n")
print(x$call)
if (!is.null(x$coefficients1)) {
cat("\n")
cat("Parametric terms:\n")
printCoefmat(x$coefficients1, P.values = TRUE, has.Pvalue = TRUE)
}
#cat("\n")
if (!is.null(x$coefficients2)) {
cat("\n")
cat("Approximate significance of smooth terms: \n")
printCoefmat(x$coefficients2, P.values = TRUE, has.Pvalue = TRUE)
}
}
###############################################
#subroutines for monotonic variance estimation
###############################################
varest = function(y, x, muhat=NULL, shape=9, var.knots=0, db.exp=FALSE){
n = length(y)
order.id = order(x)
#new:rk to order var back
#rk = rank(x)
#x = x[order.id]
xs = sort(x)
y = y[order.id]
ndegree = 2
#if (length(muhat) == 1){
# muhat = rep(0,n)
#}
#if (length(muhat) == n){
# muhat = muhat
#}
if (n < 20) {
print("ERROR: must have at least 20 observations")
}
if (length(x) != length(y)) {
print("ERROR: length of x must be length of y")
}
if (length(var.knots) > 1) {
var.kint = var.knots[-c(1, length(var.knots))]
} else {
br = c(30, 100, 200, 400, 700, 1000, 1e+10)
obs = 1:7
var.nk = min(obs[n < br]) + 2
var.knots = 0:(var.nk - 1)/(var.nk - 1) * (max(x) - min(x)) + min(x)
var.kint = var.knots[-c(1, length(var.knots))]
}
nknots = length(var.kint)
nk = nknots + 2 + 1
#initial coefficients
theta0 = seq(1, 0.5, length = nk)
dif.theta = 1
amat = matrix(0, ncol = nk, nrow = nk)
#if (increasing == 1){
if (shape == 9) {
for (i in 1:(nk - 1)) {
amat[i, i] = 1
amat[i, i + 1] = -1
}
amat[nk, nk] = 1
}
#if (increasing == 2){
if (shape == 10) {
for (i in 1:(nk - 1)) {
amat[i, i] = -1
amat[i, i + 1] = 1
}
amat[nk, 1] = 1
}
bvec = c(rep(0,nk-1), 10^-10)
Bint = splines::bs(xs, knots = var.kint, degree = 2, intercept = T)
if (!is.null(muhat)) {
r = y - muhat
} else {
r = y
}
sm = 1e-6
nrep = 0
while (dif.theta > sm) {
nrep = nrep + 1
dl = db.penal(theta0, Bint, r, db.exp)
d2l = ddb.penal(theta0, Bint)
res = qprog(d2l, c(t(theta0) %*% d2l) - dl, amat, bvec)
#if (class(res) == "try-error") {
# break
#}
theta1.new = res$thetahat
var1 = 1/(Bint %*% theta1.new)
var0 = 1/(Bint %*% theta0)
dif.theta = sum(abs(var1 - var0))/sum(abs(var0))
theta0 = theta1.new + 1e-10
#print (dif.theta)
}
res0 = theta1.new
if (!db.exp) {
vhat = 1/Bint %*% theta1.new
} else if (db.exp) {
vhat = (1/Bint %*% theta1.new)^2
}
#new
#print (vhat)
#vhat = vhat[rk]
#print (vhat)
vhat=vhat[rank(x)]
res = list(vhat = vhat, muhat = muhat, x = x, y = y, var.knots = var.knots)
return(res)
}
#functions used in the varest function for normal errors
db.penal <- function(betas,B,r, db.exp=FALSE){
nk= ncol(B)
dl=vector()
if (!db.exp) {
for (i in 1:nk){
dl[i]=sum(-(1/(B%*%betas))*B[,i] + (r^2)*B[,i])
}
} else {
for (i in 1:nk){
dl[i]=sum(-(1/(B%*%betas))*B[,i] + sqrt(2)*abs(r)*B[,i])
}
}
return(dl)
}
ddb.penal <- function(betas,B){
nk=ncol(B)
d2l=diag(0,nk)
for (i in 1:nk){
for (j in 1:nk){
d2l[i,j]= sum((1/((B%*%betas)^2))*(B[,i]*B[,j]))
}
}
return(d2l)
}
ddb.penal_dexp <- function(betas,B){
nk=ncol(B)
d2l=diag(0,nk)
for (i in 1:nk){
for (j in 1:nk){
d2l[i,j] = sum((1/((B%*%betas)^2))*(B[,i]*B[,j]))
}
}
return(d2l)
}
#---------------------------------------------------------------------------------------------------------------
# linear monotone/quadratic vs smooth constrained test
#---------------------------------------------------------------------------------------------------------------
testpar <- function(formula0, formula, data, family = gaussian(link = "identity"), ps = NULL, edfu = NULL,
nsim = 200, multicore = TRUE, method = "testpar.fit",
arp = FALSE, p = NULL, space = "Q",...) {
cl <- match.call()
if (is.character(family))
family <- get(family, mode = "function", envir = parent.frame())
if (is.function(family))
family <- family()
if (is.null(family$family))
stop("'family' not recognized!")
mf <- match.call(expand.dots = FALSE)
if(missing(data))
data <- environment(formula)
m <- match(c("formula0", "formula", "data"), names(mf), 0L)
#----------------------------------------------------------------------------------------------------------------------
#formula0 is not very useful; we just need it to see if H0 is linear or quadratic, or a linear plane/interaction plane?
#----------------------------------------------------------------------------------------------------------------------
form0_expr <- deparse(mf[c(1L, m[1])])
expr_inside <- sub(".*\\((.*)\\)", "\\1", form0_expr)
expr_parts <- strsplit(expr_inside, " \\+ ")[[1]]
expr_parts <- lapply(expr_parts, function(x) trimws(gsub("[()]", "", x)))
parametric <- lapply(expr_parts, function(x) {dplyr::case_when(grepl("\\*", x) ~ "warped_plane",
grepl("\\^2", x) ~ "quadratic",
grepl("\\^1", x) ~ "linear",
TRUE ~ "linear")}) |> unlist()
form_expr <- deparse(mf[c(1L, m[2])])
#----------------------------------------------------------
#check attributes in cgam formula; get shapes and x's and y
#----------------------------------------------------------
mf <- mf[c(1L, m[-1])] #used formula
mf[[1L]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
ynm <- names(mf)[1]
mt <- attr(mf, "terms")
y <- model.response(mf, "any")
#------------------------
#extract x, y, z, etc...
#------------------------
#mf is a data frame and can be treated as a list
mf_xz <- mf[, -1, drop = FALSE]
x_or_z <- lapply(mf_xz, function(e) attr(e, "categ"))
is_z <- sapply(x_or_z, is.null)
nvars <- nz <- sum(is_z)
zmat <- x <- shp <- shp_pr <- NULL
if(any(is_z)){
znm_in_form <- names(x_or_z)[which(is_z)]
z_ps_in_param <- sapply(expr_parts, function(e) e == znm_in_form)
parametric <- parametric[-which(z_ps_in_param)]
z <- mf_xz[, is_z, drop = FALSE]
is_fac <- sapply(z, function(e) is.factor(e))
if(any(is_fac)){
#test more
if(sum(!is_fac) > 0){
zmat <- as.matrix(z[, !is_fac, drop = FALSE])
} else {zmat <- NULL}
#add znm later
dd <- model.matrix(~ z[, is_fac], drop = FALSE)[, -1, drop = FALSE]
zmat <- cbind(zmat, dd)
} else {
zmat <- as.matrix(z)
}
}
if(any(!is_z)){
x <- mf_xz[, !is_z, drop = FALSE]
add_or_wps <- lapply(x, function(e) attr(e, "categ")) |> simplify2array()
nx <- length(add_or_wps)
X <- vector("list", length = nx)
if(any(add_or_wps == "warp")){
parametric2 <- rep("linear", length = nx)
rp_ps <- which(parametric != "linear")
rp_ps0 <- rp_ps
if(any(rp_ps > nx)){
rp_ps <- rp_ps - (rp_ps - nx)
}
parametric2[rp_ps] <- parametric[rp_ps0]
if(any(parametric == "warped_plane")){
wp_ps <- which(parametric == "warped_plane")
if(length(wp_ps) == 1){
if(wp_ps > nx){
shift <- max(wp_ps) - nx
parametric2[wp_ps - shift] <- "warped_plane"
} else {
parametric2[wp_ps] <- "warped_plane"
}
}
if(length(wp_ps) > 1){
diff_wp_ps <- diff(wp_ps)
if(any(diff_wp_ps > 2)) {
diff_wp_ps[which(diff_wp_ps > 2)] <- 2
}
min_wp_ps <- wp_ps[1]
new_wp_ps <- c(min_wp_ps, rep(min_wp_ps, length(wp_ps)-1) + diff_wp_ps)
if(any(new_wp_ps > nx)){
shift <- max(new_wp_ps) - nx
new_wp_ps <- new_wp_ps - shift
}
parametric2[new_wp_ps] <- "warped_plane"
}
}
parametric <- parametric2
}
for(ix in 1:nx){
X[[ix]] <- x[, ix]
shape_ix <- attr(X[[ix]], "shape")
if(add_or_wps[ix] == "additive"){
if(!shape_ix %in% c(9, 10)){
attr(X[[ix]], "type") <- "convex"
attr(X[[ix]], "parametric") <- parametric[ix]
} else if(shape_ix %in% c(9, 10)){
attr(X[[ix]], "type") <- "monotone"
#attr(X[[ix]], "parametric") <- "linear"
attr(X[[ix]], "parametric") <- parametric[ix]
}
}
if(add_or_wps[ix] == "warp"){
attr(X[[ix]], "type") <- "monotone_plane"
#temp
attr(X[[ix]], "parametric") <- parametric[ix]
#print (parametric[ix])
}
}
}
#----------------------------------------------------------
#call testpar.fit
#----------------------------------------------------------
fit <- testpar.fit(X=X, y=y, zmat=zmat, family=family, ps=ps, edfu=edfu, nsim=nsim, multicore=multicore,
GCV=FALSE, lams=NULL, arp=arp, p=p, space=space, parametric=parametric)
rslt <- structure(c(fit, list(X = X, zmat = zmat, call = cl, formula0 = formula0, formula = formula, terms = mt, data = data, parametric=parametric, family = family)))
#class(rslt) <- "cgam"
return(rslt)
}
#----------------------------------------------------------
testpar.fit = function(X, y, zmat = NULL, family = gaussian(link="identity"),
ps = NULL, edfu = NULL, nsim = 200, multicore = TRUE,
GCV = FALSE, lams = NULL,
arp = FALSE, p = NULL, space = "Q",...)
{
#print (head(y))
wt.iter = ifelse(family$family == "gaussian", FALSE, TRUE)
extras = list(...)
#new:
#capl = NCOL(x)
capl = length(X)
n = length(y)
k1 = k2 = NULL
p_optim = 0
if(arp){
#if the user didn't provide p, then choose p from 0:3
if(is.null(p)){
p = 0:2
} else if (p < 0 || p > 2) {
warning("The order in AR(p) must be an integer >= 0 and <= 2!")
p = 1
}
} else {
p = 0
}
#-------------------
#get xm, amat, dmat
#-------------------
mult = 2
nz = 0
if(!is.null(zmat)){
nz = NCOL(zmat)
}
xm0 = NULL #combine dd columnwise
amat_lst = vector("list", length = capl)
awmat_lst = vector("list", length = capl)
dmat_lst = vector("list", length = capl)
dd_lst = kts_lst = vector("list", length = capl)
edfu_vec = numeric(capl)
var_track = var_track_param = NULL
iadd = ipr = 0
for(icomp in 1:capl){
x = X[[icomp]] #|> as.matrix()
if(NCOL(x) == 1){
iadd = iadd + 1
xu = unique(x)
n1 = length(xu)
type = attr(x, "type")
nkts = mult * switch(type, monotone = trunc(n1^(1/5)) + 6, convex = trunc(n1^(1/7)) + 6)
if(space == "Q"){
kts = quantile(xu, probs = seq(0, 1, length = nkts), names = FALSE)
}
if(space == "E"){
kts = 0:(nkts - 1) / (nkts - 1) * (max(x) - min(x)) + min(x)
#kts = seq.int(min(x), max(x), length = nkts)
}
kts_lst[[icomp]] = kts
#new: make delta here; combine it into xm
spl_degree = switch(type, monotone = 2L, convex = 3L)
spl_ord = spl_degree + 1
#dd_ans = bqspl(x, m=NULL, knots=kts)
#dd = dd_ans$bmat
dd = bSpline(x, knots = kts[-c(1, nkts)], degree = spl_degree, intercept = TRUE)
#dd = bs(x, knots = kts[-c(1, nkts)], degree = spl_degree, intercept = TRUE)
#xm = cbind(xm, dd)
#test!
if(icomp > 1){
dd = dd[, -1]
}
dd_lst[[icomp]] = dd
var_track = c(var_track, rep(icomp, NCOL(dd)))
#check more
#if(is.null(edfu)){
edfu = switch(type, monotone = (nkts/mult) , convex = (nkts/mult + 1))
edfu_vec[icomp] = edfu #+ nz
#}
shp = attr(x, "shape")
parametric = attr(x, "parametric")
#new: make amat here; add it to amat_lst
amat = makeamat_1D(shp=shp, spl_ord=spl_ord, kts=kts, x=x, x1=min(x), xn=max(x))
#check more
#if(iadd > 1) {
if(icomp > 1){
amat = amat[, -1]
}
amat_lst[[icomp]] = amat
#new: make awmat in case we have plane comps.
#new: make dmat here; add it to dmat_lst
nc = NCOL(dd)
dmat = makedmat_1D(nc, q = spl_ord)
dmat_lst[[icomp]] = dmat
#dv_lst[[icomp]] = crossprod(dmat)
#make xm0 here
#xm0 = switch(attr(x, "parametric"), linear = cbind(1, x), quadratic = cbind(1, x, x^2))
xm0_icomp = switch(parametric, linear = cbind(1, x), quadratic = cbind(1, x, x^2))
#check more
#if(iadd > 1 |ipr > 1) {
if(icomp > 1){
xm0_icomp = xm0_icomp[, -1]
}
xm0 = cbind(xm0, xm0_icomp)
var_track_param = c(var_track_param, rep(icomp, NCOL(xm0_icomp)))
#ddwm_lst[[icomp]] = xm0_icomp
#print (shp)
awmat = makeamat_1D_param(shp = shp, parametric = parametric, x1=min(x), xn=max(x))
#if(ipr > 1 | iadd > 1){
if(icomp > 1){
awmat = awmat[, -1]
}
awmat_lst[[icomp]] = awmat
}
use_constreg = FALSE
if(NCOL(x) == 2){
use_constreg = TRUE
shp = shp_pr = attr(x, "shape")
#print (shp_pr)
parametric = attr(x, "parametric")
ipr = ipr + 1
x1 = x[, 1]
x2 = x[, 2]
xu1 = unique(x1)
xu2 = unique(x2)
m1 = round(5*n^(1/6))
m2 = round(5*n^(1/6))
x1sc = (x1 - min(x1)) / (max(x1) - min(x1))
x2sc = (x2 - min(x2)) / (max(x2) - min(x2))
if(parametric == "linear"){
if(space == "Q"){
k1 = quantile(x1, probs = seq(0, 1, length = m1), names = FALSE)
k2 = quantile(x2, probs = seq(0, 1, length = m2), names = FALSE)
}
if(space == "E"){
k1 = 0:(m1 - 1) / (m1 - 1) * (max(x1) - min(x1)) + min(x1)
k2 = 0:(m2 - 1) / (m2 - 1) * (max(x2) - min(x2)) + min(x2)
}
}
if(parametric == "warped_plane"){
if(space == "Q"){
k1 = quantile(x1sc, probs = seq(0, 1, length = m1), names = FALSE)
k2 = quantile(x2sc, probs = seq(0, 1, length = m2), names = FALSE)
}
if(space == "E"){
k1 = 0:(m1 - 1) / (m1 - 1) * (max(x1sc) - min(x1sc)) + min(x1sc)
k2 = 0:(m2 - 1) / (m2 - 1) * (max(x2sc) - min(x2sc)) + min(x2sc)
}
}
#if(is.null(edfu)){
edfu = 3*(n^(1/3))
edfu_vec[icomp] = edfu
#}
#new: make delta here; combine it into xm
if(parametric == "linear"){
sp = space
dd_ans = makedelta_wps(x1, x2, space = c(sp, sp), k1 = k1, k2 = k2, decreasing = c(FALSE, FALSE))
}
if(parametric == "warped_plane"){
sp = space
dd_ans = makedelta_wps(x1sc, x2sc, space = c(sp, sp), k1 = k1, k2 = k2, decreasing = c(FALSE, FALSE))
}
dd = dd_ans$delta
if(icomp > 1){
dd = dd[, -1]
}
dd_lst[[icomp]] = dd
var_track = c(var_track, rep(icomp, NCOL(dd)))
#new: need to re-define k1 and k2; some cells might be empty
k1 = dd_ans$k1
k2 = dd_ans$k2
kts = list(k1 = k1, k2 = k2)
kts_lst[[icomp]] = kts
m1 = length(k1)
m2 = length(k2)
use_constreg = TRUE
#new: make amat here; add it to amat_lst
amat = makeamat_nonadd(k1, k2, shp_pr)
#check more
if(icomp > 1){
amat = amat[, -1]
}
amat_lst[[icomp]] = amat
#new: make dmat here; add it to dmat_lst
dmat = makedmat_2D(k1, k2)
#check more
if(icomp > 1){
dmat = dmat[, -1]
}
dmat_lst[[icomp]] = dmat
#dv_lst[[icomp]] = crossprod(dmat)
#make xm0 here
xm0_icomp = switch(parametric, linear = cbind(1, x1, x2), warped_plane = cbind(1, x1sc, x2sc, x1sc*x2sc))
#check more
if(icomp > 1){
xm0_icomp = xm0_icomp[, -1]
}
xm0 = cbind(xm0, xm0_icomp)
var_track_param = c(var_track_param, rep(icomp, NCOL(xm0_icomp)))
#print (shp)
awmat = makeamat_1D_param(shp, parametric = parametric)
if(icomp > 1){
awmat = awmat[, -1]
}
awmat_lst[[icomp]] = awmat
}
#make xm0 here
#xm0 = switch(attr(x, "parametric"), linear = cbind(1, x), quadratic = cbind(1, x, x^2), linear_plane = cbind(1, x1, x2), warped_plane = cbind(1, x1sc, x2sc, x1sc*x2sc))
}
amat = Matrix::bdiag(amat_lst) |> as.matrix()
dmat = Matrix::bdiag(dmat_lst) |> as.matrix()
#dv = Matrix::bdiag(dv_lst) |> as.matrix()
dd = do.call(cbind, dd_lst)
#dd = Matrix(dd, sparse = TRUE)
nr_am = NROW(amat)
#----------------------
#create bvec for qprog
#----------------------
bvec = rep(0, nr_am) #will be different when using constreg
#----------------------------------------------------------------------------
#2.get H1 fit: cone \ L satisfying some shape constraint
#write a new function: fit.alt
#----------------------------------------------------------------------------
nc = nc_noz = NCOL(dd)
if(nz > 0){
dd_1 = dd_lst[[1]]
dd_1 = cbind(zmat, dd_1)
dd_lst[[1]] = dd_1
dm_1 = dmat_lst[[1]]
dm1_zero = matrix(0, nrow = nrow(dm_1), ncol = nz)
dm_1 = cbind(dm1_zero, dm_1)
dmat_lst[[1]] = dm_1
dd = cbind(zmat, dd)
dmat_zero = matrix(0, nrow = nrow(dmat), ncol = nz)
dmat = cbind(dmat_zero, dmat)
amat_zero = matrix(0, nrow = nrow(amat), ncol = nz)
amat = cbind(amat_zero, amat)
}
dv = crossprod(dmat)
#new:
qv0 = crossprod(dd)
#dv = Matrix(dv, sparse = TRUE)
#qv0 = Matrix(qv0, sparse = TRUE)
nc_am = NCOL(amat)
imat = diag(nc_am)
if(GCV){
#temp:
edfu = sum(edfu_vec)
edfu_grid = c(edfu-1, edfu, edfu + (1:2) * 3)
if(is.null(lams)){
lams = sapply(edfu_grid, function(e){uniroot(f = .search_ps, qv0 = qv0, dv = dv, dd = dd, edfu = e, interval = c(1e-10, 2e+2), tol=1e-6)$root})
lams = c(1e-3, rev(lams))
if(arp){
#test!
lams = 2^(2:8)
#lams = 2^(1:7)
lams = lams/2^7/n^(2*spl_ord/(2*spl_ord+1))
# lams = 2^(1:8)
# lams = lams/2^8/n^(3/4)
}
gcvs_rslt = parallel::mclapply(lams, function(e) fit.hypo(p=p, dd=dd, y=y, amat=amat, bvec=bvec,
dv=dv, family=family, arp=arp, ps=e), mc.cores = (8L))
gcvs = sapply(gcvs_rslt, function(rslti) rslti$gcv, simplify = TRUE)
edfs = sapply(gcvs_rslt, function(rslti) rslti$edf, simplify = TRUE)
choice_id = which(gcvs == min(gcvs))
ps = lams[choice_id]
p_optim = p
c(sse1, etahat, ahatc, face, qv, edf, edfs, gcv, gcvs, sighat, edfu_use, covmat, covmat_inv, phi1, mat1) %<-% gcvs_rslt[[choice_id]][1:15]
}
etahat = as.matrix(etahat)
muhat = family$linkinv(etahat)
#only for H1 fit
} else {
#lams = ps
if(is.null(ps)){
#edfu = sum(edfu_vec) + nz
edfu = edfu_vec
if(nz > 0){
edfu[1] = edfu_vec[1] + nz
}
#if(!arp){
if(capl == 1){
#ps = uniroot(f = .search_ps, qv0 = qv0, dv = dv, dd = dd, edfu = edfu, interval = c(1e-10, 2e+2), tol = .Machine$double.eps^0.32)$root
ps = uniroot(f = .search_ps, qv0 = qv0, dv = dv, dd = dd, edfu = edfu, interval = c(1e-10, 2e+2), tol=1e-6)$root
#test!
#if(arp & p >= 1){
#print (ps)
#ps = ps * 0.6 #1/2 (2/3) will be unbiased for p=2 but inflated for p=1, 2/3 is inflated for p=1
#print (ps)
#}
} else if (capl > 1) {
ps = NULL
for(ic in 1:capl){
dd_ic = dd_lst[[ic]]
qv0_ic = crossprod(dd_ic)
dm_ic = dmat_lst[[ic]]
dv_ic = crossprod(dm_ic)
#psi = uniroot(f = .search_ps, qv0 = qv0_ic, dv = dv_ic, dd = dd_ic, edfu = edfu[ic], interval = c(1e-10, 2e+2), tol = .Machine$double.eps^0.32)$root
psi = uniroot(f = .search_ps, qv0 = qv0_ic, dv = dv_ic, dd = dd_ic, edfu = edfu[ic], interval = c(1e-10, 2e+2), tol=1e-6)$root
ps = c(ps, psi)
}
#ps = sapply(1:capl, function(ic)uniroot(f = .search_ps, qv0 = crossprod(dd_lst[[ic]]), dv = crossprod(dmat_lst[[ic]]), dd = dd_lst[[ic]], edfu = edfu[ic], interval = c(1e-10, 2e+2), tol = .Machine$double.eps^0.32)$root)
}
#}else{
#ps = 2/n^(2*spl_ord/(2*spl_ord+1)) #seems working
# ps = 1/n^(2*spl_ord/(2*spl_ord+1)) #a little inflated
#}
}
lams = ps
covmat = covmat_inv = phi = NULL
#new:
if(length(ps) >= 1){
for(ic in 1:capl){
dmat_lst[[ic]] = sqrt(ps[ic]) * dmat_lst[[ic]]
}
#already add zmat in the 1st element of dmat_lst
dmat = Matrix::bdiag(dmat_lst) |> as.matrix()
#recreate dmat
# if(nz > 0){
# dmat_zero = matrix(0, nrow = nrow(dmat), ncol = nz)
# dmat = cbind(dmat_zero, dmat)
# }
dv = crossprod(dmat)
}
if(length(p) == 1){
#arp with user-defined order, or !arp and p=0
#cat('call arp with user-defined order, ps=', ps, '\n')
ansc = fit.hypo(p=p, dd=dd, y=y, amat=amat, bvec=bvec, dv=dv, family=family, ps=ps, arp=arp)
c(sse1, etahat, ahatc, face, qv, edf, edfs, gcv, gcvs, sighat, edfu_use, covmat, covmat_inv, phi1, mat1) %<-% ansc[1:15]
p_optim = p
} else{
#p = 0:2
#new: test p=0 first
ansc = fit.hypo(p=0, dd=dd, y=y, amat=amat, bvec=bvec, dv=dv, family=family, ps=ps, arp=FALSE)
if(ansc$pval.ts > 0.05){
c(sse1, etahat, ahatc, face, qv, edf, edfs, gcv, gcvs, sighat, edfu_use, covmat, covmat_inv, phi1, mat1) %<-% ansc[1:15]
p_optim = 0
}else{
aic_rslt = parallel::mclapply(p[-1], fit.hypo, dd=dd, y=y, amat=amat, bvec=bvec, dv=dv, family=family, ps=ps, arp=arp, mc.cores=(8L))
aics = sapply(aic_rslt, function(rslti) rslti$aic, simplify = TRUE)
#print (aics)
choice_id = which(aics == min(aics))
p_optim = (p[-1])[choice_id]
c(sse1, etahat, ahatc, face, qv, edf, edfs, gcv, gcvs, sighat, edfu_use, covmat, covmat_inv, phi1, mat1) %<-% (aic_rslt[[choice_id]])[1:15]
}
}
muhat = family$linkinv(etahat)
}
#----------------------------------------------------------------------------
#1.get H0 fit: linear space satisfying some shape constraint
#use sparse matrix later
#write a new function: fit.null
#----------------------------------------------------------------------------
wmat = x1m0 = x1m = NULL
if(!use_constreg){
pm0 = xm0 %*% solve(crossprod(xm0), t(xm0))
#x1m0 = dd - pm0 %*% dd
# nc = ncol(dd)
# qr_dd = qr(dd)
# dd_r = qr_dd$rank
# if(dd_r < nc){
# dd_2 = qr.Q(qr_dd, complete = TRUE)[, 1:dd_r]
# rm_id = qr_dd$pivot[(dd_r+1):nc]
# x1m0 = dd_2 - pm0 %*% dd_2
# }else{
x1m0 = dd - pm0 %*% dd
#}
qr_x1m = qr(x1m0)
x1m = qr.Q(qr_x1m, complete = TRUE)[, 1:qr_x1m$rank]
# if(dd_r < nc){
# xm1tb = crossprod(x1m, dd_2)
# } else {
xm1tb = crossprod(x1m, dd)
#}
qr_xm1tb = qr(t(xm1tb))
wmat = qr.Q(qr_xm1tb, complete = TRUE)[, -c(1:qr_xm1tb$rank), drop = FALSE]
# if(dd_r < nc){
# ddwm = dd_2 %*% wmat
# awmat = amat[,-rm_id] %*% wmat
# }else {
ddwm = dd %*% wmat
awmat = amat %*% wmat
#}
} else {
ddwm = xm0
awmat = Matrix::bdiag(awmat_lst) |> as.matrix()
}
if(nz > 0){
#add z before splines
ddwm = cbind(zmat, ddwm)
awmat_zero = matrix(0, nrow = nrow(awmat), ncol = nz)
awmat = cbind(awmat_zero, awmat)
}
ansl = fit.hypo(p=p_optim, dd=ddwm, y=y, amat=awmat, bvec=rep(0, nrow(awmat)), dv=NULL, family=family, ps=0, arp=arp)
sse0 = ansl$dev
etahat0 = ansl$etahat
muhat0 = family$linkinv(etahat0)
ahatl = ansl$ahat
qvl = ansl$qv
#cat(arp, '\n')
#----------------------------------------------------------------------------
#test: H0 vs H1
#----------------------------------------------------------------------------
if(wt.iter){
bval = (sse0 - sse1) / n #sse0 is llh0; sse1 is llh1
} else {
bval = (sse0 - sse1) / sse0
}
#temp
sm=1e-7
#sm = 1e-9
if (bval > sm) {
if (multicore) {
bdist = parallel::mclapply(1:nsim, .compute_bstat, etahat0=etahat0, n=n, sighat=sighat,
dd=dd, ddwm=ddwm, qv=NULL, qvl=NULL, amat=amat, awmat=awmat,
bvec=bvec, imat=imat, dv=dv, lams=ps, w=NULL, arp=arp, p=p_optim, phi=phi1,
family=family, mc.cores=(4L))
} else {
bdist = lapply(1:nsim, .compute_bstat, etahat0=etahat0, n=n, sighat=sighat, dd=dd, ddwm=ddwm, qv=NULL, qvl=NULL,
amat=amat, awmat=awmat, bvec=bvec, imat=imat, dv=dv, lams=ps, w=NULL, arp=arp, p=p_optim, phi=phi1, family=family)
}
bdist = simplify2array(bdist)
pval = sum(bdist > bval) / nsim
} else {
pval = 1
}
#----------------------
#for visualization
#----------------------
etacomps = etacomps0 = vector("list", length = capl)
etahat0_surf = etahat_surf = NULL
muhat0_surf = muhat_surf = NULL
ahatc_noz = round(ahatc, 6) |> as.matrix()
ahatl_noz = round(ahatl, 6) |> as.matrix()
#print (ahatc_noz)
#print (nz)
if(nz > 0){
#print (dim(ahatc_noz))
ahatc_noz = ahatc_noz[-c(1:nz), ,drop=F] #|> as.vector()
ahatl_noz = ahatl_noz[-c(1:nz), ,drop=F] #|> as.vector()
#new:
dd_1 = dd_lst[[1]]
dd_1 = dd_1[, -c(1:nz), drop=F]
dd_lst[[1]] = dd_1
}
for(icomp in 1:capl){
x = X[[icomp]]
if(NCOL(x) == 1){
#print (dim(dd_lst[[icomp]]))
#print (dim(ahatc_noz[var_track == icomp]))
etahat_icomp = dd_lst[[icomp]] %*% ahatc_noz[var_track == icomp,,drop=F]
#print (dim(etahat_icomp))
etacomps[[icomp]] = etahat_icomp
}
if(NCOL(x) == 2){
kts = kts_lst[[icomp]]
k1 = kts$k1
k2 = kts$k2
newd = expand.grid(k1, k2)
newd = as.matrix(newd)
#H0 surface
x1p = newd[,1]
x2p = newd[,2]
if(attr(x, "parametric") == "warped_plane"){
xm0p = cbind(1, x1p, x2p, x1p*x2p)
if(icomp > 1){
xm0p = xm0p[, -1]
}
}
if(attr(x, "parametric") == "linear"){
xm0p = cbind(1, x1p, x2p)
if(icomp > 1){
xm0p = xm0p[, -1]
}
}
#if(nz == 0){
#print (dim(xm0p))
#print (length(ahatl_noz))
#print (icomp)
psurf0 = xm0p %*% ahatl_noz[var_track_param == icomp,,drop=F]
# } else if (nz > 0){
# psurf0 = xm0p %*% ahatl[-((ncol(xm0p) + 1):(ncol(xm0p) + nz))]
# }
etahat0_surf = matrix(psurf0, m1, m2)
muhat0_surf = family$linkinv(etahat0_surf)
#H1 surface
pans = makedelta_wps(newd[,1], newd[,2], k1 = k1, k2 = k2, decreasing = c(FALSE, FALSE))
ddp = pans$delta
if(icomp > 1){
ddp = ddp[, -1]
}
#if(nz == 0){
psurf = ddp %*% ahatc_noz[var_track == icomp,,drop=F]
# } else {
# psurf = ddp %*% ahatc[-((nc_noz + 1):(nc_noz + nz))]
# }
etahat_surf = matrix(psurf, m1, m2)
muhat_surf = family$linkinv(etahat_surf)
etacomps[[icomp]] = etahat_surf
etacomps0[[icomp]] = etahat0_surf
}
}
rslt = list(pval = pval, bval = bval, knots = kts, k1=k1, k2=k2, bmat = dd, wmat = wmat, dmat = dmat, ps = ps,
xm0 = xm0, x1m = x1m, amat = amat, awmat = awmat, face = face, etahat = etahat, etahat0 = etahat0,
etahat0_surf = etahat0_surf, etahat_surf = etahat_surf, muhat0_surf = muhat0_surf, muhat_surf = muhat_surf,
sighat = sighat, edf = edf, edfu = edfu_use, lams = lams, gcvs = gcvs, edfs = edfs, ahatl = ahatl, ahatc = ahatc,
phi = phi1, covmat = covmat, covmat_inv = covmat_inv, etacomps = etacomps, p_optim = p_optim, kts_lst = kts_lst,
var_track = var_track, var_track_param = var_track_param, etacomps0 = etacomps0)
if(nz >= 1){
#assume y is iid with common sig2
if(!wt.iter){
#should work for ar(p)?
if(!arp || arp & p_optim == 0){
covmat0 = sighat^2 * mat1 %*% t(mat1)
} else {
#print (sig2hat_z)
#covmat0 = sig2hat_z * mat1 %*% t(mat1)
covmat0 = mat1 %*% t(mat1) #seems working with unscaled covariance
#covmat0 = sighat^2 * mat1 %*% t(mat1)
}
} else {
wt = wt.fun(y, etahat, n, weights = rep(1, n), fml = family$family)
covmat0 = mat1 %*% diag(wt) %*% t(mat1)
}
covmat = covmat0[(1):(nz), (1):(nz), drop=FALSE]
sez = sqrt(diag(covmat))
zcoefs = ahatc[(1):(nz)]
tz = zcoefs / sez
cpar = 1.2
#test more!
if(!wt.iter){
if ((n - cpar * edf) <= 0) {
pz = 2*(1 - pt(abs(tz), edf))
} else {
#why not pnorm?
pz = 2*(1 - pt(abs(tz), n - cpar * edf))
}
} else {
#why not pnorm?
pz = 2*(1 - pnorm(abs(tz)))
}
rslt$sez = sez
rslt$pz = pz
rslt$tz = tz
rslt$zcoefs = zcoefs
} else {rslt$sez = NULL; rslt$pz = NULL; rslt$tz = NULL; rslt$zcoefs = NULL}
return(rslt)
}
Try the cgam package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.