Skip to content

Commit

Permalink
0.3-2
Browse files Browse the repository at this point in the history
  • Loading branch information
@alexanderrobitzsch
alexanderrobitzsch committed Sep 2, 2019
1 parent 8afe383 commit 1df5f5e
Show file tree
Hide file tree
Showing 48 changed files with 1,829 additions and 221 deletions.
7 changes: 4 additions & 3 deletions DESCRIPTION
View file
Original file line number Diff line number Diff line change
@@ -1,14 +1,15 @@
Package: srm
Type: Package
Title: Structural Equation Modeling for the Social Relations Model
Version: 0.2-1
Date: 2019-06-18 23:05:29
Version: 0.3-2
Date: 2019-09-02 14:07:39
Author: Steffen Nestler [aut], Alexander Robitzsch [aut, cre],
Oliver Luedtke [aut]
Maintainer: Alexander Robitzsch <robitzsch@ipn.uni-kiel.de>
Description:
Provides functionality for structural equation modeling for
the social relations model (Warner, Kenny, & Soto, 1979,
the social relations model (Kenny & La Voie, 1984;
<doi:10.1016/S0065-2601(08)60144-6>; Warner, Kenny, & Soto, 1979,
<doi:10.1037/0022-3514.37.10.1742>). Maximum likelihood
estimation (Gill & Swartz, 2001, <doi:10.2307/3316080>;
Nestler, 2018, <doi:10.3102/1076998617741106>) and
Expand Down
8 changes: 4 additions & 4 deletions R/SRM_CREATE_DESIGN_MATRICES.R
View file
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
## File Name: SRM_CREATE_DESIGN_MATRICES.R
## File Version: 0.319
## File Version: 0.322

SRM_CREATE_DESIGN_MATRICES <- function( data_list, ngroups, use_rcpp=TRUE)
SRM_CREATE_DESIGN_MATRICES <- function( data_list, ngroups, rrgroup_name, use_rcpp=TRUE)
{
# data_list$ngroups <- ngroups
comp_design <- TRUE
Expand All @@ -16,7 +16,7 @@ SRM_CREATE_DESIGN_MATRICES <- function( data_list, ngroups, use_rcpp=TRUE)
Xs_rr <- list()
Wds_rr <- list()
Wds_rr_rcpp <- list()
groups <- unique( data_list[[gg]]$y$Group )
groups <- unique( data_list[[gg]]$y[,rrgroup_name] )
data_list[[1]]$nrr <- NR
y_gg <- data_list[[gg]]$y
Zis_gg <- data_list[[gg]]$Zis
Expand All @@ -25,7 +25,7 @@ SRM_CREATE_DESIGN_MATRICES <- function( data_list, ngroups, use_rcpp=TRUE)
calculate_gg <- rep(TRUE,NR)
for (rr in seq_len(NR) ){
# y
ind_rr <- which(y_gg$Group == groups[rr])
ind_rr <- which(y_gg[,rrgroup_name] == groups[rr])
y_temp <- y_gg[ ind_rr, ]
y_rr[[rr]] <- y_temp$y

Expand Down
10 changes: 10 additions & 0 deletions R/SRM_DEFINE_NULL_VECTOR.R
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,10 @@
## File Name: SRM_DEFINE_NULL_VECTOR.R
## File Version: 0.01

SRM_DEFINE_NULL_VECTOR <- function(vec)
{
if (length(vec)==0){
vec <- NULL
}
return(vec)
}
12 changes: 7 additions & 5 deletions R/SRM_IDVARIABLE.R
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
## File Name: SRM_IDVARIABLE.R
## File Version: 0.17
## File Version: 0.25


SRM_IDVARIABLE <- function(TABLE, method="ml")
Expand All @@ -16,7 +16,7 @@ SRM_IDVARIABLE <- function(TABLE, method="ml")
index[idx] <- seq(1,length(idx),1)
last <- length(idx)

# all free parameters that are constrainted get a number
# all free parameters that are constrained get a number
idx <- which(!(is.na(TABLE$equal)) & TABLE$free == 1)
name <- unique(TABLE$equal[idx])
lauf <- last + 1
Expand All @@ -29,9 +29,11 @@ SRM_IDVARIABLE <- function(TABLE, method="ml")
TABLE$index <- index
TABLE$equal <- NULL
TABLE$mod.idx <- NULL

TABLE <- TABLE[c("group","lhs","op","rhs","index","mat",
"row","col","fixed","starts","user")]
TABLE_vars <- c("group","lhs","op","rhs","index","mat",
"row","col","fixed","starts","user",
"level")
TABLE_vars <- intersect(colnames(TABLE), TABLE_vars)
TABLE <- TABLE[TABLE_vars] # added by Steffen
return(TABLE)

}
163 changes: 105 additions & 58 deletions R/SRM_MAKE_DATA_LIST.R
View file
Original file line number Diff line number Diff line change
@@ -1,63 +1,95 @@
## File Name: SRM_MAKE_DATA_LIST.R
## File Version: 0.250

SRM_MAKE_DATA_LIST <- function( srm_data = NULL, person_names = NULL,
rrgroup_name = NULL, group.var = NULL, fixed.groups = FALSE,
var_names=NULL, use_rcpp=TRUE, do_checks=FALSE )
## File Version: 0.264


SRM_MAKE_DATA_LIST <- function( srm_data = NULL,
person_names = NULL,
rrgroup_name = NULL,
group.var = NULL,
rrvar_names=NULL,
personcov_names = NULL,
dyadcov_names = NULL,
fixed.groups = FALSE,
use_rcpp=TRUE,
do_checks=FALSE )
{
#use_rcpp <- FALSE
##-- some checks
if (do_checks){
if( length(unique(srm_data[,person_names[1]])) != length(unique(srm_data[,person_names[2]])) ) {
stop("SRM ERROR: Number of actors does not match number of partners!")
}

if (!(identical(sort(unique(srm_data[,person_names[1]])),sort(unique(srm_data[,person_names[2]]))))) {
stop("SRM ERROR: Actor-IDs does not match Partner-IDs!")
}
}
#use_rcpp <- FALSE

##-- if there is only one rr-group add a rrgroup_name variable
if ( is.null(rrgroup_name) ) {
srm_data$rrgroup = 1
rrgroup_name = "rrgroup"
}
##-- some checks
if (do_checks){

if ( length(unique(srm_data[,person_names[1]])) != length(unique(srm_data[,person_names[2]])) ) {
stop("SRM ERROR: Number of actors does not match number of partners!")
}

##-- add a dyad number that is rrgroup specific
z0 <- Sys.time()
srm_data <- SRM_PREPARE_ADD_DYADNUMBER(data = srm_data, person_names = person_names,
rrgroup_name = rrgroup_name )
# cat(" --- SRM_PREPARE_ADD_DYADNUMBER") ; z1 <- Sys.time(); print(z1-z0) ; z0 <- z1
if (!(identical(sort(unique(srm_data[,person_names[1]])),sort(unique(srm_data[,person_names[2]]))))) {
stop("SRM ERROR: Actor-IDs does not match Partner-IDs!")
}

##-- make a long data frame, sort the data
srm_data <- SRM_PREPARE_DATA( data = srm_data, person_names = person_names ,
rrgroup_name = rrgroup_name, var_names = var_names )
# cat(" --- SRM_PREPARE_DATA") ; z1 <- Sys.time(); print(z1-z0) ; z0 <- z1
}

##-- now, we generate a list of data frames for each SRM-SEM group
##-- if there is only one participant group add a rrgroup_name variable
if ( is.null(group.var) ) {
srm_data$group.var <- 1
group.var <- "group.var"
}

groups = unique(srm_data[,group.var])
ngroups = length(groups)
data_list = vector("list",ngroups)
##-- if there is only one rr-group add a rrgroup_name variable
if ( is.null(rrgroup_name) ) {
srm_data$rrgroup <- 1
rrgroup_name <- "rrgroup"
}


# cat(" --- start group iteration") ; z1 <- Sys.time(); print(z1-z0) ; z0 <- z1
##-- we iterate through the groups
for (ng in 1:ngroups) {
##-- add a dyad number that is rrgroup specific
#z0 <- Sys.time()
srm_data <- SRM_PREPARE_ADD_DYADNUMBER( data = srm_data,
person_names = person_names,
rrgroup_name = rrgroup_name )
# cat(" --- SRM_PREPARE_ADD_DYADNUMBER") ; z1 <- Sys.time(); print(z1-z0) ; z0 <- z1

#- a temporary data frame
tmp_data = srm_data[srm_data[,group.var] == groups[ng],]
##-- make a long data frame, sort the data
srm_data <- SRM_PREPARE_DATA( data = srm_data,
group.var = group.var,
person_names = person_names,
rrgroup_name = rrgroup_name,
rrvar_names = rrvar_names,
personcov_names = personcov_names,
dyadcov_names = dyadcov_names )
rrdata <- srm_data[["rrdata"]]
pedata <- srm_data[["pedata"]]
dydata <- srm_data[["dydata"]]

# cat(" --- SRM_PREPARE_DATA") ; z1 <- Sys.time(); print(z1-z0) ; z0 <- z1

#groups <- unique(srm_data[,group.var])
groups <- unique(rrdata[,group.var])
ngroups <- length(groups)
data_list <- vector("list",ngroups)
allnames <- c(group.var, rrgroup_name, person_names, "DyadNo_SRM", "no_vars", "y" )

# cat(" --- start group iteration") ; z1 <- Sys.time(); print(z1-z0) ; z0 <- z1
##-- we iterate through the groups
for (ng in 1:ngroups) {

#- temporary data frame fpr rr-variables
tmp_data <- rrdata[rrdata[,group.var] == groups[ng],]

#- make the Xs matrix
if ( fixed.groups ) {
# generate variable combining rr_group and measure
tmp_data$tmpX <- interaction( tmp_data[,rrgroup_name], tmp_data[,"no_vars"] )
Xs <- outer(tmp_data[,"tmpX"], unique(tmp_data[,"tmpX"]), '==')*1

#- generate variable combining rr_group and measure
tmp_data$tmpX <- interaction( tmp_data[,rrgroup_name], tmp_data[,"no_vars"] )
#Xs <- outer(tmp_data[,"tmpX"], unique(tmp_data[,"tmpX"]), '==')*1
c1 <- unique(tmp_data[,"tmpX"])
n2 <- length(c1)
n1 <- nrow(tmp_data)
m1 <- matrix(tmp_data[,"tmpX"], nrow=n1, ncol=n2)
m2 <- matrix(c1, nrow=n1, ncol=n2, byrow=TRUE)
Xs <- 1*(m1 == m2)

} else {

# Xs = outer(tmp_data[,"no_vars"], unique(tmp_data[,"no_vars"]), '==')*1
c1 <- unique(tmp_data[,"no_vars"])
n2 <- length(c1)
Expand All @@ -68,28 +100,43 @@ z0 <- Sys.time()
}

#- make the y-index matrix
y_index <- tmp_data[,c(group.var, rrgroup_name, "Actor", "Partner", "DyadNo_SRM", "no_vars", "y")]
y_index <- tmp_data[,allnames]

#- make the personcov - variable matrices
if( !(is.null(pedata)) ) {
Xu <- as.matrix( pedata[pedata[,group.var] == groups[ng],] )
} else { Xu <- NULL }

#- make the personcov - variable matrices
if( !(is.null(dydata)) ) {
Xd <- as.matrix( dydata[dydata[,group.var] == groups[ng],] )
} else { Xd <- NULL }

#- make the matrix lists
pers_matrix_list <- SRM_MAKE_DATA_MATRIX_PERSON( data = tmp_data, person_names = person_names,
rrgroup_name = rrgroup_name, use_rcpp=use_rcpp)
pers_matrix_list <- SRM_MAKE_DATA_MATRIX_PERSON( data = tmp_data,
person_names = person_names,
rrgroup_name = rrgroup_name,
use_rcpp = use_rcpp )

dyad_matrix_list <- SRM_MAKE_DATA_MATRIX_DYAD( data = tmp_data, rrgroup_name = rrgroup_name,
use_rcpp=use_rcpp)
dyad_matrix_list <- SRM_MAKE_DATA_MATRIX_DYAD( data = tmp_data,
rrgroup_name = rrgroup_name,
use_rcpp = use_rcpp)

#- add the lists to the overall list
tmp_data_list = list( y = tmp_data[,c(rrgroup_name,"y")] ,
Xs = Xs,
Zis = pers_matrix_list$res1,
Wds = dyad_matrix_list$res1 ,
NI = pers_matrix_list$res2,
ND = dyad_matrix_list$res2,
y_index = y_index )
tmp_data_list <- list( y = tmp_data[,c(rrgroup_name,"y")] ,
Xs = Xs,
Zis = pers_matrix_list$res1,
Wds = dyad_matrix_list$res1 ,
NI = pers_matrix_list$res2,
ND = dyad_matrix_list$res2,
y_index = y_index,
Xu = Xu,
Xd = Xd )

#- add to the overall list
data_list[[ng]] <- tmp_data_list
}
# cat(" --- end group iteration") ; z1 <- Sys.time(); print(z1-z0) ; z0 <- z1

return(data_list)

# cat(" --- end group iteration") ; z1 <- Sys.time(); print(z1-z0) ; z0 <- z1
attr(data_list, "rrgroup_name") <- rrgroup_name
return(data_list)
}
3 changes: 1 addition & 2 deletions R/SRM_MAKE_DATA_MATRIX_DYAD.R
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,5 @@
## File Name: SRM_MAKE_DATA_MATRIX_DYAD.R
## File Version: 0.277

## File Version: 0.281


SRM_MAKE_DATA_MATRIX_DYAD <- function(data = NULL,
Expand Down
35 changes: 22 additions & 13 deletions R/SRM_MAKE_DATA_MATRIX_PERSON.R
View file
Original file line number Diff line number Diff line change
@@ -1,20 +1,22 @@
## File Name: SRM_MAKE_DATA_MATRIX_PERSON.R
## File Version: 0.305
## File Version: 0.312


SRM_MAKE_DATA_MATRIX_PERSON <- function(data = NULL, person_names = NULL,
rrgroup_name = NULL, use_rcpp=TRUE )
SRM_MAKE_DATA_MATRIX_PERSON <- function( data = NULL,
person_names = NULL,
rrgroup_name = NULL,
use_rcpp = TRUE )

{

##-- how many round-robin groups
rrgroups = unique(data[,rrgroup_name])
nrr = length(rrgroups)
rrgroups <- unique(data[,rrgroup_name])
nrr <- length(rrgroups)

##-- how many variables?
no_vars = length(unique(data$no_vars))
res1 = NULL
res2 = NULL
no_vars <- length(unique(data$no_vars))
res1 <- NULL
res2 <- NULL

for ( rr in 1:nrr ){

Expand All @@ -29,14 +31,15 @@ SRM_MAKE_DATA_MATRIX_PERSON <- function(data = NULL, person_names = NULL,
##-- now we generate a list of data frame containing the position of
## the elements in the design matrix for each dyad
if (!use_rcpp){

person_matrix_list <- lapply(1:no_person, function(x) {

idx.rows = numeric()
idx.cols = numeric()
for (m in 1:no_vars) {

tmp_actor <- which(tmp.data[,person_names[1]]==persons[x] & tmp.data[,"no_vars"]==m)
tmp_partner <- which(tmp.data[,person_names[2]]==persons[x] & tmp.data[,"no_vars"]==m)
tmp_partner <- which(tmp.data[,person_names[2]]==persons[x] & tmp.data[,"no_vars"]==m)

idx.rows <- c(idx.rows,tmp_actor,tmp_partner)
idx.cols <- c(idx.cols,rep(m,length(tmp_actor)),rep(m+no_vars,length(tmp_partner)))
Expand All @@ -50,17 +53,23 @@ SRM_MAKE_DATA_MATRIX_PERSON <- function(data = NULL, person_names = NULL,
})

out1 <- as.matrix( do.call("rbind", person_matrix_list ))

} else { # use Rcpp

tmp_data3 <- as.matrix(tmp.data[, c(person_names, "no_vars")])
out1 <- SRM_RCPP_SRM_MAKE_DATA_MATRIX_PERSON( tmp_data3=tmp_data3,
no_person=no_person, no_vars=no_vars, rr=rr, persons=persons )
out1 <- SRM_RCPP_SRM_MAKE_DATA_MATRIX_PERSON( tmp_data3 = tmp_data3,
no_person = no_person,
no_vars = no_vars,
rr = rr,
persons = persons )
colnames(out1) <- c("rrgroup", "pid", "rows", "cols")
}

res1 <- rbind(res1, out1)

res2 = rbind(res2, as.matrix( data.frame( rrgroup = rr, NI = no_person )) )
res2 <- rbind(res2, as.matrix( data.frame( rrgroup = rr, NI = no_person )))

}

return( list( res1 = res1, res2 = res2 ))

}
Loading

0 comments on commit 1df5f5e

Please sign in to comment.