Skip to content

Commit

Permalink
..
Browse files Browse the repository at this point in the history
  • Loading branch information
@cdriveraus
cdriveraus committed May 3, 2023
1 parent 4ef60de commit 66f9521
Show file tree
Hide file tree
Showing 3 changed files with 29 additions and 24 deletions.
20 changes: 11 additions & 9 deletions R/ctModel.R
View file
Expand Up @@ -141,6 +141,8 @@
#' covariances are generated by ctFit.
#' Better starting values may improve model fit speed and the chance of an appropriate model fit.
#'
#' @param silent Suppress all output to console.
#'
#' @examples
#' ### Frequentist example:
#' ### impulse and level change time dependent predictor
Expand Down Expand Up @@ -176,7 +178,7 @@
#' @export

ctModel<-function(LAMBDA, type='omx',n.manifest = 'auto', n.latent='auto', Tpoints=NULL,
manifestNames='auto', latentNames='auto', id='id',time='time',
manifestNames='auto', latentNames='auto', id='id',time='time', silent=FALSE,
T0VAR="auto", T0MEANS="auto", MANIFESTMEANS="auto", MANIFESTVAR="auto",
DRIFT="auto", CINT="auto", DIFFUSION="auto",
n.TDpred='auto', TDpredNames='auto',
Expand All @@ -194,12 +196,12 @@ ctModel<-function(LAMBDA, type='omx',n.manifest = 'auto', n.latent='auto', Tpoin
#get dimensions
if(is.null(n.manifest) || is.null(n.latent) || all(n.manifest %in% 'auto') || all(n.latent %in% 'auto')){
if(is.matrix(LAMBDA)){
message('System dimensions inferred from LAMBDA')
if(!silent) message('System dimensions inferred from LAMBDA')
n.manifest <- nrow(LAMBDA)
n.latent <- ncol(LAMBDA)
} else {
if(!all(manifestNames %in% 'auto') && !all(latentNames %in% 'auto')){
message('System dimensions inferred from manifestNames and latentNames')
if(!silent) message('System dimensions inferred from manifestNames and latentNames')
n.manifest <- length(manifestNames)
n.latent <- length(latentNames)
} else stop('LAMBDA must either a matrix, n.manifest and n.latent must be specified, or manifestNames and latentNames must be specified!')
Expand All @@ -208,19 +210,19 @@ ctModel<-function(LAMBDA, type='omx',n.manifest = 'auto', n.latent='auto', Tpoin

if(is.null(n.TDpred) || all(n.TDpred %in% 'auto')){
if(is.matrix(TDPREDEFFECT)){
message('n.TDpred inferred from TDPREDEFFECT')
if(!silent) message('n.TDpred inferred from TDPREDEFFECT')
n.TDpred <- ncol(TDPREDEFFECT)
} else {
if(!all(TDpredNames %in% 'auto')){
message('n.TDpred inferred inferred from TDpredNames')
if(!silent) message('n.TDpred inferred inferred from TDpredNames')
n.TDpred <- length(TDpredNames)
} else n.TDpred <- 0
}
}

if(is.null(n.TIpred) || all(n.TIpred %in% 'auto')){
if(!all(TIpredNames %in% 'auto')){
message('n.TIpred inferred inferred from TIpredNames')
if(!silent) message('n.TIpred inferred inferred from TIpredNames')
n.TIpred <- length(TIpredNames)
} else n.TIpred <- 0
}
Expand Down Expand Up @@ -288,17 +290,17 @@ ctModel<-function(LAMBDA, type='omx',n.manifest = 'auto', n.latent='auto', Tpoin
counter <- 0 #then start filling with vector
if(length(val) != length(mat) && length(val) !=1) stop(paste0(m,' needs ',length(mat),' values for ',nrow(mat),' * ',ncol(mat),' matrix, but has ',length(val)))
if(length(val)==1 && length(mat) > 1) {
message(m,' specified via single value -- filling ',nrow(mat),' * ',ncol(mat),' matrix:')
if(!silent) message(m,' specified via single value -- filling ',nrow(mat),' * ',ncol(mat),' matrix:')
val <- rep(val,length(mat))
} else message(paste0(m,' vector spec input rowwise into ',nrow(mat),' * ',ncol(mat),' matrix:'))
} else if(!silent) message(paste0(m,' vector spec input rowwise into ',nrow(mat),' * ',ncol(mat),' matrix:'))
for(ri in 1:nrow(mat)){
for(ci in 1:ncol(mat)){
counter <- counter + 1
mat[ri,ci] <- val[counter]
}
}

print(mat,right=TRUE)
if(!silent) print(mat,right=TRUE)
assign(m, mat)
}
}
Expand Down
3 changes: 3 additions & 0 deletions man/ctModel.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

30 changes: 15 additions & 15 deletions tests/testthat/test-tdeffectvariation_covtest.R
View file
Expand Up @@ -15,7 +15,7 @@ if(identical(Sys.getenv("NOT_CRAN"), "true")& .Machine$sizeof.pointer != 4){
effect <- rnorm(nsubjects, 5-baseline/3, 0.5)

for(i in 1:nsubjects){
gm <- suppressMessages(ctModel(Tpoints=ntimes,
gm <- suppressMessages(ctModel(silent=TRUE,Tpoints=ntimes,
LAMBDA=matrix(c(1,0),1,2),
DRIFT= c(-1,1,
0,-.5),
Expand All @@ -33,7 +33,7 @@ if(identical(Sys.getenv("NOT_CRAN"), "true")& .Machine$sizeof.pointer != 4){
}

#regular bw effect approach
m <- ctModel(type='stanct',
m <- ctModel(silent=TRUE,type='stanct',
LAMBDA=matrix(c(1,0),1,2),
DRIFT= c('drift',1,
0,-0.5),
Expand All @@ -43,7 +43,7 @@ if(identical(Sys.getenv("NOT_CRAN"), "true")& .Machine$sizeof.pointer != 4){
TDPREDEFFECT = matrix(c(0,'tdpredeffect|param|TRUE')))

#manual bw effects
m2 <- ctModel(type='omx',Tpoints=3,
m2 <- ctModel(silent=TRUE,type='omx',Tpoints=3,
LAMBDA=matrix(c(1,0,0,0),1,4),
DRIFT= c('drift',1,0,0,
0,-0.5,0,0,
Expand Down Expand Up @@ -143,7 +143,7 @@ if(identical(Sys.getenv("NOT_CRAN"), "true")& .Machine$sizeof.pointer != 4){
effect <- rnorm(nsubjects, 5-baseline/3, 0.5)

for(i in 1:nsubjects){
gm <- suppressMessages(ctModel(Tpoints=ntimes,
gm <- suppressMessages(ctModel(silent=TRUE,Tpoints=ntimes,
LAMBDA=matrix(c(1,effect[i]),1,2),
DRIFT= c(-1,0,
0,-.5),
Expand All @@ -161,7 +161,7 @@ if(identical(Sys.getenv("NOT_CRAN"), "true")& .Machine$sizeof.pointer != 4){
}

#regular bw effect approach
m <- ctModel(type='stanct',
m <- ctModel(silent=TRUE,type='stanct',
LAMBDA=matrix(c(1,'tdpredeffect|param|TRUE'),1,2),
DRIFT= c('drift',0,
0,-0.5),
Expand All @@ -171,7 +171,7 @@ if(identical(Sys.getenv("NOT_CRAN"), "true")& .Machine$sizeof.pointer != 4){
TDPREDEFFECT = matrix(c(0,1)))

#manual bw effects
m2 <- ctModel(type='omx',Tpoints=3,
m2 <- ctModel(silent=TRUE,type='omx',Tpoints=3,
LAMBDA=matrix(c(1,'state[4]',0,0),1,4),
DRIFT= c('drift',0,0,0,
0,-0.5,0,0,
Expand Down Expand Up @@ -268,7 +268,7 @@ if(identical(Sys.getenv("NOT_CRAN"), "true")& .Machine$sizeof.pointer != 4){
effect <- -log1p(exp(-raweffect))

for(i in 1:nsubjects){
gm <- suppressMessages(ctModel(Tpoints=ntimes,
gm <- suppressMessages(ctModel(silent=TRUE,Tpoints=ntimes,
LAMBDA=matrix(1),
DRIFT= c(effect[i]),
T0MEANS = c(t0m[i]),
Expand All @@ -283,12 +283,12 @@ if(identical(Sys.getenv("NOT_CRAN"), "true")& .Machine$sizeof.pointer != 4){
}

#regular bw effect approach
m <- ctModel(type='stanct',
m <- ctModel(silent=TRUE,type='stanct',
CINT='cint',MANIFESTMEANS=0,
LAMBDA=matrix(1),DRIFT='drift|-log1p_exp(-param)|TRUE')

#manual bw effects
m2 <- ctModel(type='omx',Tpoints=3,
m2 <- ctModel(silent=TRUE,type='omx',Tpoints=3,
LAMBDA=matrix(c(1,0,0),ncol=3),
DRIFT= c('-log1p_exp(-state[2])',0,0,
0,-1e-6,0,
Expand Down Expand Up @@ -388,7 +388,7 @@ if(identical(Sys.getenv("NOT_CRAN"), "true")& .Machine$sizeof.pointer != 4){
effect <- log1p(exp(raweffect))

for(i in 1:nsubjects){
gm <- suppressMessages(ctModel(Tpoints=ntimes,
gm <- suppressMessages(ctModel(silent=TRUE,Tpoints=ntimes,
LAMBDA=matrix(1),
DRIFT= -1,
T0MEANS = c(t0m[i]),
Expand All @@ -404,14 +404,14 @@ if(identical(Sys.getenv("NOT_CRAN"), "true")& .Machine$sizeof.pointer != 4){
}

#regular bw effect approach
m <- ctModel(type='stanct',
m <- ctModel(silent=TRUE,type='stanct',
T0MEANS='t0m|param',
MANIFESTVAR=.5,
MANIFESTMEANS=0,CINT='cint|param',
LAMBDA=matrix(1),DIFFUSION='diffusion|log1p_exp(param)|TRUE')

#manual bw effects
m2 <- ctModel(type='omx',Tpoints=3,
m2 <- ctModel(silent=TRUE,type='omx',Tpoints=3,
LAMBDA=matrix(c(1,0,0),ncol=3),
DRIFT= c('drift',0,0,
0,-1e-12,0,
Expand Down Expand Up @@ -521,7 +521,7 @@ if(identical(Sys.getenv("NOT_CRAN"), "true")& .Machine$sizeof.pointer != 4){
effect <- log1p(exp(raweffect))

for(i in 1:nsubjects){
gm <- suppressMessages(ctModel(Tpoints=ntimes,
gm <- suppressMessages(ctModel(silent=TRUE,Tpoints=ntimes,
LAMBDA=matrix(1),
DRIFT= -1,
T0MEANS = c(t0m[i]),
Expand All @@ -537,14 +537,14 @@ if(identical(Sys.getenv("NOT_CRAN"), "true")& .Machine$sizeof.pointer != 4){
}

#regular bw effect approach
m <- ctModel(type='stanct',
m <- ctModel(silent=TRUE,type='stanct',
T0MEANS='t0m|param',
DIFFUSION=.5,
MANIFESTMEANS=0,CINT='cint|param',
LAMBDA=matrix(1),MANIFESTVAR='errsd|log1p_exp(param)|TRUE')

#manual bw effects
m2 <- ctModel(type='omx',Tpoints=3,
m2 <- ctModel(silent=TRUE,type='omx',Tpoints=3,
LAMBDA=matrix(c(1,0,0),ncol=3),
DRIFT= c('drift',0,0,
0,-1e-12,0,
Expand Down

0 comments on commit 66f9521

Please sign in to comment.