projects.mako.cc - protection-tools/blob - 05-generate_spells.R

   1 Sys.setenv(tz = "utc")
   2 library(parallel)
   3 library(data.table)
   4
   5 dump.creation.time <- as.POSIXct("2015-01-12 00:00:00 utc")
   6
   7 r <- list()
   8
   9 ## step 2: merge moves and deletions into an expanded log
  10 #################################################################
  11 load("processed_log_and_sql_data.RData")
  12
  13 r[["num.final.state.orig"]] <- nrow(final.state)
  14 r[["num.log"]] <- nrow(log)
  15 r[["num.moves"]] <- nrow(log)
  16 r[["num.dels"]] <- nrow(dels)
  17 r[["dump.creation.time"]] <- dump.creation.time
  18
  19 events <- log[,list(title, id)]
  20 events[, type := 'protect']
  21
  22 tmp <- moves[,list(from.title, id)]
  23 tmp[, type := 'move']
  24 setnames(tmp, "from.title", "title")
  25
  26 tmp2 <- dels[, list(title, id)]
  27 tmp2[, type := 'delete']
  28
  29 events <- rbindlist(list(events, tmp, tmp2))
  30 rm(tmp, tmp2)
  31
  32 # convert type to a factor and sort
  33 events[, type := as.factor(type)]
  34
  35 # dropping missing titles
  36 events <- events[!is.na(events$title),]
  37
  38 setkey(events, title)
  39
  40 # return true if next event is move
  41 get.next.event <- function (move.item) {
  42   destination <- move.item[,to.title]
  43   log.id <- move.item[,id]
  44
  45   x <- events[destination,]
  46   x <- x[x$id > log.id,]
  47
  48   # return the first item in the event list
  49   # this will return a one row data.table of all NA if it's missing...
  50   return(x[sort.list(x$id)[1],])
  51 }
  52
  53 # BOOKMARK: BM-D
  54 ## turn/expand moves into a protection and unprotection events
  55 ###############################################################
  56 # build list of uninterupted moves; was end = end of y^
  57 build.move.chains <- function (move.chain){
  58     last.move <- move.chain[nrow(move.chain),]
  59     next.event <- get.next.event(last.move)
  60
  61     if (!all(is.na(next.event))) {
  62         if (next.event[, type] == "move") {
  63             move.chain <- rbindlist(list(move.chain, moves.tmp[J(next.event[,id]),]))
  64             build.move.chains(move.chain)
  65         } else {
  66             return(list(move.chain, FALSE))
  67         }
  68     } else {
  69         return(list(move.chain, TRUE))
  70     }
  71 }
  72
  73 setkey(moves, id)
  74 moves.tmp <- moves
  75
  76 moves.result = list()
  77 while (nrow(moves.tmp) > 0) {
  78   move <- moves.tmp[1,]
  79
  80   rv <- build.move.chains(move)
  81   move.chain <- rv[[1]]
  82   ends.with.move <- rv[[2]]
  83
  84   for (i in seq(1, nrow(move.chain))) {
  85     moves.tmp <- moves.tmp[!J(move.chain[i, id]),]
  86   }
  87
  88   moves.result[[length(moves.result)+1]] <- list(move.chain, ends.with.move)
  89
  90 }
  91
  92 explode.move.chain <- function (chain, rights) {
  93   log.unprot <- data.table(id=chain$id, title=chain$from.title,
  94                            log.type="unprotect", log.time=chain$log.time,
  95                            type="move", level=NA, expiry=NA)
  96   log.prot <- data.table(id=chain$id, title=chain$to.title,
  97                          log.type="protect", log.time=chain$log.time)
  98
  99   # if, and only if, there are no previous events, we'll add right censored event
 100   if (!any(events[chain[1,from.title],id] < chain[1, id])) {
 101     log.prot <- rbind(log.prot,
 102                       data.table(id=NA, title=chain[1,from.title], log.type="protect",
 103                                  log.time=NA))
 104   }
 105
 106   # copy data.table once per right
 107   log.prot <- cbind(log.prot[rep(seq_len(nrow(log.prot)), nrow(rights)),],
 108                     rights[unlist(lapply(seq_len(nrow(rights)),
 109                            function (i) {rep(i, nrow(log.prot))})),])
 110
 111   # put together the unprotect and protect events and return them
 112   return(rbind(log.unprot, log.prot))
 113 }
 114
 115 # check in the final state data
 116 explode.with.final.state.data <- function (chain) {
 117   final.title <- chain[nrow(chain), to.title]
 118
 119   # this will be set to a list of rights, or all NA if they are missing
 120   rights <- final.state[final.title, list(type, level, expiry)]
 121
 122   # return entries for the log
 123   explode.move.chain(chain, rights)
 124 }
 125
 126 setkey(final.state, title)
 127
 128 moves.results.moveterm <- moves.result[sapply(moves.result, function (x) {x[[2]]})]
 129 moves.results.moveterm <- lapply(moves.results.moveterm, function (x) {x[[1]]})
 130
 131 log.moveterm <- rbindlist(mclapply(moves.results.moveterm, explode.with.final.state.data))
 132
 133 moves.results.otherterm <- moves.result[!sapply(moves.result, function (x) {x[[2]]})]
 134 moves.results.otherterm <- lapply(moves.results.otherterm, function (x) {x[[1]]})
 135
 136 log.otherterm <- rbindlist(mclapply(moves.results.otherterm,
 137   function (x) { explode.move.chain(x, data.table(type=NA, level=NA, expiry=NA)) }))
 138
 139 expanded.log <- rbind(log, log.moveterm, log.otherterm,
 140                       data.table(id=dels$id, title=dels$title, log.type="unprotect",
 141                       log.time=dels$log.time, type="delete", level=NA, expiry=NA))
 142
 143 setkey(expanded.log, title)
 144
 145 save(expanded.log, file="expanded_log.RData")
 146 # load("expanded_log.RData"); load("processed_log_and_sql_data.RData")
 147
 148 ### GENERATE SPELLS
 149 generate.spells <- function (page.title, d) {
 150   x <- d[page.title,]
 151   setkey(x, id)
 152
 153   spells <- data.table()
 154   tmp.spells <- data.table()
 155   prev.mod <- FALSE
 156   for (i in seq_len(nrow(x))) {
 157     row <- as.list(x[i,])
 158
 159     # if it's the first time, through and we're seeing an uprot, create a l-cens event
 160     if (i == 1 && row[["log.type"]] == "unprotect") {
 161         tmp.spells <- data.table(title=row[["title"]], type=NA, level=NA, start=NA, end=NA)
 162     }
 163
 164     # first, see if any of the previous tmp.spells expired naturally
 165     if (nrow(tmp.spells) > 0 &&
 166         nrow(tmp.spells[!is.na(tmp.spells$end),]) > 0 &&
 167         nrow(tmp.spells[tmp.spells$end < row[["log.time"]],]) > 0) {
 168       # if they did, add them to spells and drop them from tmp.spells
 169       spells <- rbind(spells, tmp.spells[!is.na(tmp.spells$end) & tmp.spells$end < row[["log.time"]],])
 170       tmp.spells <- tmp.spells[!(!is.na(tmp.spells$end) & tmp.spells$end < row[["log.time"]]),]
 171     }
 172
 173     # otherwise, see if the prevoius spell was a protect/modify and ended a
 174     # spell by omission
 175     if (prev.mod && !is.na(prev.id) && prev.id != row[["id"]]) {
 176       unlisted.types <- tmp.spells[,type][!tmp.spells[,type] %in% x[x$id == row[["id"]], type]]
 177       tmp.tmp.spells <- tmp.spells[tmp.spells$type %in% unlisted.types,]
 178       tmp.tmp.spells$end <- x[x$id == row[["id"]],log.time]
 179       spells <- rbind(spells, tmp.tmp.spells)
 180
 181       tmp.spells <- tmp.spells[!tmp.spells$type %in% unlisted.types,]
 182     }
 183
 184     # if we are adding a new protection event
 185     if (row[["log.type"]] %in% c("protect", "modify")) {
 186       prev.mod <- TRUE; prev.id <- row[["id"]]
 187       # if there is an active spell that conflicts with the current bit,
 188       # end them with the spells start time
 189       if (nrow(tmp.spells) > 0) {
 190         # we could be missing previous data on type in which case we want to replace
 191         # and add to the spells
 192         if (all(is.na(tmp.spells$type))) {
 193           tmp.spells$end <- row[["log.time"]]
 194           spells <- rbind(spells, tmp.spells)
 195           tmp.spells <- data.table()
 196         } else if (is.na(row[["type"]])) {
 197           next
 198         } else {
 199           conflict <- tmp.spells$type == row[["type"]]
 200           # if it's the same rights, we update the expiry date and continue
 201           if (any(conflict) && tmp.spells[conflict,level] == row[["level"]]) {
 202             tmp.spells$end[conflict] <- row[["expiry"]]
 203             next
 204           }
 205           # otherwise, we end the spell
 206           tmp.spells$end[conflict] <- row[["log.time"]]
 207           spells <- rbind(spells, tmp.spells[conflict,])
 208           tmp.spells <- tmp.spells[!conflict,]
 209         }
 210       }
 211
 212       # add the new spell to the list of active spells
 213       tmp.spells <- rbind(tmp.spells,
 214         data.table(title=row[["title"]], type=row[["type"]], level=row[["level"]],
 215                    start=row[["log.time"]], end=row[["expiry"]]))
 216
 217     # if it's an unprotection event and we're sitting on existing events
 218     } else if (row[["log.type"]] == "unprotect" && nrow(tmp.spells) > 0) {
 219       prev.mod <- FALSE; prev.id <- row[["id"]]
 220       # end /all/ active spells and add them to spells
 221       tmp.spells$end <- row[["log.time"]]
 222       spells <- rbind(spells, tmp.spells)
 223       tmp.spells <- data.table()
 224     }
 225   }
 226   # if this is the final time through, add any active spells
 227   if (nrow(tmp.spells) > 0) {
 228     spells <- rbind(spells, tmp.spells)
 229   }
 230   tmp.spells <- data.table()
 231   if (any(is.na(spells$title))) { print(page.title) }
 232   return(spells)
 233 }
 234
 235 page.titles <- unique(expanded.log$title)
 236 page.titles <- page.titles[!is.na(page.titles)]
 237 page.titles <- page.titles[page.titles != ""]
 238 #spells <- rbindlist(lapply(page.titles, generate.spells, expanded.log))
 239 spells <- rbindlist(mclapply(page.titles, generate.spells, expanded.log))
 240
 241 save(spells, file="spells-nofinal.RData")
 242
 243 # load("spells-nofinal.RData"); load("processed_log_and_sql_data.RData")
 244
 245 # remove cascacading data from final.state data to allow for merging later
 246 final.state[, cascade := NULL]
 247
 248 # set any ongoing spells and final state data ongoing at the point of data
 249 # collection to right censored
 250 spells <- spells[spells$end > dump.creation.time, end := NA]
 251 final.state <- final.state[final.state$expiry > dump.creation.time, expiry := NA]
 252
 253 # drop log entries from outside our data collection window
 254 spells <- spells[spells$start < dump.creation.time,]
 255
 256 # drop any spells other than edit, move or upload for which we have no final
 257 # state data; and any final state data along the same lines
 258 spells <- spells[spells$type %in% c("edit", "move", "upload"),]
 259 final.state <- final.state[final.state$type %in% c("edit", "move", "upload"),]
 260
 261 # TODO/FIX? handle the two extra NA dropped here
 262 spells <- spells[!is.na(spells$title),]
 263
 264 r[["num.spells.orig"]] <- nrow(spells)
 265
 266 # we're now going to load on any final.state data for missing spells
 267 setkey(final.state, title, type)
 268 setkey(spells, title, type)
 269
 270 ## merge final.state data with spells
 271 #######################################################################
 272 # there are several situations we need to take into account:
 273 # 1. final.state for pages for which we have no record: we create right/left
 274 #    censored spells for these
 275 # 2. we have an open spells. final.state data that matches data we have in log
 276 #    data. we can discard this final state data
 277 # 3. we have an open spell and final state data, but they disagree.
 278 # 4. final state data for spells our log data suggests should be closed: add right/
 279 # 5. log data suggests is should be open
 280
 281 # 1. final.state for pages for which we have no record: we create right/left
 282 #    censored spells for these.  most likely, these were spells started before
 283 #    2008. as a result, we grab final.state data for those spells
 284 missing.spells <- final.state[is.na(spells[final.state, level, mult="first"]),]
 285 missing.spells <- missing.spells[!missing.spells$type == "aft",]
 286 missing.spells[, start := NA]
 287 missing.spells[, end := NA]
 288 missing.spells[, page.id := NULL]
 289 missing.spells[, expiry := NULL]
 290
 291 # drop these missing spells from the final.state
 292 final.state <- final.state[!missing.spells[,list(title, type)]]
 293
 294 # print the number of missing spells
 295 r[["num.created.from.final.state"]] <- nrow(missing.spells)
 296 r[["num.created.from.final.state.pages"]] <- length(unique(missing.spells$title))
 297
 298 # to answer 2+ we first need create a dataset of spells from the log that are
 299 # open at the time of data.collection. these will either be because they have
 300 # an infinite expiry or because they were ongoing at the time of
 301 # data.collection.
 302 open.spells <- spells[is.na(spells$end),]
 303 setkey(open.spells, start)
 304
 305 setkey(open.spells, title, type)
 306 setkey(final.state, title, type)
 307
 308 # BOOKMARK: BK-A
 309 # look for spells that both final.state and log suggests are open but there is
 310 # disagreement on
 311 tmp <- open.spells[final.state, nomatch=0]
 312 tmp <- tmp[as.character(tmp$level) != as.character(tmp$i.level), list(title, type)]
 313
 314 # handchecking each of the examples suggests that these are all due a lag in
 315 # time between the creation of the SQL final.state data and the log. we can
 316 # simply remove these from the final state data
 317 r[["num.dropped.level.nomatch"]] <- nrow(tmp)
 318
 319 # as a result, we can simply drop these form the final state
 320 # an alternate approach would be to set these to NA as in:
 321 # spells[tmp, level := as.character(NA), mult="last"]
 322
 323
 324 final.state <- final.state[!tmp,]
 325
 326 # now, we have to take the list of open spells and find the subset of the final
 327 # state that does not match
 328 open.spells[, expiry := end]
 329 setkey(open.spells, title, type, level, expiry)
 330 setkey(final.state, title, type, level, expiry)
 331
 332 # BOOKMARK: BK-C
 333 final.state.missing <- open.spells[!final.state,]
 334 # BOOKMARK: BK-B
 335 open.spells.missing <- final.state[!open.spells,]
 336
 337 r[["num.final.state.missing"]] <- nrow(final.state.missing)
 338 r[["num.spell.missing"]] <- nrow(open.spells.missing)
 339
 340 # spells <- rbind(spells, missing.spells, missing.spells2)
 341 spells <- rbind(spells, missing.spells)
 342 setkey(spells, title)
 343
 344 save(spells, file="spells.RData")
 345