R/functions_effects_DyNAMi_rate.R

Defines functions update_DyNAMi_rate_dyadXego update_DyNAMi_rate_sizeXego update_DyNAMi_rate_dyadXdiff update_DyNAMi_rate_sizeXdiff update_DyNAMi_rate_sim update_DyNAMi_rate_diff update_DyNAMi_rate_same update_DyNAMi_rate_alter update_DyNAMi_rate_ego update_DyNAMi_rate_dyad update_DyNAMi_rate_size update_DyNAMi_rate_alterpop update_DyNAMi_rate_alterdeg update_DyNAMi_rate_egopop update_DyNAMi_rate_egodeg update_DyNAMi_rate_tie update_DyNAMi_rate_inertia update_DyNAMi_rate_intercept init_DyNAMi_rate.default init_DyNAMi_rate

# define methods ----------------------------------------------------------
# init cache data structure: vector or matrix
init_DyNAMi_rate <- function(
    effectFun, network, attribute, groupsNetwork, window, n1, n2) {
  UseMethod("init_DyNAMi_rate", effectFun)
}

# default -----------------------------------------------------------------
init_DyNAMi_rate.default <- function(
    effectFun,
    network = NULL, attribute = NULL,
    groupsNetwork, window,
    n1, n2) {
  init_DyNAMi_choice.default(
    effectFun = effectFun,
    network = network, attribute = attribute,
    groupsNetwork = groupsNetwork, window = window,
    n1 = n1, n2 = n2
  )
}

# Structural effects ------------------------------------------------------
# intercept -------------------------------------------------------------------
# initStat_DyNAMi_rate_intercept <- function()

update_DyNAMi_rate_intercept <- function(
    network,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    weighted = FALSE,
    joining = 1) {
  reptotal <- NULL

  # JOINING RATE
  if (joining == 1) {
    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (!isingroup) {
        if (statistics[i, 1] != 1) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 1)
          )
        }
        next
      } else {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
      }
    }
  }

  # LEAVING RATE
  if (joining == -1) {
    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (isingroup) {
        if (statistics[i, 1] != 1) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 1)
          )
        }
        next
      } else {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
      }
    }
  }

  return(reptotal)
}


# inertia ---------------------------------------------------------------------
# initStat_DyNAMi_rate_inertia <- function()

update_DyNAMi_rate_inertia <- function(
    network,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    weighted = TRUE, subType = "proportion",
    joining = -1) {
  update_DyNAMi_rate_tie(
    network = network,
    groupsNetwork = groupsNetwork,
    sender = sender, receiver = receiver, replace = replace,
    n1 = n1, n2 = n2, statistics = statistics,
    weighted = weighted, subType = subType,
    joining = joining
  )
}

# tie ---------------------------------------------------------------------
# initStat_DyNAMi_rate_tie <- function()

update_DyNAMi_rate_tie <- function(
    network,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    weighted = FALSE, subType = "proportion",
    joining = -1) {
  reptotal <- NULL

  # LEAVING MODEL
  if (joining == -1) {
    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (!isingroup) {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
        next
      }

      members <- which(groupsNetwork[, owngroup] == 1)
      nmembers <- length(members)
      smembers <- members[members != i]
      snmembers <- length(smembers)

      if (subType == "count") {
        rep <- sum(network[i, smembers] > 0)
      }
      if (subType == "proportion") {
        rep <- sum(network[i, smembers] > 0) / snmembers
      }
      if (subType == "presence") {
        rep <- max(network[i, smembers] > 0)
      }
      if (subType == "min") {
        rep <- min(network[i, smembers])
      }
      if (subType == "mean") {
        rep <- mean(network[i, smembers])
      }
      if (subType == "max") {
        rep <- max(network[i, smembers])
      }

      if (statistics[i, 1] != rep) {
        reptotal <- rbind(
          reptotal,
          cbind(node1 = i, node2 = seq.int(n2), replace = rep)
        )
      }
    }
  }

  return(reptotal)
}

# egodeg -------------------------------------------------------------------
# initStat_DyNAMi_rate_egodeg <- function()

update_DyNAMi_rate_egodeg <- function(
    network,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    weighted = TRUE, subType = "identity",
    joining = 1) {
  reptotal <- NULL
  meandeg <- mean(rowSums(network))
  sddeg <- sd(rowSums(network))

  # JOINING RATE
  if (joining == 1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (!isingroup) {
        if (subType == "identity") {
          rep <- sum(network[i, ])
        }
        if (subType == "centered") {
          rep <- sum(network[i, ]) - meandeg
        }
        if (subType == "normalized") {
          if (sddeg > 0) {
            rep <- (sum(network[i, ]) - meandeg) / sddeg
          } else {
            rep <- 0
          }
        }

        if (statistics[i, 1] != rep) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = rep)
          )
        }
        next
      } else {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
      }
    }
  }

  # LEAVING RATE
  if (joining == -1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (isingroup) {
        if (subType == "identity") {
          rep <- sum(network[i, ])
        }
        if (subType == "centered") {
          rep <- sum(network[i, ]) - meandeg
        }
        if (subType == "normalized") {
          if (sddeg > 0) {
            rep <- (sum(network[i, ]) - meandeg) / sddeg
          } else {
            rep <- 0
          }
        }

        if (statistics[i, 1] != rep) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = rep)
          )
        }
        next
      } else {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
      }
    }
  }

  return(reptotal)
}


# egopop -------------------------------------------------------------------
# initStat_DyNAMi_rate_egopop <- function()

update_DyNAMi_rate_egopop <- function(
    network,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    weighted = TRUE, subType = "normalized",
    joining = 1) {
  update_DyNAMi_rate_egodeg(
    network = network,
    groupsNetwork = groupsNetwork,
    sender = sender, receiver = receiver, replace = replace,
    n1 = n1, n2 = n2, statistics = statistics,
    weighted = weighted, subType = subType,
    joining = joining
  )
}

# alterdeg -------------------------------------------------------------------
# initStat_DyNAMi_rate_alterdeg <- function()

update_DyNAMi_rate_alterdeg <- function(
    network,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    weighted = TRUE, subType = "mean",
    joining = -1) {
  reptotal <- NULL
  meandeg <- mean(rowSums(network))
  maxdeg <- max(rowSums(network))
  sddeg <- sd(rowSums(network))

  # LEAVING MODEL
  if (joining == -1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (!isingroup) {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
        next
      }

      members <- which(groupsNetwork[, owngroup] == 1)
      nmembers <- length(members)
      smembers <- members[members != i]
      snmembers <- length(smembers)

      if (snmembers == 1) {
        if (subType == "mean") {
          rep <- sum(network[smembers, ])
        }
        if (subType == "mean_centered") {
          rep <- sum(network[smembers, ]) - meandeg
        }
        if (subType == "mean_normalized") {
          if (sddeg > 0) {
            rep <- (sum(network[smembers, ]) - meandeg) / sddeg
          } else {
            rep <- 0
          }
        }
        if (subType == "min") {
          rep <- sum(network[smembers, ])
        }
        if (subType == "max") {
          rep <- sum(network[smembers, ])
        }
      } else {
        if (subType == "mean") {
          rep <- mean(rowSums(network[smembers, ]))
        }
        if (subType == "mean_centered") {
          rep <- mean(rowSums(network[smembers, ])) - meandeg
        }
        if (subType == "mean_normalized") {
          if (sddeg > 0) {
            rep <- (mean(rowSums(network[smembers, ])) - meandeg) / sddeg
          } else {
            rep <- 0
          }
        }
        if (subType == "min") {
          rep <- min(rowSums(network[smembers, ])) / maxdeg
        }
        if (subType == "max") {
          rep <- max(rowSums(network[smembers, ])) / maxdeg
        }
      }

      if (statistics[i, 1] != rep) {
        reptotal <- rbind(
          reptotal,
          cbind(node1 = i, node2 = seq.int(n2), replace = rep)
        )
      }
    }
  }

  return(reptotal)
}

# alterpop -------------------------------------------------------------------
# initStat_DyNAMi_rate_alterpop <- function()

update_DyNAMi_rate_alterpop <- function(
    network,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    weighted = TRUE, subType = "mean_normalized",
    joining = -1) {
  update_DyNAMi_rate_alterdeg(
    network = network,
    groupsNetwork = groupsNetwork,
    sender = sender, receiver = receiver, replace = replace,
    n1 = n1, n2 = n2, statistics = statistics,
    weighted = weighted, subType = subType,
    joining = joining
  )
}

# size -------------------------------------------------------------------
# initStat_DyNAMi_rate_size <- function()

update_DyNAMi_rate_size <- function(
    network,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    weighted = FALSE, subType = "identity",
    joining = -1) {
  reptotal <- NULL

  # LEAVING MODEL
  if (joining == -1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (!isingroup) {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
        next
      }

      members <- which(groupsNetwork[, owngroup] == 1)
      nmembers <- length(members)

      if (subType == "identity") {
        rep <- nmembers
      }
      if (subType == "squared") {
        rep <- nmembers^2
      }
      if (subType == "dummy") {
        rep <- nmembers > 2
      }

      if (statistics[i, 1] != rep) {
        reptotal <- rbind(
          reptotal,
          cbind(node1 = i, node2 = seq.int(n2), replace = rep)
        )
      }
    }
  }

  return(reptotal)
}


# dyad -------------------------------------------------------------------
# initStat_DyNAMi_rate_dyad <- function()

update_DyNAMi_rate_dyad <- function(
    network,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    weighted = FALSE, subType = "identity",
    joining = -1) {
  reptotal <- NULL

  # LEAVING MODEL
  if (joining == -1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (!isingroup) {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
        next
      }

      members <- which(groupsNetwork[, owngroup] == 1)
      nmembers <- length(members)

      if (subType == "identity") {
        if (nmembers == 2) {
          rep <- 1
        } else {
          rep <- 0
        }
      }

      if (statistics[i, 1] != rep) {
        reptotal <- rbind(
          reptotal,
          cbind(node1 = i, node2 = seq.int(n2), replace = rep)
        )
      }
    }
  }

  return(reptotal)
}


# Covariate effects -------------------------------------------------------


# ego -------------------------------------------------------------------
# initStat_DyNAMi_rate_ego <- function()

update_DyNAMi_rate_ego <- function(
    attribute,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    subType = "identity",
    joining = 1,
    node = 0) {
  reptotal <- NULL
  meanatt <- mean(attribute)
  sdatt <- sd(attribute)

  # JOINING RATE
  if (joining == 1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (!isingroup) {
        if (subType == "identity") {
          rep <- attribute[i]
        }
        if (subType == "squared") {
          rep <- attribute[i]^2
        }
        if (subType == "centered") {
          rep <- attribute[i] - meanatt
        }
        if (subType == "normalized") {
          if (sdatt > 0) {
            rep <- (attribute[i] - meanatt) / sdatt
          } else {
            rep <- 0
          }
        }

        if (statistics[i, 1] != rep) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = rep)
          )
        }
        next
      } else {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
      }
    }
  }

  # LEAVING RATE
  if (joining == -1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (isingroup) {
        if (subType == "identity") {
          rep <- attribute[i]
        }
        if (subType == "squared") {
          rep <- attribute[i]^2
        }
        if (subType == "centered") {
          rep <- attribute[i] - meanatt
        }
        if (subType == "normalized") {
          if (sdatt > 0) {
            rep <- (attribute[i] - meanatt) / sdatt
          } else {
            rep <- 0
          }
        }

        if (statistics[i, 1] != rep) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = rep)
          )
        }
        next
      } else {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
      }
    }
  }

  return(reptotal)
}

# alter -------------------------------------------------------------------
# initStat_DyNAMi_rate_alter <- function()

update_DyNAMi_rate_alter <- function(
    attribute,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    subType = "mean",
    joining = -1,
    node = 0) {
  reptotal <- NULL
  meanatt <- mean(attribute)
  sdatt <- sd(attribute)

  # LEAVING MODEL
  if (joining == -1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (!isingroup) {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
        next
      }

      members <- which(groupsNetwork[, owngroup] == 1)
      nmembers <- length(members)
      smembers <- members[members != i]
      snmembers <- length(smembers)

      if (subType == "mean") {
        rep <- mean(attribute[smembers])
      }
      if (subType == "mean_squared") {
        rep <- mean(attribute[smembers])^2
      }
      if (subType == "mean_centered") {
        rep <- mean(attribute[smembers]) - meanatt
      }
      if (subType == "mean_centered_squared") {
        rep <- (mean(attribute[smembers]) - meanatt)^2
      }
      if (subType == "mean_normalized") {
        if (sdatt > 0) {
          rep <- (mean(attribute[smembers]) - meanatt) / sdatt
        } else {
          rep <- 0
        }
      }
      if (subType == "min") {
        rep <- min(attribute[smembers])
      }
      if (subType == "min_squared") {
        rep <- min(attribute[smembers])^2
      }
      if (subType == "min_centered") {
        rep <- min(attribute[smembers] - meanatt)
      }
      if (subType == "min_centered_squared") {
        rep <- min(attribute[smembers] - meanatt)^2
      }
      if (subType == "max") {
        rep <- max(attribute[smembers])
      }
      if (subType == "max_squared") {
        rep <- max(attribute[smembers])^2
      }
      if (subType == "max_centered") {
        rep <- max(attribute[smembers] - meanatt)
      }
      if (subType == "max_centered_squared") {
        rep <- max(attribute[smembers] - meanatt)^2
      }
      if (subType == "range") {
        rep <- max(attribute[smembers]) - min(attribute[smembers])
      }

      if (statistics[i, 1] != rep) {
        reptotal <- rbind(
          reptotal,
          cbind(node1 = i, node2 = seq.int(n2), replace = rep)
        )
      }
    }
  }

  return(reptotal)
}

# same --------------------------------------------------------------------
# initStat_DyNAMi_rate_same <- function()

update_DyNAMi_rate_same <- function(
    attribute,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    subType = "proportion",
    joining = -1,
    node = 0) {
  reptotal <- NULL

  # LEAVING MODEL
  if (joining == -1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (!isingroup) {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
        next
      }

      members <- which(groupsNetwork[, owngroup] == 1)
      nmembers <- length(members)
      smembers <- members[members != i]
      snmembers <- length(smembers)

      if (subType == "proportion") {
        rep <- sum(attribute[smembers] == attribute[i]) / snmembers
      }
      if (subType == "count") {
        rep <- sum(attribute[smembers] == attribute[i])
      }
      if (subType == "presence") {
        rep <- min(attribute[smembers] == attribute[i])
      }

      if (statistics[i, 1] != rep) {
        reptotal <- rbind(
          reptotal,
          cbind(node1 = i, node2 = seq.int(n2), replace = rep)
        )
      }
    }
  }

  return(reptotal)
}

# diff --------------------------------------------------------------------
# initStat_DyNAMi_rate_diff <- function()

update_DyNAMi_rate_diff <- function(
    attribute,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    subType = "averaged_sum",
    joining = -1,
    node = 0) {
  reptotal <- NULL

  # LEAVING MODEL
  if (joining == -1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (!isingroup) {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
        next
      }

      members <- which(groupsNetwork[, owngroup] == 1)
      nmembers <- length(members)
      smembers <- members[members != i]
      snmembers <- length(smembers)

      if (subType == "averaged_sum") {
        rep <- sum(abs(attribute[smembers] - attribute[i])) / snmembers
      }
      if (subType == "mean") {
        rep <- abs(mean(attribute[smembers]) - attribute[i])
      }
      if (subType == "mean_squared") {
        rep <- (mean(attribute[smembers]) - attribute[i])^2
      }
      if (subType == "min") {
        rep <- abs(min(attribute[smembers]) - attribute[i])
      }
      if (subType == "min_squared") {
        rep <- (min(attribute[smembers]) - attribute[i])^2
      }
      if (subType == "max") {
        rep <- abs(max(attribute[smembers]) - attribute[i])
      }
      if (subType == "max_squared") {
        rep <- (max(attribute[smembers]) - attribute[i])^2
      }

      if (statistics[i, 1] != rep) {
        reptotal <- rbind(
          reptotal,
          cbind(node1 = i, node2 = seq.int(n2), replace = rep)
        )
      }
    }
  }

  return(reptotal)
}


# sim ---------------------------------------------------------------------
# initStat_DyNAMi_rate_sim <- function()

update_DyNAMi_rate_sim <- function(
    attribute,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    subType = "averaged_sum",
    joining = -1,
    node = 0) {
  reptotal <- NULL

  # LEAVING MODEL
  if (joining == -1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (!isingroup) {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
        next
      }

      members <- which(groupsNetwork[, owngroup] == 1)
      nmembers <- length(members)
      smembers <- members[members != i]
      snmembers <- length(smembers)

      if (subType == "averaged_sum") {
        rep <- (-1) * sum(abs(attribute[smembers] - attribute[i])) / snmembers
      }
      if (subType == "mean") {
        rep <- (-1) * abs(mean(attribute[smembers]) - attribute[i])
      }
      if (subType == "min") {
        rep <- (-1) * abs(min(attribute[smembers]) - attribute[i])
      }
      if (subType == "max") {
        rep <- (-1) * abs(max(attribute[smembers]) - attribute[i])
      }

      if (statistics[i, 1] != 1) {
        reptotal <- rbind(
          reptotal,
          cbind(node1 = i, node2 = seq.int(n2), replace = rep)
        )
      }
    }
  }

  return(reptotal)
}


# Interaction structural and Covariate effects ----------------------------

# sizeXdiff ---------------------------------------------------------------
# initStat_DyNAMi_rate_sizeXdiff <- function()

update_DyNAMi_rate_sizeXdiff <- function(
    attribute,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    subType = "averaged_sum",
    joining = -1,
    node = 0) {
  reptotal <- NULL

  # LEAVING MODEL
  if (joining == -1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (!isingroup) {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
        next
      }

      members <- which(groupsNetwork[, owngroup] == 1)
      nmembers <- length(members)
      smembers <- members[members != i]
      snmembers <- length(smembers)

      if (subType == "averaged_sum") {
        rep <- nmembers *
          sum(abs(attribute[smembers] - attribute[i])) / snmembers
      }
      if (subType == "mean") {
        rep <- nmembers * abs(mean(attribute[smembers]) - attribute[i])
      }
      if (subType == "min") {
        rep <- nmembers * abs(min(attribute[smembers]) - attribute[i])
      }
      if (subType == "max") {
        rep <- nmembers * abs(max(attribute[smembers]) - attribute[i])
      }

      if (statistics[i, 1] != rep) {
        reptotal <- rbind(
          reptotal,
          cbind(node1 = i, node2 = seq.int(n2), replace = rep)
        )
      }
    }
  }

  return(reptotal)
}


# dyadXdiff ---------------------------------------------------------------
# initStat_DyNAMi_rate_dyadXdiff <- function()

update_DyNAMi_rate_dyadXdiff <- function(
    attribute,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    subType = "averaged_sum",
    joining = -1,
    node = 0) {
  reptotal <- NULL

  # LEAVING MODEL
  if (joining == -1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      if (!isingroup) {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
        next
      }

      members <- which(groupsNetwork[, owngroup] == 1)
      nmembers <- length(members)
      smembers <- members[members != i]
      snmembers <- length(smembers)

      if (nmembers == 2) {
        m <- 1
      } else {
        m <- 0
      }

      if (subType == "averaged_sum") {
        rep <- m * sum(abs(attribute[smembers] - attribute[i])) / snmembers
      }
      if (subType == "mean") {
        rep <- m * abs(mean(attribute[smembers]) - attribute[i])
      }
      if (subType == "min") {
        rep <- m * abs(min(attribute[smembers]) - attribute[i])
      }
      if (subType == "max") {
        rep <- m * abs(max(attribute[smembers]) - attribute[i])
      }

      if (statistics[i, 1] != rep) {
        reptotal <- rbind(
          reptotal,
          cbind(node1 = i, node2 = seq.int(n2), replace = rep)
        )
      }
    }
  }

  return(reptotal)
}

# sizeXego -------------------------------------------------------------------
# initStat_DyNAMi_rate_sizeXego <- function()

update_DyNAMi_rate_sizeXego <- function(
    attribute,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    subType = "identity",
    joining = -1,
    node = 0) {
  reptotal <- NULL
  meanatt <- mean(attribute)
  sdatt <- sd(attribute)

  # LEAVING RATE
  if (joining == -1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      members <- which(groupsNetwork[, owngroup] == 1)
      nmembers <- length(members)
      smembers <- members[members != i]
      snmembers <- length(smembers)

      if (isingroup) {
        if (subType == "identity") {
          rep <- nmembers * attribute[i]
        }
        if (subType == "squared") {
          rep <- nmembers * attribute[i]^2
        }
        if (subType == "centered") {
          rep <- nmembers * (attribute[i] - meanatt)
        }
        if (subType == "normalized") {
          if (sdatt > 0) {
            rep <- nmembers * (attribute[i] - meanatt) / sdatt
          } else {
            rep <- 0
          }
        }

        if (statistics[i, 1] != rep) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = rep)
          )
        }
        next
      } else {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
      }
    }
  }

  return(reptotal)
}


# dyadXego -------------------------------------------------------------------
# initStat_DyNAMi_rate_dyadXego <- function()

update_DyNAMi_rate_dyadXego <- function(
    attribute,
    groupsNetwork,
    sender, receiver, replace,
    n1, n2, statistics,
    subType = "identity",
    joining = -1,
    node = 0) {
  reptotal <- NULL
  meanatt <- mean(attribute)
  sdatt <- sd(attribute)

  # LEAVING RATE
  if (joining == -1) {
    reptotal <- NULL

    for (i in seq.int(n1)) {
      owngroup <- which(groupsNetwork[i, ] == 1)
      isingroup <- FALSE
      if (length(owngroup) == 1) {
        isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1
      }

      members <- which(groupsNetwork[, owngroup] == 1)
      nmembers <- length(members)
      smembers <- members[members != i]
      snmembers <- length(smembers)

      if (nmembers == 2) {
        m <- 1
      } else {
        m <- 0
      }

      if (isingroup) {
        if (subType == "identity") {
          rep <- m * attribute[i]
        }
        if (subType == "squared") {
          rep <- m * attribute[i]^2
        }
        if (subType == "centered") {
          rep <- m * (attribute[i] - meanatt)
        }
        if (subType == "normalized") {
          if (sdatt > 0) {
            rep <- m * (attribute[i] - meanatt) / sdatt
          } else {
            rep <- 0
          }
        }

        if (statistics[i, 1] != rep) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = rep)
          )
        }
        next
      } else {
        if (statistics[i, 1] != 0) {
          reptotal <- rbind(
            reptotal,
            cbind(node1 = i, node2 = seq.int(n2), replace = 0)
          )
        }
      }
    }
  }

  return(reptotal)
}

Try the goldfish package in your browser

Any scripts or data that you put into this service are public.

goldfish documentation built on Sept. 14, 2024, 9:08 a.m.