### R code from vignette source 'siblings.rnw'
### Encoding: UTF-8

###################################################
### code chunk number 1: siblings.rnw:41-58
###################################################
cat('
id fid mid
  1   NA  0
  2   9  NA
  3   1   2
  4   1   2
 12   7   6
 13   5   6
 14   5   6
 15   5   8', file="netwk.txt" )
( indata <- read.table("netwk.txt", header=TRUE) )
idat <- indata

( foffspring <- by(indata, indata$fid, function(i) { i$id }, simplify=FALSE) )
( moffspring <- by(indata, indata$mid, function(i) { i$id }, simplify=FALSE) )
foffspring[2]
foffspring[[2]]


###################################################
### code chunk number 2: siblings.rnw:61-70
###################################################
sibs <- sapply( 1:nrow(indata), 
                function(i) {
 res <- c()
 if( !is.na(indata$fid[i]) ) res <- c(res, unlist(foffspring[paste0(indata$fid[i])]))
 if( !is.na(indata$mid[i]) ) res <- c(res, unlist(moffspring[paste0(indata$mid[i])]))
 unique(res[res != indata$id[i]])
                            },             
                simplify=TRUE )
sibs


###################################################
### code chunk number 3: siblings.rnw:73-81
###################################################
fsibs <- sapply( 1:nrow(indata), 
                 function(i) {
 res <- c()
 if( !is.na(indata$fid[i]) ) res <- c(res, unlist(foffspring[paste0(indata$fid[i])]))
 unique(res[res != indata$id[i]])
                             },              
                 simplify=TRUE )
fsibs


###################################################
### code chunk number 4: siblings.rnw:84-92
###################################################
msibs <- sapply( 1:nrow(indata), 
                 function(i) {
 res <- c()
 if( !is.na(indata$fid[i]) ) res <- c(res, unlist(moffspring[paste0(indata$mid[i])]) )
 unique(res[res != indata$id[i]]) 
                             },              
                 simplify=TRUE )
msibs


###################################################
### code chunk number 5: siblings.rnw:95-105
###################################################
Fsibs <- sapply( 1:nrow(indata), 
                 function(i) {
 res <- hasf <- hasm <- c()
 if( !is.na(indata$fid[i]) ) hasf <- unlist(foffspring[paste0(indata$fid[i])])
 if( !is.na(indata$mid[i]) ) hasm <- unlist(moffspring[paste0(indata$mid[i])])
 res <- c( res, intersect( hasf, hasm ) )
 unique(res[res != indata$id[i]])
                             }, 
                 simplify=TRUE )
Fsibs


###################################################
### code chunk number 6: siblings.rnw:108-118
###################################################
Hsibs <- sapply( 1:nrow(indata), 
                 function(i) {
 res <- hasf <- hasm <- c()
 if( !is.na(indata$fid[i]) ) hasf <- unlist(foffspring[paste0(indata$fid[i])])
 if( !is.na(indata$mid[i]) ) hasm <- unlist(moffspring[paste0(indata$mid[i])])
 res <- c( res, setdiff( union(hasf,hasm), intersect(hasf,hasm) ) )
 unique(res[res != indata$id[i]])
                             }, 
                 simplify=TRUE )
Hsibs


###################################################
### code chunk number 7: siblings.rnw:121-129
###################################################
names(  sibs ) <-
names( Hsibs ) <-
names( Fsibs ) <-
names( msibs ) <-
names( fsibs ) <- indata$id
sibs
Hsibs
Fsibs


###################################################
### code chunk number 8: siblings.rnw:132-158
###################################################
mx <- 5
NAfill <- function( x ) c(x,rep(NA,mx))[1:mx]

db <- data.frame( id = as.numeric(names(sibs)),
                  do.call( rbind, lapply( sibs, NAfill ) ) )
names( db )[-1] <- paste("s",1:mx,sep="")
db

ms <- data.frame( id = as.numeric(names(msibs)),
                  do.call( rbind, lapply( msibs, NAfill ) ) )
names( ms )[-1] <- paste("m",1:mx,sep="")
ms

fs <- data.frame( id = as.numeric(names(fsibs)),
                  do.call( rbind, lapply( fsibs, NAfill ) ) )
names( ms )[-1] <- paste("f",1:mx,sep="")
fs

Fs <- data.frame( id = as.numeric(names(Fsibs)),
                  do.call( rbind, lapply( Fsibs, NAfill ) ) )
names( Fs )[-1] <- paste("F",1:mx,sep="")

Hs <- data.frame( id = as.numeric(names(Hsibs)),
                  do.call( rbind, lapply( Hsibs, NAfill ) ) )
names( Hs )[-1] <- paste("H",1:mx,sep="")
merge( Fs, Hs )


###################################################
### code chunk number 9: siblings.rnw:163-173
###################################################
indata <- idat
library(data.table)
setDT(indata)[,msib  := .(list(id)), by = "mid"][
              ,msibs := mapply(setdiff, msib, id)][ 
              ,fsib  := .(list(id)), by = "fid"][
              ,fsibs := mapply(setdiff, fsib, id)][
              ,sibs  := mapply(union, msibs, fsibs)][
              ,c("msib","msibs", "fsib", "fsibs") := NULL]
indata
str( indata )


###################################################
### code chunk number 10: siblings.rnw:176-180
###################################################
(DT <- data.table(indata))
( sibDT = DT[!is.na(fid) & !is.na(mid),
             CJ(id = id, sid = id)[id != sid]
            ,by=.(fid, mid)] )


###################################################
### code chunk number 11: siblings.rnw:183-186 (eval = FALSE)
###################################################
## hsibDT = melt(DT, id = id)[!is.na(value), 
##               CJ(id = id, hsid = id)[id != hsid]
##               , by=.(ptype = variable, pid = value)][!sibDT, on=.(id, hsid = sid)]