-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathcreateParameters.R
executable file
·125 lines (111 loc) · 6.8 KB
/
createParameters.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
createParameters <- function(
subjects, #@ subjects for which to create parameters
## arguments for the `createNormalParameters` function
genNames, #@ Names of fixed effects to generate
genFixedMean, #@ Means for generating fixed parameters
genFixedCov = 0, #@ Covariance Matrix for generating fixed parameter
genRange, #@ Range of Acceptable values for derived parameters
genBetweenNames, #@ Between subjects effects to generate
genBetweenMean, #@ Means for generated bw effects
genBetweenCov, #@ bw covariance
genErrStruc = "None", #@ how to map effects
genMaxDraws = 10, #@ maximum number of draws
genParRangeTolerance = .5, ## Proportion of subjects with "in range" parameters with which we'd be happy proceeding
## arguments for the `createExternalParameters` function
extFile, #@ file name for data to import
extNames, #@ Names of parameters to import
extBetween, #@ bw subject effect variables in the data
extBetweenNums, #@ integer mapping between random and fixed effects
extSubset, #@ subset to be applied to data before sampling
extRange, #@ Range of Acceptable values for derived parameters
extErrStruc = "None", #@ function to map effects
extRefCol, #@ Column of reference data
extRefColName, #@ Reference column name
extRefColSuffix, #@ Reference column name
extIndEffects, #@ individual effects flag
extDataId = idCol, #@ External subject variable name
workingPath = getwd(), #@ Working directory
## arguments for both
suffix = ".Between", #@ suffix for retained between subject effects
idCol = getEctdColName("Subject"), #@ Subject variable name
seed = .deriveFromMasterSeed( ) , #@ Random seed
flagName = getEctdColName("ParOmit") #@ name for omit flag
)
{
##############################################################################
# Mango Solutions, Chippenham SN15 1BN 2009
# createParameters.R Thu Jun 21 16:54:02 BST 2007 @704 /Internet Time/
#
# Author: Romain/Rich P
###############################################################################
# DESCRIPTION: create parameters wrapper
# KEYWORDS: datagen, component:data:parameter
##############################################################################
subjects <- .expandSubjects( subjects )
idCol <- parseCharInput( idCol, expected = 1, convertToNumeric = FALSE, valid = TRUE)
flagName <- parseCharInput( flagName, expected = 1, convertToNumeric = FALSE, valid = TRUE)
test1 <- !missing(genNames) && !missing(genFixedMean)
test2 <- !missing(extFile) && !missing(extNames)
if (test1) genNames <- parseCharInput( genNames , convertToNumeric = FALSE, checkdup = TRUE)
if (test2) extNames <- parseCharInput( extNames , convertToNumeric = FALSE, checkdup = TRUE)
if(test1 & test2 && any(genNames %in% extNames) ) ectdStop( "Duplicated names between `genNames` and `extNames`")
if( !test1 && !test2){
out <- .eval( "data.frame( $idCol = subjects, $flagName = rep(0, length(subjects)) )" )
return( out )
}
if( test1 ){
## generate parameters from a MVN distribution using createNormalParameters
## build the argument list
argsNP <- list( subjects = subjects, idCol = idCol,
seed = seed, flagName = flagName, suffix = suffix,
errStruc = genErrStruc, covariance = genFixedCov, parRangeTolerance = genParRangeTolerance )
## handle missing arguments
if(!missing(genNames )) argsNP$names <- genNames
if(!missing(genFixedMean )) argsNP$mean <- genFixedMean
if(!missing(genRange )) argsNP$range <- genRange
if(!missing(genBetweenNames)) argsNP$betNames <- genBetweenNames
if(!missing(genBetweenMean )) argsNP$betMean <- genBetweenMean
if(!missing(genBetweenCov )) argsNP$betCov <- genBetweenCov
if(!missing(genMaxDraws )) argsNP$maxDraws <- genMaxDraws
## call the createNormalParameters function and check its output
genData <- try( do.call(createNormalParameters, argsNP), silent = TRUE )
if(class(genData) == "try-error") {
ectdStop("Errors when building data from normal distribution\n\t$genData" )
}
if( !is.data.frame(genData)) ectdStop( "The dataset generated by `createNormalParameters` is not a data frame")
if( nrow(genData) != length(subjects) ) ectdStop( "The number of lines in the dataset does not match the number of subjects requested")
}
if( test2 ){
## generate parameters by sampling from a file using `createExternalParameters`
## build the argument list
argsEX <- list( subjects = subjects, idCol = idCol, seed = seed, flagName = flagName,
errStruc = extErrStruc, file = extFile, names = extNames, workingPath = workingPath, dataId = extDataId )
## handle missing arguments
if( !missing(extBetween )) argsEX$betNames <- extBetween
if( !missing(extBetweenNums)) argsEX$betNums <- extBetweenNums
if( !missing(extSubset )) argsEX$subset <- extSubset
if( !missing(extRange )) argsNP$range <- extRange
if( !missing(extRefCol )) argsEX$refCol <- extRefCol
if( !missing(extRefColName )) argsEX$refColName <- extRefColName
if( !missing(extRefColSuffix)) argsEX$refColSuffix <- extRefColSuffix
if( !missing(extIndEffects )) argsEX$indEffects <- extIndEffects
## call the function and check consistency of the output
extData <- try( do.call( createExternalParameters, argsEX), silent = TRUE)
if( class(extData) == "try-error") ectdStop( "Errors when importing data from file \n\t $extFile" )
if( !is.data.frame(extData)) ectdStop( "The dataset generated by `createExternalParameters` is not a data frame")
if( nrow(extData) != length(subjects) ) ectdStop( "The number of lines in the dataset does not match the number of subjects requested")
}
## build the output data
out <- switch( test1 + 2*test2,
genData, # (1) only test1 is TRUE -> normal data
extData, # (2) only test2 is TRUE -> external data
{ # (3) merge genData and extData
namesGD <- names(genData)
namesEX <- names(extData)
data.frame(
genData[,namesGD != flagName, drop = FALSE], # all data from genData but the paromit
extData[,namesEX %!in% c(idCol, flagName) , drop = FALSE], # all data from extData but the id and flag
1 * ( extData[,flagName,drop=FALSE] | genData[,flagName,drop=FALSE] ) ) # omit from gen or ext
})
out
}