################################################################################
## Triads (one-mode statistic)
################################################################################
triadStatold <- function(data, time, sender, target, halflife, weight = NULL,
eventtypevar = NULL, eventtypevalues = NULL,
eventattributevar = NULL, eventattributeAI = NULL,
eventattributeBI = NULL, eventattributeAB = NULL,
variablename = "triad", returnData = FALSE,
showprogressbar = FALSE){
####### check inputs
## check if sender input is available
if ( is.null(sender) ) {
stop("No 'sender' argument was provided.")
}else{
sender <- as.character(sender)
}
## check if target input is available
if ( is.null(target) ) {
stop("No 'target' argument was provided.")
}else{
target <- as.character(target)
}
## check if event.sequence is well defined (numeric and ever-increasing)
if ( is.null(time) ) {
stop("No 'time' argument was provided.")
}else{
#test if weight-var is in ascending order
if ( is.unsorted(time) ) {
stop("'", time, "' is not sorted. Sort data frame according to the event
sequence.")
}
}
## check if vaiables are of same length
if ( length(sender) != length(target) ){
stop("'sender' and 'target' are not of same length.")
}
if ( length(sender) != length(time) ){
stop("'sender' and 'time' are not of same length.")
}
## check if weight-var is defined (if not -> create it)
if ( is.null(weight) ) {
weight <- rep(1, length(time))
}
if ( !is.numeric(weight) ) {
stop("'", as.name(weight), "' variable is not numeric.")
}
## check if event-type inputs are available and correctly specified
if ( !is.null(eventtypevar) ) {
# check if variable is of same length as sender
if ( length(sender) != length(eventtypevar) ){
stop("'sender' and 'eventtypevar' are not of same length.")
}
# transform variable
eventtypevar <- as.character(eventtypevar)
if ( length(unique(eventtypevar)) != 2 ){
stop("'eventtypevar' is not a dummy variable.")
}
if ( is.null(eventtypevalues) ){
stop("No 'eventtypevalues' provided. ")
}
if ( length(eventtypevalues) != 2 ){
stop("'eventtypevalues' not specified correctly. Two values need to be
provided that will reflect either a 'friend-of-friend', a 'friend-
of-enemy', a 'enemy-of-friend' or a 'enemy-of-enemy' triad. The two
values indicate which value in the 'eventtypevar' relates to
'friend' (or 'enemy') depending on the triad type.")
}
if ( length(grep(eventtypevalues[1], eventtypevar)) == 0 ) {
stop("First value '", eventattributeAB, "' is not an element of '",
deparse(substitute(eventattributevar)) , "'.")
}
if ( length(grep(eventtypevalues[2], eventtypevar)) == 0 ) {
stop("Second value '", eventattributeAB, "' is not an element of '",
deparse(substitute(eventattributevar)) , "'.")
}
}
## check if event-attribute inputs are available and correctly specified
if ( is.null(eventattributevar) == FALSE ) {
# check length of variable
if ( length(sender) != length(eventattributevar) ){
stop("'sender' and 'eventattributevar' are not of same length.")
}
# transform variable
eventattributevar <- as.character(eventattributevar)
if ( is.null(eventattributeAB) & is.null(eventattributeAI) &
is.null(eventattributeBI) ){
stop("No 'eventattribute__' provided. Provide a string value by which the
events are filtered.", )
}
# check if eventattributevalue is part of the variable
if ( is.null(eventattributeAB) == FALSE){
if ( length(grep(eventattributeAB, eventattributevar)) == 0 ) {
stop("Value '", eventattributeAB, "' is not an element of '",
deparse(substitute(eventattributevar)) , "'.")
}
}
if ( is.null(eventattributeAI) == FALSE){
if ( length(grep(eventattributeAI, eventattributevar)) == 0 ) {
stop("Value '", eventattributeAI, "' is not an element of '",
deparse(substitute(eventattributevar)) , "'.")
}
}
if ( is.null(eventattributeBI) == FALSE){
if ( length(grep(eventattributeBI, eventattributevar)) == 0 ) {
stop("Value '", eventattributeBI, "' is not an element of '",
deparse(substitute(eventattributevar)) , "'.")
}
}
}
## check if variablename makes sense (no " " etc.)
variablename <- gsub(" ", "", variablename, fixed = TRUE)
## create simple data set to be returned for degree calcuations with more than 1 output-variable
##TODO: should there be an event-id-variable?? => that would be useful here
data.short <- data.frame(time)
## calculate part of decay function
xlog <- log(2)/halflife
####### calculate stat
## create placeholder-variables to be used in the cpp-Function
placeholder <- rep("1", length(time))
## calculate the triad effects for each event
## all the statistics without an event type
if ( is.null(eventtypevar) ){
## all stats without an event type and an event attribute
if ( is.null(eventattributevar) ){
## (1) no type, no attribute. Simple triad-effect
result <- triadCpp(sender, target, time, weight, placeholder, "1", "1",
placeholder, "1", placeholder, "1", placeholder, "1",
xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}else{
## all stats without event type but with event attribute
## (2) no type, attributeAB
if ( is.null(eventattributeAI) & is.null(eventattributeBI) & is.null(eventattributeAB) == FALSE ){
result <- triadCpp(sender, target, time, weight, placeholder, "1", "1",
eventattributevar, eventattributeAB, placeholder, "1",
placeholder, "1", xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
## (3) no type, attributeAI
if ( is.null(eventattributeAB) & is.null(eventattributeBI) & is.null(eventattributeAI) == FALSE ){
result <- triadCpp(sender, target, time, weight, placeholder, "1", "1",
placeholder, "1", eventattributevar, eventattributeAI,
placeholder, "1", xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
## (4) no type, attributeBI
if ( is.null(eventattributeAB) & is.null(eventattributeAI) & is.null(eventattributeBI) == FALSE ){
result <- triadCpp(sender, target, time, weight, placeholder, "1", "1",
placeholder, "1", placeholder, "1", eventattributevar,
eventattributeBI, xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
## (5) no type, attributeAB & attributeAI
if ( is.null(eventattributeAB) == FALSE & is.null(eventattributeAI) == FALSE & is.null(eventattributeBI) ){
result <- triadCpp(sender, target, time, weight, placeholder, "1", "1",
eventattributevar, eventattributeAB, eventattributevar,
eventattributeAI, placeholder, "1", xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
## (6) no type, attribute AB & attributeBI
if ( is.null(eventattributeAB) == FALSE & is.null(eventattributeAI) & is.null(eventattributeBI) == FALSE ){
result <- triadCpp(sender, target, time, weight, placeholder, "1", "1",
eventattributevar, eventattributeAB, placeholder,
"1", eventattributevar, eventattributeBI, xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
## (7) no type, attribute AI & attributeBI
if ( is.null(eventattributeAB) & is.null(eventattributeAI) == FALSE & is.null(eventattributeBI) == FALSE ){
result <- triadCpp(sender, target, time, weight, placeholder, "1", "1",
placeholder, "1", eventattributevar,
eventattributeAI, eventattributevar, eventattributeBI, xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
## (8) no type, attribute AB & attributeAI & attributeBI
if ( is.null(eventattributeAB) == FALSE & is.null(eventattributeAI) == FALSE & is.null(eventattributeBI) == FALSE ){
result <- triadCpp(sender, target, time, weight, placeholder, "1", "1",
eventattributevar, eventattributeAB, eventattributevar,
eventattributeAI, eventattributevar, eventattributeBI, xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
}#closes else attributevar != null
}else{
## all the statistics with an event type
if ( is.null(eventattributevar) ){
## with type, but no attribute
## (9) type, no attribute
if ( is.null(eventattributeAB) & is.null(eventattributeAI) & is.null(eventattributeBI) ){
result <- triadCpp(sender, target, time, weight, eventtypevar, eventtypevalues[1], eventtypevalues[2],
placeholder, "1", placeholder,
"1", placeholder, "1", xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
}else{
## all stats with type and attribute
## (10) type, attributeAB
if ( is.null(eventattributeAB) == FALSE & is.null(eventattributeAI) & is.null(eventattributeBI) ){
result <- triadCpp(sender, target, time, weight, eventtypevar, eventtypevalues[1], eventtypevalues[2],
eventattributevar, eventattributeAB, placeholder,
"1", placeholder, "1", xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
## (11) type, attributeAI
if ( is.null(eventattributeAB) & is.null(eventattributeAI) == FALSE & is.null(eventattributeBI) ){
result <- triadCpp(sender, target, time, weight, eventtypevar, eventtypevalues[1], eventtypevalues[2],
placeholder, "1", eventattributevar,
eventattributeAI, placeholder, "1", xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
## (12) type, attributeBI
if ( is.null(eventattributeAB) & is.null(eventattributeAI) & is.null(eventattributeBI) == FALSE ){
result <- triadCpp(sender, target, time, weight, eventtypevar, eventtypevalues[1], eventtypevalues[2],
placeholder, "1", placeholder,
"1", eventattributevar, eventattributeBI, xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
## (13) type, attributeAB & attributeAI
if ( is.null(eventattributeAB) == FALSE & is.null(eventattributeAI) == FALSE & is.null(eventattributeBI) ){
result <- triadCpp(sender, target, time, weight, eventtypevar, eventtypevalues[1], eventtypevalues[2],
eventattributevar, eventattributeAB, eventattributevar,
eventattributeAI, placeholder, "1", xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
## (14) type, attribute AB & attributeBI
if ( is.null(eventattributeAB) == FALSE & is.null(eventattributeAI) & is.null(eventattributeBI) == FALSE ){
result <- triadCpp(sender, target, time, weight, eventtypevar, eventtypevalues[1], eventtypevalues[2],
eventattributevar, eventattributeAB, placeholder,
"1", eventattributevar, eventattributeBI, xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
## (15) type, attribute AI & attributeBI
if ( is.null(eventattributeAB) & is.null(eventattributeAI) == FALSE & is.null(eventattributeBI) == FALSE ){
result <- triadCpp(sender, target, time, weight, eventtypevar, eventtypevalues[1], eventtypevalues[2],
placeholder, "1", eventattributevar,
eventattributeAI, eventattributevar, eventattributeBI, xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
## (16) type, attribute AB & attributeAI & attributeBI
if ( is.null(eventattributeAB) == FALSE & is.null(eventattributeAI) == FALSE & is.null(eventattributeBI) == FALSE ){
result <- triadCpp(sender, target, time, weight, eventtypevar, eventtypevalues[1], eventtypevalues[2],
eventattributevar, eventattributeAB, eventattributevar,
eventattributeAI, eventattributevar, eventattributeBI, xlog )
if ( returnData == TRUE ) {
data <- cbind(data, result)
names(data)[length(data)] <- variablename
## return the data frame with the variable bound to it
return(data)
}else{
## only return the 1 triad variable that was generated
return(result)
}
}
}##closes else attr-var != null
}## closes else-type-var != null
}#closing
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.