Skip to content
Projects
Groups
Snippets
Help
This project
Loading...
Sign in / Register
Toggle navigation
P
ProcMod
Overview
Overview
Details
Activity
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
0
Issues
0
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
LECASofts
ProcMod
Commits
147a729b
Commit
147a729b
authored
May 25, 2018
by
Eric Coissac
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Add the procmod.frame data strucutre
parent
b7960bb6
Hide whitespace changes
Inline
Side-by-side
Showing
5 changed files
with
406 additions
and
1 deletions
+406
-1
DESCRIPTION
DESCRIPTION
+5
-0
NAMESPACE
NAMESPACE
+19
-0
ProcMod.Rproj
ProcMod.Rproj
+1
-1
internals.R
R/internals.R
+54
-0
procmod.frame.R
R/procmod.frame.R
+327
-0
No files found.
DESCRIPTION
View file @
147a729b
...
...
@@ -13,3 +13,8 @@ RoxygenNote: 6.0.1
Suggests: knitr,
rmarkdown
VignetteBuilder: knitr
Collate:
'internals.R'
'formula.procmod.frame.R'
'mprocuste.R'
'procmod.frame.R'
NAMESPACE
View file @
147a729b
# Generated by roxygen2: do not edit by hand
S3method("$<-",procmod.frame)
S3method("[",procmod.frame)
S3method("[[<-",procmod.frame)
S3method(AIC,pm)
S3method(BIC,pm)
S3method(anova,pm)
S3method(as.list,procmod.frame)
S3method(as.procmod.frame,array)
S3method(as.procmod.frame,list)
S3method(as.procmod.frame,procmod.frame)
S3method(deviance,pm)
S3method(dim,procmod.frame)
S3method(extractAIC,pm)
S3method(formula,procmod.frame)
S3method(plot,pm)
S3method(print,pm)
S3method(residuals,pm)
S3method(subset,procmod.frame)
export(as.procmod.frame)
export(is.procmod.frame)
export(mcor)
export(mvar)
export(pm)
export(procmod.frame)
export(weighted.residuals)
ProcMod.Rproj
View file @
147a729b
...
...
@@ -18,4 +18,4 @@ StripTrailingWhitespace: Yes
BuildType: Package
PackageUseDevtools: Yes
PackageInstallArgs: --no-multiarch --with-keep.source
PackageRoxygenize: rd,collate,namespace
,vignette
PackageRoxygenize: rd,collate,namespace
R/internals.R
0 → 100644
View file @
147a729b
make_subS3Class
=
function
(
obj
,
subclass
)
{
class
(
obj
)
=
c
(
paste
(
subclass
,
collapse
=
"_"
),
class
(
obj
))
return
(
obj
)
}
dots.names
=
function
(
...
)
{
varnames
=
substitute
(
list
(
...
))[
-1L
]
dots
=
list
(
...
)
isname
=
sapply
(
varnames
,
is.name
)
charname
=
as.character
(
varnames
)
charname
[
!
isname
]
=
""
n
=
length
(
dots
)
explicit
=
names
(
dots
)
if
(
is.null
(
explicit
))
explicit
=
character
(
n
)
ze
=
!
nzchar
(
explicit
)
explicit
[
ze
]
=
charname
[
ze
]
ze
=
!
nzchar
(
explicit
)
dnames
<-
paste
(
'V'
,
seq_len
(
n
),
sep
=
''
)
explicit
[
ze
]
=
dnames
[
ze
]
return
(
explicit
)
}
make_procmod_subS3Class
=
function
(
obj
,
subclass
)
{
class
(
obj
)
=
c
(
paste
(
"procmod"
,
subclass
,
sep
=
"_"
,
collapse
=
"_"
),
class
(
obj
))
return
(
obj
)
}
make_procmod_data
=
function
(
obj
,
subclass
)
{
eud
=
inherits
(
obj
,
'procmod_data'
,
which
=
TRUE
)
if
(
eud
>
0
)
class
(
obj
)
=
class
(
obj
)[
-1
:-
(
eud
-1
)]
else
obj
=
make_procmod_subS3Class
(
obj
,
'data'
)
if
(
!
missing
(
subclass
))
obj
=
make_procmod_subS3Class
(
obj
,
subclass
)
return
(
obj
)
}
R/procmod.frame.R
0 → 100644
View file @
147a729b
#' @include internals.R
NULL
#' Internal function repeating a matrix.
#'
#' @description repeats several times the rows of a matrix
#' to create a new matrix with more rows. The
#' final row count must be a multiple of the
#' initial row count
#'
#' @param x The matrix to replicate
#' @param length.out an interger value specifying the number of row
#' of the returned matrix
#'
#' @return a new matrix with the same number of columns but with `length.out`
#' rows.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#'
.rep_matrix
=
function
(
x
,
length.out
)
{
N
=
nrow
(
x
)
if
((
length.out
%%
N
!=
0L
))
stop
(
sprintf
(
"The size of the longest object (%d) is not a multiple of the size of the shortest (%d)"
,
nrows
,
N
),
domain
=
NA
)
rep
=
x
while
(
nrow
(
rep
)
<
length.out
)
rep
=
rbind
(
rep
,
x
)
return
(
rep
)
}
.procmod_coerce_value
=
function
(
x
,
nrows
=
0
)
{
xi
<-
if
(
is.data.frame
(
x
))
as.matrix
(
x
)
else
if
(
is.matrix
(
x
))
x
else
as.matrix
(
x
)
dxi
=
dim
(
xi
)
if
(
is.null
(
dxi
))
dxi
=
c
(
1
,
1
)
rownamesi
=
rownames
(
xi
)
colnamesi
=
colnames
(
xi
)
xi
=
as.numeric
(
xi
)
dim
(
xi
)
=
dxi
rownames
(
xi
)
=
rownamesi
colnames
(
xi
)
=
colnamesi
N
=
nrow
(
xi
)
if
(
nrows
>
0L
&&
N
<
nrows
)
if
(
N
>
0L
&&
(
nrows
%%
N
==
0L
))
xi
<-
.rep_matrix
(
xi
,
length.out
=
nrows
)
else
stop
(
sprintf
(
ngettext
(
N
,
"replacement has %d row, data has %d"
,
"replacement has %d rows, data has %d"
),
N
,
nrows
),
domain
=
NA
)
return
(
xi
)
}
#' Build a procmod.frame data structure.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
procmod.frame
=
function
(
...
,
row.names
=
NULL
,
check.rows
=
FALSE
,
check.names
=
TRUE
,
fix.empty.names
=
TRUE
)
{
mirn
<-
missing
(
row.names
)
mrn
<-
is.null
(
row.names
)
varnames
=
dots.names
(
...
)
x
<-
list
(
...
)
n
<-
length
(
x
)
nrows
<-
integer
(
n
)
value
<-
vector
(
mode
=
"list"
,
length
=
n
)
names
(
value
)
=
varnames
types
<-
character
(
n
)
for
(
i
in
seq_len
(
n
))
{
if
(
i
==
1
)
xi
<-
.procmod_coerce_value
(
x
[[
i
]])
else
xi
<-
.procmod_coerce_value
(
x
[[
i
]],
nrows
=
nrows
[
1
])
nrows
[
i
]
<-
nrow
(
xi
)
value
[[
i
]]
=
xi
}
stopifnot
(
all
(
nrows
[
i
]
==
nrows
))
if
(
length
(
row.names
)
==
nrows
[
i
])
{
attr
(
value
,
"row.names"
)
=
row.names
for
(
i
in
seq_len
(
n
))
rownames
(
value
[[
i
]])
=
row.names
}
return
(
make_subS3Class
(
value
,
"procmod.frame"
))
}
#' Check if an object is a Matrix Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
is.procmod.frame
=
function
(
x
)
{
inherits
(
x
,
"procmod.frame"
)
}
#' Coerce to a Matrix Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame
=
function
(
data
)
{
UseMethod
(
"as.procmod.frame"
,
data
)
}
#' Coerce to a ProcMod Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.list
=
function
(
data
)
{
do.call
(
procmod.frame
,
data
)
}
#' Coerce to a ProcMod Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.procmod.frame
=
function
(
data
)
{
data
}
#' Coerce to a ProcMod Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.procmod.frame.array
=
function
(
data
)
{
di
=
dim
(
data
)
stopifnot
(
length
(
di
)
==
3
)
l
=
lapply
(
seq_len
(
di
[
3
]),
function
(
i
)
data
[,,
i
])
if
(
length
(
attr
(
data
,
"dimnames"
))
==
3
)
names
(
l
)
=
attr
(
data
,
"dimnames"
)[[
3
]]
do.call
(
procmod.frame
,
l
)
}
#' Dimensions of a Matrix Frame.
#'
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
dim.procmod.frame
=
function
(
x
)
return
(
c
(
nrow
(
x
[[
1
]]),
length
(
x
)))
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
`[[<-.procmod.frame`
=
function
(
x
,
i
,
value
)
{
cl
=
class
(
x
)
nrows
=
nrow
(
x
)
class
(
x
)
=
"list"
if
(
!
is.null
(
value
))
{
value
=
.procmod_coerce_value
(
value
,
nrows
)
N
<-
nrow
(
value
)
if
(
N
>
nrows
)
stop
(
sprintf
(
ngettext
(
N
,
"replacement has %d row, data has %d"
,
"replacement has %d rows, data has %d"
),
N
,
nrows
),
domain
=
NA
)
if
(
N
<
nrows
)
stop
(
sprintf
(
ngettext
(
N
,
"replacement has %d row, data has %d"
,
"replacement has %d rows, data has %d"
),
N
,
nrows
),
domain
=
NA
)
}
if
(
length
(
attr
(
x
,
"row.names"
))
==
nrows
)
rownames
(
value
)
=
attr
(
x
,
"row.names"
)
x
[[
i
]]
<-
value
class
(
x
)
=
cl
return
(
x
)
}
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
`$<-.procmod.frame`
=
function
(
x
,
name
,
value
)
{
x
[[
name
]]
<-
value
return
(
x
)
}
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
`[.procmod.frame`
=
function
(
x
,
i
,
j
,
drop
=
if
(
missing
(
i
))
TRUE
else
length
(
cols
)
==
1
)
{
has.j
=
!
missing
(
j
)
has.i
=
!
missing
(
i
)
has.drop
=
!
missing
(
drop
)
Narg
=
nargs
()
-
2
+
(
has.i
|
has.j
|
has.drop
)
-
has.drop
# message("Nargs = ",Narg," i:",has.i," j:",has.j," drop:",has.drop)
if
(
!
all
(
names
(
sys.call
())
%in%
c
(
""
,
"drop"
)))
warning
(
"named arguments other than 'drop' are discouraged"
)
# Case 1 : X[]
if
(
!
has.i
&&
!
has.j
)
return
(
x
)
# Case 2 : X[,j]
if
(
!
has.i
&&
has.j
)
{
y
<-
x
[
j
,
drop
=
FALSE
]
if
(
drop
&&
length
(
y
)
==
1L
)
y
=
y
[[
1L
]]
return
(
y
)
}
# Case 3 : X[i]
if
(
has.i
&&
Narg
==
1
)
{
nm
<-
names
(
x
)
if
(
is.null
(
nm
))
nm
<-
character
()
if
(
!
is.character
(
i
)
&&
anyNA
(
nm
))
{
names
(
nm
)
<-
names
(
x
)
<-
seq_along
(
x
)
y
<-
as.list
(
x
)[
i
]
cols
<-
names
(
y
)
if
(
anyNA
(
cols
))
stop
(
"undefined columns selected"
)
cols
<-
names
(
y
)
<-
nm
[
cols
]
}
else
{
y
<-
as.list
(
x
)[
i
]
cols
<-
names
(
y
)
if
(
!
is.null
(
cols
)
&&
anyNA
(
cols
))
stop
(
"undefined columns selected"
)
}
if
(
anyDuplicated
(
cols
))
names
(
y
)
<-
make.unique
(
cols
)
attr
(
y
,
"row.names"
)
<-
.row_names_info
(
x
,
0L
)
attr
(
y
,
"class"
)
<-
oldClass
(
x
)
return
(
y
)
}
# Case 3 : X[i,]
if
(
has.i
&&
!
has.j
&&
Narg
>
1
)
{
y
=
lapply
(
x
,
function
(
m
)
m
[
i
,,
drop
=
FALSE
])
attr
(
y
,
"row.names"
)
<-
.row_names_info
(
x
,
0L
)
attr
(
y
,
"class"
)
=
class
(
x
)
return
(
y
)
}
if
(
has.i
&&
has.j
)
{
y
=
x
[
j
,
drop
=
drop
]
y
=
y
[
i
,,
drop
=
drop
]
return
(
y
)
}
}
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
subset.procmod.frame
=
function
(
x
,
subset
,
select
,
drop
=
FALSE
,
...
)
{
r
<-
if
(
missing
(
subset
))
rep_len
(
TRUE
,
nrow
(
x
))
else
{
e
<-
substitute
(
subset
)
r
<-
eval
(
e
,
x
,
parent.frame
())
if
(
!
is.logical
(
r
))
stop
(
"'subset' must be logical"
)
r
&
!
is.na
(
r
)
}
vars
<-
if
(
missing
(
select
))
TRUE
else
{
nl
<-
as.list
(
seq_along
(
x
))
names
(
nl
)
<-
names
(
x
)
eval
(
substitute
(
select
),
nl
,
parent.frame
())
}
x
[
r
,
vars
,
drop
=
drop
]
}
#' @author Eric Coissac
#' @author Christelle Gonindard-Melodelima
#' @export
as.list.procmod.frame
=
function
(
x
,
...
)
{
class
(
x
)
=
'list'
return
(
x
)
}
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment