发帖
雷达卡
滚雪球抽样（snowball sampling 或 snowballing）。
讨论：
实践中，样本受限于特定群体，覆盖面狭窄。
只有首轮抽样为随机抽样，而后续各轮抽样均为前一轮样本的关联推荐，因为非随机，所以严格意义上并非抽样。
虽然实践中，总体实际上很小且样本之间的关系未知，但我们假设有个足够大的总体，且样本之间的关系以权重描述，则这个总体可以作为模拟抽样的总体。需要说明的是，这个总体，仅为方便模拟抽样。
- library(dplyr)
- library(plot.matrix)
- library(igraph)
- #建立一个总体
- N <- 1000 #总体容量
- set.seed(2022)
- V <-
- paste(
- sample(LETTERS[-c(9, 15)], N, replace = T),
- sample(letters[-c(9, 15)], N, replace = T),
- round(10000 * runif(N, 1, 9), 0),
- sep = ""
- )#样本名称
- unique(V) #验证样本名唯一性
- #自定义函数,参数须大于20, 结果为对称的邻接矩阵，对角线元素为0
- #权重3、2、1、0，对应“至交”、“酒肉朋友”、“点头之交”和“无直接关系”
- #概率猜测的基础是一个人大概有1个至交，3个酒肉朋友，10个点头之交
- adjMFunc <- function (n) {
- m <- diag(0, n)
- m[lower.tri(m)] <-
- sample(3:0,
- length(m[lower.tri(m)]),
- replace = T,
- prob = c(1 / n, 3 / n, 10 / n, (n - 1 - 3 - 10) / n))
- m[upper.tri(m)] <- m[lower.tri(m)]
- m[upper.tri(m)] <- t(m)[upper.tri(m)]
- m
- }
- #生成邻接矩阵,N须大于20
- adjM <- adjMFunc(N)
- #矩阵热图,只显示前50个对象
- plot(adjM[1:50, 1:50], breaks = seq(0, 4, 1),
- col = colorRampPalette(c("white", "blue", "red")),
- main = "", xlab = "", ylab = "")
- rownames(adjM) <- V
- colnames(adjM) <- V
- #自定义函数，矩阵转数据框，样本之间无直接关系的去除
- M2DFunc <- function (x) {
- #x[upper.tri(x)]<-0 #此处取下三角则为单向关系
- res <- data.frame(
- from = rep(row.names(x), dim(x)[2]),
- to = rep(colnames(x), each = dim(x)[1]),
- weight = as.vector(x),
- stringsAsFactors = F
- ) #转数据框
- res[res[, 3] != 0, ]
- }
- #邻接矩阵转数据框，这个作为后面抽样的总体关系描述更清楚些
- adjDf <- M2DFunc(adjM)
- #str(adjDf)#查看网络关系
- #绘制网络关系图，只用去除"无关系"的数据
- netG <- graph_from_data_frame(d = adjDf, directed = F)
- L1 <- layout.graphopt(netG)
- plot(netG, layout = L1, vertex.size = 5,
- vertex.label.cex = 0.5, vertex.label.dist = 0.5,
- edge.color = "tomato", edge.arrow.size = 0.05)
- #首轮随机抽样
- n1 <- 2 #首轮抽样数
- snowbRes <- sample(V, n1) #抽样结果
- recom <- snowbRes
- #后续轮次推荐
- nm <- 5 #后续轮次数
- k = 1 #循环计数
- repeat {
- selected <- NULL
- for (i in 1:length(recom)) {
- #推荐范围，去除已有抽样
- temp <- adjDf %>%
- filter((from == recom[i]) & !(to %in% snowbRes))
- #在范围内选择权重靠前2位
- selected <- c(selected,
- temp[which(rank(temp[, 3], ties.method = "first") > (dim(temp)[1] - 2)), 2])
- }
- recom <- setdiff(selected, snowbRes)
- snowbRes <- c(snowbRes, recom)#添加至结果
- if (k > nm)
- break
- k <- k + 1
- }
- #抽样结果的邻接矩阵
- resM <- adjM[snowbRes, snowbRes]
- plot(resM, breaks = seq(0, 4, 1),
- col = colorRampPalette(c("white", "blue", "red")),
- main = "", xlab = "", ylab = "")#矩阵热图
- #抽样结果的网络，直接用邻接矩阵生成,蓝色节点为首轮随机抽样，其余为后续推荐
- resG <- graph_from_adjacency_matrix(resM, mode = "undirected")
- resG <- resG %>%
- set_vertex_attr("color", index = V(resG)[1:3], value = "blue") %>%
- set_vertex_attr("color", index = V(resG)[-(1:3)], value = "red")
- L2 <- layout.graphopt(resG)
- plot(resG, layout = L2, vertex.size = 5,
- vertex.label.cex = 0.6, vertex.label.dist = 0.3,
- edge.color = "tomato")
京公网安备 11010802022788号
