#' Coerce to init
#'
#' Coerces to init
#' @param x object
#' @param ... dots
#' @export
#' @family as.init
#' @keywords internal
as.init <- function(x,...)UseMethod('as.init')
#' Coerce init to init
#'
#' Coerces init to init
#' @param x init
#' @param fixed logical
#' @param comment character
#' @param ... passed arguments
#' @return init
#' @family as.init
#' @export
as.init.init <- function(x=numeric(0),fixed=FALSE,comment=character(0),...)as.init.numeric(x=x,fixed=fixed,comment=comment,...)
#' Coerces numeric to init
#' @param x numeric
#' @param fixed logical
#' @param comment character
#' @param ... ignored
#' @return init
#' @keywords internal
#' @export
#' @family as.init
as.init.numeric <- function(x=numeric(0),fixed=FALSE,comment=character(0),...){
#x may be one,two, or three values
#init, low/init, or low/init/up
stopifnot(length(x)<=3,is.logical(fixed),inherits(comment,'character'))
y <- c(-Inf,NA,Inf)
names(y) <- c('low','init','up')
class(y) <- c('init',class(y))
if(length(x)==1)y['init'] <- x
if(length(x)==2)y[c('low','init')] <- x
if(length(x)==3)y[c('low','init','up')] <- x
if(is.na(y['low']))y['low'] <- -Inf
if(is.na(y['up']))y['up'] <- Inf
if(y['low'] > y['up']) stop('lower bound must not be greater than upper bound')
if(!is.na(y['init']))stopifnot(y['low'] <= y['init'],y['init'] <= y['up'])
if(fixed & is.na(y['init']))stop('initial cannot be fixed if missing')
# if(!fixed & !is.na(y['init']) & y['init'] == 0)warning('initial should be fixed if zero\n')
if(fixed) y[c('low','init','up')] <- y['init']
if(length(comment))comment(y) <- comment
y
}
#' Coerce init to character
#'
#' Coerces init to character.
#' @param x init
#' @param ... ignored
#' @return character
#' @export
#' @family as.character
#' @keywords internal
as.character.init <- function(x,...){
fixed <- x['low']==x['init'] & x['init']==x['up']
com <- comment(x)
if(is.na(fixed))fixed <- FALSE
if(!is.na(x['init']) & all(is.infinite(x[c('low','up')]))) x <- x['init']
if(!is.na(x['init']) & is.infinite(x['up'])) x <- x[c('low','init')]
x[] <- sapply(x,toupper)
x[is.na(x)] <- ''
if(fixed) x <- x['init']
len <- length(x)
y <- paste(x,collapse=',')
if(len>1) y <- parens(y)
if(fixed) y <- paste(y,'FIXED')
if(!is.null(com)) {
com <- as.character(com)
if(length(com)==1)y <- paste(y,com, sep='; ')
if(length(com)>1){
com <- paste('; ',com)
y <- c(y,com)
}
}
y
}
#' Format init
#'
#' Formats init.
#' @param x init
#' @param ... passed arguments
#' @return character
#' @export
#' @family format
#' @keywords internal
format.init <-function(x,...)as.character(x,...)
#' Print init
#'
#' Prints init.
#' @param x init
#' @param ... passed arguments
#' @return character
#' @export
#' @family print
#' @keywords internal
print.init <-function(x,...)print(format(x,...))
#' Check if something is fixed
#'
#' Checks if something is fixed
#' @param x object
#' @param ... passed arguments
#' @export
#' @family fixed
#' @keywords internal
fixed <- function(x,...)UseMethod('fixed')
#' Set value of fixed attribute
#'
#' Sets value of fixed attribute.
#' @param x object
#' @param value value to set
#' @export
#' @family fixed
#' @keywords internal
`fixed<-` <- function(x,value)UseMethod('fixed<-')
#' Check if init is fixed
#'
#' Checks if init is fixed.
#' @param x init
#' @return logical
#' @param ... ignored
#' @export
#' @family fixed
fixed.init <- function(x,...)!any(is.na(x)) & length(unique(x)) == 1
#' Set fixed init value
#'
#' Sets fixed init value.
#' @param x object
#' @param value value to
#' @return init
#' @export
#' @family fixed
#' @keywords internal
`fixed<-.init` <- function(x,value){
stopifnot(is.logical(value))
if(is.na(value))stop('NA found where logical required')
if(fixed(x)==value)return(x)
if(is.na(x['init']))stop("cannot alter 'fixed' for a missing value")
if(value)x[c('low','init','up')] <- x['init']
else{
#user has requested 'not fixed' on something that is 'fixed'
x['low'] <- -Inf
x['up'] <- Inf
}
x
}
#' Coerce to inits
#'
#' Coerces to inits.
#' @param x object
#' @param ... dots
#' @export
#' @family as.inits
#' @keywords internal
as.inits <- function(x,...)UseMethod('as.inits')
#' Coerce list to inits
#'
#' Coerces list to inits.
#' @param x list
#' @param ... passed arguments
#' @param comment character
#' @return inits
#' @export
#' @family as.inits
as.inits.list <- function(x,comment=character(0),...){
stopifnot(length(x)>0,is.character(comment))
is.init <- sapply(x,inherits,'init') ## test?
class(x) <- c('inits',class(x))
comment(x) <- if(length(comment))comment else '' # NA_character_
x
}
#' Coerce inits to character
#'
#' Coerces inits to character.
#' @param x inits
#' @param ... passed arguments
#' @return character
#' @export
#' @family as.character
#' @keywords internal
as.character.inits <- function(x,pretty = TRUE, sep = ';', delim = ' ; ', widths = comwidth(x), ...){
block <- attr(x, 'block')
com <- comment(x)
padded <- attr(x,'padded')
if(is.null(padded)) padded <- FALSE
if(!is.null(com))if(!is.na(com))if(com != '') com <- paste(sep,com)
y <- c(com,unlist(lapply(x,as.character)))
if(padded) y <- c(y,rep('',padded))
if(!is.null(block))if(block) y[[1]] <- paste(y[[1]], paste0('BLOCK',parens(block)))
if(pretty) y <- sapply(y,prettycom, widths, sep = sep, delim = delim, ...)
y
}
#' Coerce Items to Character
#'
#' Coerces items to character.
#' @param x items
#' @param pretty logical
#' @param sep input delimiter
#' @param delim output delimiter
#' @param widths desired widths
#' @param ... passed arguments
#' @return character
#' @keywords internal
#' @export
#' @family as.character
as.character.items <- function(x,pretty = TRUE, sep = ';', delim = ' ; ', widths = comwidth(x), ...){
y <- attr(x,'text')
if(pretty) y <- sapply(y,prettycom, widths, sep = sep, delim = delim, ...)
y
}
#' Calculate Comment Widths for Items
#'
#' Calculates comment widths for items
#' @param x object
#' @param ... passed arguments
#' @export
#' @family comwidth
#' @keywords internal
comwidth.items <- function(x, ...){
y <- attr(x,'text')
z <- comwidth(y)
z
}
#' Calculate Comment Widths for Inits
#'
#' Calculates comment widths for inits
#' @param x object
#' @param ... passed arguments
#' @export
#' @family comwidth
#' @keywords internal
comwidth.inits <- function(x, ...){
com <- comment(x)
y <- c(com,unlist(lapply(x,as.character)))
z <- comwidth(y)
z
}
#' Calculate Comment Widths
#' Calculates comment widths.
#' @param x object
#' @param ... passed arguments
#' @export
#' @family comwidth
#' @keywords internal
comwidth <- function(x,...)UseMethod('comwidth')
#' Calculate Comment Widths for Character
#'
#' Calculates comment widths for character.
#' @param x object
#' @param ... passed arguments
#' @export
#' @family comwidth
#' @keywords internal
comwidth.character <- function(x,...){
y <- lapply(x,comwidthOne)
w <- maxWidths(y,...)
w
}
#' Calculate Maximum Widths
#'
#' Calculates maximum widths
#' @param x object
#' @param ... passed arguments
#' @export
#' @family maxWidths
#' @keywords internal
maxWidths <- function(x,...)UseMethod('maxWidths')
#' Calculate Maximum Widths for List
#'
#' Calculates maximum widths for list
#' @param x object
#' @param ... passed arguments
#' @export
#' @family maxWidths
#' @keywords internal
maxWidths.list <- function(x,...){
if(length(x) == 0) return(0)
maxlen <- max(sapply(x,length))
for(i in seq_along(x)){
len <- length(x[[i]])
for(j in seq_len(maxlen - len)){
x[[i]] <- c(x[[i]], 0)
}
}
w <- do.call(cbind,x)
w <- apply(w,1,max)
w
}
#' Calculate Comment Widths for One Element
#'
#' Calculates comment widths for one element.
#' @param x object
#' @param ... passed arguments
#' @export
#' @family comwidthOne
#' @keywords internal
comwidthOne <- function(x,...)UseMethod('comwidthOne')
#' Calculate Comment Widths for One Element of Character
#'
#' Calculates Comment Widths for one element of character
#' @param x object
#' @param ... passed arguments
#' @param split comment separator
#' @export
#' @family comwidthOne
#' @keywords internal
comwidthOne.character <- function(x,split = ';', ...){
if(!grepl(split, x)) return(0)
y <- strsplit(x, split = split)[[1]]
y <- sub('^\\s+', '', y)
y <- sub('\\s+$', '', y)
z <- sapply(y, nchar)
z <- as.integer(z)
z
}
#' Pretty-print a Comment
#'
#' Pretty-prints a comment.
#' @param x object
#' @param ... passed arguments
#' @export
#' @family prettycom
#' @keywords internal
prettycom <- function(x, ...)UseMethod('prettycom')
#' Pretty-print a Comment for Character
#'
#' Pretty-prints a comment for character.
#' @param x ... object
#' @param widths integer
#' @param sep input separator
#' @param delim output separator
#' @param ... passed arguments
#' @export
#' @family prettycom
#' @keywords internal
prettycom.character <- function(x, widths, sep, delim, ...){
stopifnot(length(x) == 1)
y <- strsplit(x, sep)[[1]]
y <- sub('^\\s+', '', y)
y <- sub('\\s+$', '', y)
stopifnot(length(widths) >= length(y))
for(i in seq_along(y)){
have <- nchar(y[[i]])
need <- widths[[i]]
pad <- need - have
pad <- max(pad, 0)
tail <- rep(' ',pad)
tail <- paste(tail, collapse = '')
y[[i]] <- paste0(y[[i]], tail)
}
z <- paste(y, collapse = delim)
z
}
#' Format inits
#'
#' Formats inits.
#' @param x inits
#' @param ... passed arguments
#' @return character
#' @export
#' @family format
#' @keywords internal
format.inits <-function(x,...)as.character(x,...)
#' Print inits
#'
#' Prints inits.
#' @param x inits
#' @param ... passed arguments
#' @return character
#' @export
#' @family print
#' @keywords internal
print.inits <-function(x,...)print(format(x,...))
.comments <- function(x)sub('^[^;]*;?(.*)$','\\1',x)
.space2comma <- function(x){
if(!length(x))return(x)
x[[1]] <- gsub(' ',',',x[[1]])
x
}
.explicit <- function(x){
halves <- strsplit(x,')',fixed=TRUE)
halves <- lapply(halves,.space2comma)
}
#' Subset inits
#'
#' Subsets inits.
#' @param x inits
#' @param ... passed arguments
#' @param drop logical
#' @return inits
#' @export
#' @family inits
#' @keywords internal
`[.inits` <- function (x, ..., drop = TRUE){
cl <- oldClass(x)
class(x) <- NULL
val <- NextMethod("[")
class(val) <- cl
val
}
#' Coerce numeric to inits
#'
#' Coerces numeric to inits
#' @param x numeric
#' @param fixed logical
#' @param comment character
#' @return inits
#' @keywords internal
#' @export
#' @family as.inits
as.inits.numeric <- function(x,fixed=FALSE,comment=character(0),...){
stopifnot(is.logical(fixed),is.character(comment))
fixed <- rep(fixed,length.out=length(x))
y <- lapply(
seq_along(x),
function(i)as.init(x[[i]],fixed=fixed[[i]])
)
y <- as.inits(y)
if(length(comment)) comment(y) <- comment
y
}
#' Select init element
#'
#' Selects init element.
#' @param x init
#' @param name character
#' @return numeric
#' @export
#' @family init
#' @keywords internal
`$.init` <- function(x,name)x[[name]]
#' Set init element
#'
#' Sets init element.
#' @param x init
#' @param name character
#' @param value numeric
#' @return init
#' @export
#' @family init
#' @keywords internal
`$<-.init` <- function(x,name,value){
if(!name %in% c('low','init','up'))stop('attempt to set an invalid init element')
if(is.null(value))stop('attempt to delete a required init element')
x[name] <- value
x
}
#' Check if inits is fixed
#'
#' Checks if inits is fixed.
#' @param x inits
#' @param ... ignored
#' @return logical
#' @describeIn fixed inits method
#' @export
#' @family fixed
fixed.inits <- function(x,...)sapply(x,fixed)
#' Set fixed attribute of inits
#'
#' Sets fixed attribute of inits.
#' @param x inits
#' @param value logical
#' @return inits
#' @export
#' @family fixed
#' @keywords internal
`fixed<-.inits` <- function(x,value){
stopifnot(is.logical(value))
value <- rep(value,length.out=length(x))
for(i in seq_along(value))fixed(x[[i]]) <- value[[i]]
x
}
.initcomments <- function(x)sub('^[^;]*;?(.*)$','\\1',x)
.initdata <- function(x)sub(';.*','',x)
.initEstimateNum <- function(x){
# an estimate is initiated by a parenthesis, or by a qualifying character.
# a qualifying character is a numeric or reserved char.
# if initiated by parenthesis, it is closed by parenthesis, else by next
# qualifying character
# only 0123456789.-+eI( can initiate an estimate. For (, only ) can close it.
# For the others, the first space or newline ends the numeric region.
y <- numeric(0)
openers <- c('0','1','2','3','4','5','6','7','8','9','.','-','+','(')
closers <- c(' ','\n','\t') #or end of vector
region <- 0
parenthetical <- FALSE
active <- FALSE
for(i in x){
if(!active){
if(i %in% openers){
region <- region + 1
active <- TRUE
}
}else{
if(parenthetical){
if(i==')') active <- FALSE
}else{
if(i %in% closers) active <- FALSE
}
}
if(i=='(')parenthetical <- TRUE
if(i==')')parenthetical <- FALSE
y <- append(y,region)
}
y
}
.initLineNum <- function(x){
newline <- x=='\n'
#I am the first character in a line if I follow a newline, or if I am the veryfirst character.
frst <- lag(newline)
frst[is.na(frst)] <- TRUE
linenum <- cumsum(frst)
linenum
}
#' Coerce character to inits
#'
#' Coerces character to inits.
#' @param x character
#' @param ... ignored
#' @return inits
#' @describeIn as.inits character method
#' @export
#' @family as.inits
as.inits.character <- function(x,...){
# final empty line is scrubbed by collapse=\n
# chomp all line endings, count and store final empties
x <- sub('\\s+$','',x)
y <- rev(x)
z <- y == ''
count = match(FALSE,z)
padded <- count - 1
x <- .parseBlock(x)
block <- attr(x,'block')
stopifnot(length(x)>0)
comments <- .initcomments(x)
data <- .initdata(x)
data <- sub('SAME','1',data)
data <- paste(data,collapse='\n')
z <- strsplit(data,NULL)[[1]]
#classify each character in z as belonging to a particular line and particular estimate.
est <- .initEstimateNum(z)
line <- .initLineNum(z)
inits <- split(z,est)
inits <- lapply(inits,paste,collapse='')
# those comments on lines before the start of estimates
# globalcom <- comments[unique(line[est==0])]
globalcom <- comments[setdiff(line,line[est > 0])]
if(0 %in% est) inits <- inits[-1]
inits <- lapply(
seq_along(inits),
function(i){
x <- inits[[i]]
com <- comments[.initRelComment(i,est,line)]
com <- com[com!='']
comment(x) <- com
x
}
)
inits <- lapply(
seq_along(inits),
function(i){
com <- comment(inits[[i]])
if(is.null(com))com <- character(0)
out <- .as.init.character(inits[[i]],comment=com)
out
}
)
out <- as.inits(inits,comment=globalcom)
attr(out,'block') <- block
attr(out,'padded') <- padded
out
}
.parseBlock <- function(x){
y <- c(x,'_terminus_')
y <- paste(y,collapse='\n')
block <- 0
if(y %contains% '^ *BLOCK'){
block <- text2decimal(y)
y <- sub('BLOCK *\\([^)]+\\)','',y)
}
y <- strsplit(y,'\n')[[1]]
y <- y[y != '_terminus_']
attr(y,'block') <- block
y
}
.initRelComment <- function(i,est,line){
#need numbers for comment lines for any comment on my line, plus any trailing
#comments, i.e. those after this line but before a new est is started
#use comment groups: where runhead est coincides with runhead line
#but if line starts with space, runhead est does not coincide with runhead line
stopifnot(length(est)==length(line))
myLines <- line[est == i]
theirLines <- line[ est > i] # note: not est == i because leading space "belongs" to i - 1
myLines <- setdiff(myLines, theirLines)
# groupstart <- runhead(est) & runhead(line)
# group <- cumsum(groupstart)
# mygroup <- unique(group[est==i])#probably only 1
# mylines <- unique(line[group==mygroup])
myLines
}
.as.init.character <- function(x,comment=character(0),...){#limited utility
stopifnot(length(x)==1)
fixed = FALSE
if(x %contains% 'FIX|FIXED') fixed <- TRUE
x <- gsub('FIXED','',x)
x <- gsub('FIX','',x)
x <- gsub('\n','',x)
x <- gsub('\t','',x)
x <- sub('(','',x,fixed=TRUE)
x <- sub(')','',x,fixed=TRUE)
x <- gsub(' +',' ',x)
x <- sub('^ ','',x)
x <- sub(' $','',x)
x <- gsub(',? ',',',x)
x <- strsplit(x,',')[[1]]
x <- as.numeric(x)
x <- as.init(x,fixed=fixed,comment=comment,...)
x
}
#' Coerce Inits to Inits
#'
#' Coerces inits to inits
#' @param x inits
#' @param ... ignored
#' @return inits
#' @describeIn as.inits inits method
#' @export
#' @family as.inits
as.inits.inits <- function(x,...)x
#' Tweak Something
#'
#' Tweaks something.
#' @param x object
#' @param ... dots
#' @export
#' @family tweak
#' @keywords internal
tweak <- function(x,...)UseMethod('tweak')
#' Tweak Init
#'
#' Tweaks init.
#' @param x init
#' @param ... passed arguments
#' @param sd numeric
#' @param digits integer
#' @return init
#' @export
#' @keywords internal
#' @family tweak
tweak.init <- function(x,sd=0.13,digits=3,...){
scale <- stats::rnorm(1,mean=1,sd=sd)
y <- x$init * scale
y <- signif(y,digits=digits)
if(y < x$low | y > x$up) return(tweak.init(x,sd=sd,digits=digits,...))
x$init <- y
x
}
#' Tweak inits
#'
#' Tweaks inits.
#' @param x inits
#' @param ... passed arguments
#' @param sd numeric
#' @param digits integer
#' @return inits
#' @export
#' @keywords internal
#' @family tweak
tweak.inits <- function(x,sd=0.13,digits=3,...){
x[!fixed(x)] <- lapply(x[!fixed(x)],tweak,sd=sd,digits=digits,...)
x
}
#' Tweak Model
#'
#' Tweaks model.
#' @param x model
#' @param ... passed arguments
#' @param sd numeric
#' @param digits integer
#' @return model
#' @export
#' @family tweak
#' @examples
#' # Create a working project.
#' source <- system.file(package = 'nonmemica','project')
#' target <- tempdir()
#' target <- gsub('\\\\','/',target) # for windows
#' source
#' target
#' file.copy(source,target,recursive = TRUE)
#' project <- file.path(target,'project','model')
#'
#' # Point project option at working project
#' options(project = project)
#' library(magrittr)
#'
#' # Make ten new models with slightly different initial estimates.
#' 1001 %>% tweak
tweak.model <- function(x,sd=0.13,digits=3,...){
stopifnot('theta' %in% names(x))
# x$theta <- as.inits(x$theta)
x[names(x) == 'theta'] <- lapply(x[names(x) == 'theta'], as.inits)
# x$theta <- tweak(x$theta,sd=sd,digits=digits,...)
x[names(x) == 'theta'] <- lapply(x[names(x) == 'theta'], tweak, sd = sd, digits = digits,...)
x
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.