R/seedmatrix_function.R
In GIST-ORNL/revengc: Reverse Engineering Summarized Data
library(stringr)
library(dplyr)
# source("R/format_data_for_functions.R")
seedmatrix<-function(censoredtable, Xlowerbound, Xupperbound, Ylowerbound, Yupperbound){
# ################################################################################## start functions that help format data first
#The findtypeofcensoring_univariatetable function regonizes the symbols and divides a frequency table up into the 6 censored cases
findtypeofcensoring_univariatetable<-function (univariatefreqtable){
#making a dataframe from the category case (column one)
cases<-data.frame(univariatefreqtable)
cases<-cases[1]
#relabeled column with censoring as Censoring_Symbol
names(cases) <- c("Censoring_Symbol")
# changed lowercase up uppercase if users input "l, le, i, g, ge"
cases$Censoring_Symbol<-toupper(as.matrix(cases$Censoring_Symbol))
#will list censoring type in column called Type_of_Censoring
cases$Type_of_Censoring <- ""
#find what numbers go with censoring and put it in censor_number column
cases$Censor_Number<-str_replace_all(cases$Censoring_Symbol, "[-,<,<=,>,>=,+,\\,]", " ")
cases$Censor_Number<-str_replace_all(cases$Censor_Number, "[L, LE, I, G, GE]", " ")
cases$Censor_Number<-str_replace_all(cases$Censor_Number, "[l, le, i, g, ge]", " ")
# remove numbers from censoring_symbol column
cases$Censoring_Symbol<-gsub('[0-9]+', '', cases$Censoring_Symbol)
cases$Censoring_Symbol<-gsub('\\.', '', cases$Censoring_Symbol)
#named the symbols allowed in model
L1 <- c("<")
L1a <- c("L")
L2 <- c("<=")
L2a <- c("LE")
I <- c("-")
Ia <- c("I")
G1 <- c(">")
G1a <- c("G")
G2 <- c(">=")
G2a<-c("[+]")
G2b<-c("GE")
# remove any spaces found in symbol column
cases$Censoring_Symbol<-gsub('\\s+', '', cases$Censoring_Symbol)
#look to see if these symbols are in the provided table
leftcensorcase1<-grep("^<$", cases$Censoring_Symbol)
leftcensorcase1a<-grep("^L$", cases$Censoring_Symbol)
leftcensorcase2<-grep("^<=$", cases$Censoring_Symbol)
leftcensorcase2a<-grep("^LE$", cases$Censoring_Symbol)
intervalcensor<-grep("^[-]$", cases$Censoring_Symbol)
intervalcensora<-grep("^I$", cases$Censoring_Symbol)
rightcensorcase1<-grep("^>$", cases$Censoring_Symbol)
rightcensorcase1a<-grep("^G$", cases$Censoring_Symbol)
rightcensorcase2<-grep("^>=$", cases$Censoring_Symbol)
rightcensorcase2a<-grep("^[+]$", cases$Censoring_Symbol)
rightcensorcase2b<-grep("^GE$", cases$Censoring_Symbol)
#if the cases were there then this puts an L1, L2, I, G1, G2, or U in column called Type_of_Censoring
if (length(leftcensorcase1)>0){cases[which (str_detect(cases$Censoring_Symbol, L1)),"Type_of_Censoring"] <- "L1"}
if (length(leftcensorcase1a)>0){cases[which (str_detect(cases$Censoring_Symbol, L1a)),"Type_of_Censoring"] <- "L1a"}
if (length(leftcensorcase2)>0){cases[which (str_detect(cases$Censoring_Symbol, L2)),"Type_of_Censoring"] <- "L2"}
if (length(leftcensorcase2a)>0){cases[which (str_detect(cases$Censoring_Symbol, L2a)),"Type_of_Censoring"] <- "L2a"}
if (length(intervalcensor)>0){cases[which (str_detect(cases$Censoring_Symbol, I)),"Type_of_Censoring"] <- "I"}
if (length(intervalcensora)>0){cases[which (str_detect(cases$Censoring_Symbol, Ia)),"Type_of_Censoring"] <- "Ia"}
if (length(rightcensorcase1)>0){cases[which (str_detect(cases$Censoring_Symbol, G1)),"Type_of_Censoring"] <- "G1"}
if (length(rightcensorcase1a)>0){cases[which (str_detect(cases$Censoring_Symbol, G1a)),"Type_of_Censoring"] <- "G1a"}
if (length(rightcensorcase2)>0){cases[which (str_detect(cases$Censoring_Symbol, G2)),"Type_of_Censoring"] <- "G2"}
if (length(rightcensorcase2a)>0){cases[which (str_detect(cases$Censoring_Symbol, G2a)),"Type_of_Censoring"] <- "G2a"}
if (length(rightcensorcase2b)>0){cases[which (str_detect(cases$Censoring_Symbol, G2b)),"Type_of_Censoring"] <- "G2b"}
#make all the different labels of censoring consistent
cases$Type_of_Censoring[cases$Type_of_Censoring =="L1a"]<-c("L1")
cases$Type_of_Censoring[cases$Type_of_Censoring =="L2a"]<-c("L2")
cases$Type_of_Censoring[cases$Type_of_Censoring =="Ia"]<-c("I")
cases$Type_of_Censoring[cases$Type_of_Censoring =="G1a"]<-c("G1")
cases$Type_of_Censoring[cases$Type_of_Censoring =="G2a"]<-c("G2")
cases$Type_of_Censoring[cases$Type_of_Censoring =="G2b"]<-c("G2")
#listing the no censoring cases as "U"
cases$Type_of_Censoring[cases$Type_of_Censoring==""]<-"U"
#put in errors to let users know that there can't be duplicates of Greater than or Less than
if(length(grep("G1", cases$Type_of_Censoring))>1) stop ('Censored table can only have 1 greater than (> or G) category')
if(length(grep("G2", cases$Type_of_Censoring))>1) stop ('Censored table can only have 1 greater than or equal to (>= or GE) category')
if(length(grep("L2", cases$Type_of_Censoring))>1) stop ('Censored table can only have 1 less than or equal to (<= or LE) category')
if(length(grep("L1", cases$Type_of_Censoring))>1) stop ('Censored table can only have 1 less than (< or L) category')
if(length(grep("L1", cases$Type_of_Censoring))>1) stop ('Censored table can only have 1 less than (< or L) category')
if(length(grep("L1", cases$Type_of_Censoring))==1 && length(grep("L2", cases$Type_of_Censoring))==1) stop ('Censored table can not have both a less than (< or L) category and a less than or equal to category (<= or LE)')
if(length(grep("G1", cases$Type_of_Censoring))==1 && length(grep("G2", cases$Type_of_Censoring))==1) stop ('Censored table can not have both a greater than (< or G) category and a greater than or equal to category (<= or GE)')
return (cases)} #end findtypeofcensoring_univariatetable function
#####
#####
#The fixdata_univariatecase function regonizes the symbols and divides a frequency table up into the 6 censored cases
#This is a formatting data function
#This uses the findtypeofcensoring_univariatetable function
fixdata_univariatecase<-function(univariatefreqtable) {
# conduct findtypeofcensoring_univariatetable function on data
cases<-findtypeofcensoring_univariatetable(data.frame(univariatefreqtable))
#gives a row number for each of the 6 censoring types
lo1<-as.numeric(which(cases$Type_of_Censoring=='L1'))
lo2<-as.numeric(which(cases$Type_of_Censoring=='L2'))
inte<-as.numeric(which(cases$Type_of_Censoring=='I'))
gre1<-as.numeric(which(cases$Type_of_Censoring=='G1'))
gre2<-as.numeric(which(cases$Type_of_Censoring=='G2'))
ex<-as.numeric(which(cases$Type_of_Censoring=='U'))
#finding what number corresponds to the freqency value based off type of censoring
#put as.numeric and as.character to help with format
#R was changing decimals to whole numbers without putting as.numeric and as.character
countl1<-as.numeric(as.character(univariatefreqtable[lo1,2]))
countl2<-as.numeric(as.character(univariatefreqtable[lo2,2]))
counti<-as.numeric(as.character(univariatefreqtable[inte,2]))
countg1<-as.numeric(as.character(univariatefreqtable[gre1,2]))
countg2<-as.numeric(as.character(univariatefreqtable[gre2,2]))
counte<-as.numeric(as.character(univariatefreqtable[ex,2]))
#finding what number (in the Censor_Number) corresponds to the censor type
#values listed in cases$Censor_Number[] are factors
#intervalnumber will be as.vector because will have to run strsplit function on this value later
lowernumber1<-as.numeric(as.character(cases$Censor_Number[lo1]))
lowernumber2<-as.numeric(as.character(cases$Censor_Number[lo2]))
intervalnumber<-as.vector(cases$Censor_Number[inte])
greaternumber1<-as.numeric(as.character(cases$Censor_Number[gre1]))
greaternumber2<-as.numeric(as.character(cases$Censor_Number[gre2]))
exactnumber<-as.numeric(as.character(cases$Censor_Number[ex]))
#combining the category number (without its symbol) and the freqency number that corresponds to that category number
lower1<-t(c(lowernumber1,countl1))
lower2<-t(c(lowernumber2,countl2))
greater1<-t(c(greaternumber1,countg1))
greater2<-t(c(greaternumber2,countg2))
#unlike the left and right censor categories there could be multiple of the no censored category
exact<-unname(rbind(exactnumber,counte))
#spliting the interval(s)
if (length(intervalnumber)>0){
spl<-na.omit(as.numeric(unlist(strsplit(intervalnumber,' ', fixed=FALSE))))
interval<-matrix(spl,length(intervalnumber),2,byrow=TRUE)
interval<-unname(cbind(interval,counti))
} else {interval=NULL}
# testing to see if intervals are closed..
if (length(interval)!=0){
intervalclosed<-as.vector(interval[,1:2])
if (any(duplicated(intervalclosed))==TRUE) stop (paste(intervalclosed[which(duplicated(intervalclosed)==TRUE)],
'is repeated in different - or I categories and this is not allowed (i.e. need closed intervals)'))
}
#return values for later use
final<-list(leftcensored1=lower1,leftcensored2=lower2, nocensored=exact,
rightcensored1=greater1,
rightcensored2=greater2, intervalcensored=interval
# lowerbound = lowerbound,
# upperbound=upperbound
)
#replacing any negative numbers with 0
#there might be negative numbers, but these negative values will cause error in the likelihood function
final<-rapply(final,function(x) ifelse(x<0,0,x), how = "replace")
# add errors
if(length(final$leftcensored2)!= 0 && length(final$intervalcensored) != 0 &&
final$leftcensored2[1,1] == final$intervalcensored[1,1]) stop ('Censored table can not have the same number in both the <= or LE category and the - or I category (i.e. need closed intervals)')
if(length(final$rightcensored2)!= 0 && length(final$intervalcensored) != 0 &&
final$rightcensored2[1,1] == final$intervalcensored[nrow(final$intervalcensored),2]) stop ('Censored table can not have the same number in both the >= or GE or + category and the - or I category (i.e. need closed intervals)')
return(final)
} #end fixdata_univariatecase function
# ################################################################################## end functions that help format data first
# looking at provided table
# griding the row and col names
rnames<-findtypeofcensoring_univariatetable(row.marginal(censoredtable))$Type_of_Censoring
cnames<-findtypeofcensoring_univariatetable(column.marginal(censoredtable))$Type_of_Censoring
# tn = table names
tn_expaned<-expand.grid(rnames, cnames)
# removing marginals to get to inside of table
# br = bottom row, tr = top row, rc = right column, and lc = left column
brgone<-censoredtable[-nrow(censoredtable),]
# for removing the top row we have to also accounte for if user read in csv with header=TRUE or header=FALSE
if (any(na.omit(colnames(censoredtable))=="V1")) {trgone=brgone[-1,]} else {trgone=unname(brgone)}
rcgone<-trgone[, -ncol(trgone)]
lcgone<-rcgone[,-1]
Inside<-matrix(as.matrix(lcgone), dim(data.frame(lcgone))*dim(data.frame(lcgone))[2], 1)
#r emoving commas from inside of table
inside<-str_replace_all(Inside,",","")
suminside<-sum(as.numeric(inside))
# make probabilities
if (suminside != 1) {inside<-as.numeric(inside)/sum(as.numeric(inside))}
# put inside table with corresponding rows and cols
tn_expaned$repvar<-inside
names(tn_expaned)<-c("row", "col", "inside")
tn_expaned$rowcol<-paste(tn_expaned$row, tn_expaned$col, sep = "_")
# final inside of table with censoring symbols
tn_expaned<-tn_expaned[3:4]
# find numbers for each name
rnumb<-findtypeofcensoring_univariatetable(row.marginal(censoredtable))$Censor_Number
cnumb<-findtypeofcensoring_univariatetable(column.marginal(censoredtable))$Censor_Number
# remove spaces from the numbers
rnumb<-gsub(" ", "", rnumb)
cnumb<-gsub(" ", "", cnumb)
# expand grid for numbers just like did for censored symbols
rowandcolnumb<-expand.grid(rnumb, cnumb)
# final inside of table with censoring symbols and numbers
tn_expaned<-cbind(tn_expaned, "Numbers" = paste(rowandcolnumb$Var1, rowandcolnumb$Var2, sep = "_"))
# create merge column for later..
tn_expaned<-cbind(tn_expaned, "Censoring_Numbers" = paste(tn_expaned$rowcol, tn_expaned$Numbers, sep = "_"))[-c(2,3)]
# run function to know cases of the provided table
# quasipoisson_phiX and quasipoisson_phiY doesn't actually equal one.. just a place filler
repx<-fixdata_univariatecase(row.marginal(censoredtable))
repy<-fixdata_univariatecase(column.marginal(censoredtable))
# uncensored table names expaned grid
tn_expand_new<-expand.grid(Xlowerbound:Xupperbound, Ylowerbound:Yupperbound)
# function to give censoring symbols/pasted numbers to tn_expand_new
##########
censoringtypeforuncensoredtable<-function (tn_expand_new,repx,repy ){
# get rid of count values in repx
if(length(repx$leftcensored1)!=0) {repx$leftcensored1<-repx$leftcensored1[1,1]}
if(length(repx$leftcensored2)!=0) {repx$leftcensored2<-repx$leftcensored2[1,1]}
if(length(repx$intervalcensored)!=0) {repx$intervalcensored<-repx$intervalcensored[,c(1,2)]}
if(length(repx$rightcensored1)!=0) {repx$rightcensored1<-repx$rightcensored1[1,1]}
if(length(repx$rightcensored2)!=0) {repx$rightcensored2<-repx$rightcensored2[1,1]}
if(length(repx$nocensored)!=0) {repx$nocensored<-repx$nocensored[1,]}
# get rid of count values in repy
if(length(repy$leftcensored1)!=0) {repy$leftcensored1<-repy$leftcensored1[1,1]}
if(length(repy$leftcensored2)!=0) {repy$leftcensored2<-repy$leftcensored2[1,1]}
if(length(repy$intervalcensored)!=0) {repy$intervalcensored<-repy$intervalcensored[,c(1,2)]}
if(length(repy$rightcensored1)!=0) {repy$rightcensored1<-repy$rightcensored1[1,1]}
if(length(repy$rightcensored2)!=0) {repy$rightcensored2<-repy$rightcensored2[1,1]}
if(length(repy$nocensored)!=0) {repy$nocensored<-repy$nocensored[1,]}
# function for to find what uncensored number falls between inteval values
findinterval<-function (x, y){
if (is.null(nrow(y))) {y=paste0(y[1], y[2])} else {
result = NULL
for (i in 1:nrow(y)){
if(x>=y[i,1] && x <=y[i,2]) {result[i]<-c("yes")} else {result[i]<-c("no")}
}
y = y[which(result=="yes"),]
y = paste0(y[1], y[2])
} # end else statement
return(y)
}
### going through the 36 cases..
# case where row x has L1
if (length(repx$leftcensored1) != 0){
if (length(repy$leftcensored1)!=0){
if(tn_expand_new$Var1<repx$leftcensored1 && tn_expand_new$Var2<repy$leftcensored1) {
tn_expand_new$rowcol<-c("L1_L1")
tn_expand_new$Numbers<-paste(repx$leftcensored1, repy$leftcensored1, sep = "_")
} }
if (length(repy$leftcensored2)!=0){
if(tn_expand_new$Var1<repx$leftcensored1 && tn_expand_new$Var2<=repy$leftcensored2) {
tn_expand_new$rowcol<-c("L1_L2")
tn_expand_new$Numbers<-paste(repx$leftcensored1, repy$leftcensored2, sep = "_")
} }
if (length(repy$intervalcensored)!=0){
if(tn_expand_new$Var1<repx$leftcensored1 && tn_expand_new$Var2>=min(repy$intervalcensored) && tn_expand_new$Var2<=max(repy$intervalcensored)) {
tn_expand_new$rowcol<-c("L1_I")
tn_expand_new$Numbers<-paste(repx$leftcensored1, findinterval(tn_expand_new$Var2, repy$intervalcensored), sep = "_")
} }
if (length(repy$rightcensored1)!=0){
if(tn_expand_new$Var1<repx$rightcensored1 && tn_expand_new$Var2>repy$rightcensored1) {
tn_expand_new$rowcol<-c("L1_G1")
tn_expand_new$Numbers<-paste(repx$leftcensored1, repy$rightcensored1, sep = "_")
} }
if (length(repy$rightcensored2)!=0){
if(tn_expand_new$Var1<repx$leftcensored1 && tn_expand_new$Var2>=repy$rightcensored2) {
tn_expand_new$rowcol<-c("L1_G2")
tn_expand_new$Numbers<-paste(repx$leftcensored1, repy$rightcensored2, sep = "_")
} }
if (length(repy$nocensored)!=0){
if(tn_expand_new$Var1<repx$leftcensored1 && any(tn_expand_new$Var2==repy$nocensored)) {
tn_expand_new$rowcol<-c("L1_U")
matchingvalue<-which(tn_expand_new$Var2==repy$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$leftcensored1, repy$nocensored[matchingvalue], sep = "_")
} }
} # end case where row x has L1
#############################
# case where row x has L2
if (length(repx$leftcensored2) != 0){
if (length(repy$leftcensored1)!=0){
if(tn_expand_new$Var1<=repx$leftcensored2 && tn_expand_new$Var2<repy$leftcensored1) {
tn_expand_new$rowcol<-c("L2_L1")
tn_expand_new$Numbers<-paste(repx$leftcensored2, repy$leftcensored1, sep = "_")
} }
if (length(repy$leftcensored2)!=0){
if(tn_expand_new$Var1<=repx$leftcensored2 && tn_expand_new$Var2<=repy$leftcensored2) {
tn_expand_new$rowcol<-c("L2_L2")
tn_expand_new$Numbers<-paste(repx$leftcensored2, repy$leftcensored2, sep = "_")
} }
if (length(repy$intervalcensored)!=0){
if(tn_expand_new$Var1<=repx$leftcensored2 && tn_expand_new$Var2>=min(repy$intervalcensored) && tn_expand_new$Var2<=max(repy$intervalcensored)) {
tn_expand_new$rowcol<-c("L2_I")
tn_expand_new$Numbers<-paste(repx$leftcensored2, findinterval(tn_expand_new$Var2, repy$intervalcensored), sep = "_")
} }
if (length(repy$rightcensored1)!=0){
if(tn_expand_new$Var1<=repx$rightcensored1 && tn_expand_new$Var2>repy$rightcensored1) {
tn_expand_new$rowcol<-c("L2_G1")
tn_expand_new$Numbers<-paste(repx$leftcensored2, repy$rightcensored1, sep = "_")
} }
if (length(repy$rightcensored2)!=0){
if(tn_expand_new$Var1<=repx$leftcensored2 && tn_expand_new$Var2>=repy$rightcensored2) {
tn_expand_new$rowcol<-c("L2_G2")
tn_expand_new$Numbers<-paste(repx$leftcensored2, repy$rightcensored2, sep = "_")
} }
if (length(repy$nocensored)!=0){
if(tn_expand_new$Var1<=repx$leftcensored2 && any(tn_expand_new$Var2==repy$nocensored)) {
tn_expand_new$rowcol<-c("L2_U")
matchingvalue<-which(tn_expand_new$Var2==repy$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$leftcensored2, repy$nocensored[matchingvalue], sep = "_")
} }
} # end case where row x has L2
#############################
# case where row x has G1
if (length(repx$rightcensored1) != 0){
if (length(repy$leftcensored1)!=0){
if(tn_expand_new$Var1>repx$rightcensored1 && tn_expand_new$Var2<repy$leftcensored1) {
tn_expand_new$rowcol<-c("G1_L1")
tn_expand_new$Numbers<-paste(repx$rightcensored1, repy$leftcensored1, sep = "_")
} }
if (length(repy$leftcensored2)!=0){
if(tn_expand_new$Var1>repx$rightcensored1 && tn_expand_new$Var2<=repy$leftcensored2) {
tn_expand_new$rowcol<-c("G1_L2")
tn_expand_new$Numbers<-paste(repx$rightcensored1, repy$leftcensored2, sep = "_")
} }
if (length(repy$intervalcensored)!=0){
if(tn_expand_new$Var1>repx$rightcensored1 && tn_expand_new$Var2>=min(repy$intervalcensored) && tn_expand_new$Var2<=max(repy$intervalcensored)) {
tn_expand_new$rowcol<-c("G1_I")
tn_expand_new$Numbers<-paste(repx$rightcensored1, findinterval(tn_expand_new$Var2, repy$intervalcensored), sep = "_")
} }
if (length(repy$rightcensored1)!=0){
if(tn_expand_new$Var1>repx$rightcensored1 && tn_expand_new$Var2>repy$rightcensored1) {
tn_expand_new$rowcol<-c("G1_G1")
tn_expand_new$Numbers<-paste(repx$rightcensored1, repy$rightcensored1, sep = "_")
} }
if (length(repy$rightcensored2)!=0){
if(tn_expand_new$Var1>repx$rightcensored1 && tn_expand_new$Var2>=repy$rightcensored2) {
tn_expand_new$rowcol<-c("G1_G2")
tn_expand_new$Numbers<-paste(repx$rightcensored1, repy$rightcensored2, sep = "_")
} }
if (length(repy$nocensored)!=0){
if(tn_expand_new$Var1>repx$rightcensored1 && any(tn_expand_new$Var2==repy$nocensored)) {
tn_expand_new$rowcol<-c("G1_U")
matchingvalue<-which(tn_expand_new$Var2==repy$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$rightcensored1, repy$nocensored[matchingvalue], sep = "_")
} }
} # end case where row x has G1
#############################
# case where row x has G2
if (length(repx$rightcensored2) != 0){
if (length(repy$leftcensored1)!=0){
if(tn_expand_new$Var1>=repx$rightcensored2 && tn_expand_new$Var2<repy$leftcensored1) {
tn_expand_new$rowcol<-c("G2_L1")
tn_expand_new$Numbers<-paste(repx$rightcensored2, repy$leftcensored1, sep = "_")
} }
if (length(repy$leftcensored2)!=0){
if(tn_expand_new$Var1>=repx$rightcensored2 && tn_expand_new$Var2<=repy$leftcensored2) {
tn_expand_new$rowcol<-c("G2_L2")
tn_expand_new$Numbers<-paste(repx$rightcensored2, repy$leftcensored2, sep = "_")
} }
if (length(repy$intervalcensored)!=0){
if(tn_expand_new$Var1>=repx$rightcensored2 && tn_expand_new$Var2>=min(repy$intervalcensored) && tn_expand_new$Var2<=max(repy$intervalcensored)) {
tn_expand_new$rowcol<-c("G2_I")
tn_expand_new$Numbers<-paste(repx$rightcensored2, findinterval(tn_expand_new$Var2, repy$intervalcensored), sep = "_")
} }
if (length(repy$rightcensored1)!=0){
if(tn_expand_new$Var1>=repx$rightcensored2 && tn_expand_new$Var2>repy$rightcensored1) {
tn_expand_new$rowcol<-c("G2_G1")
tn_expand_new$Numbers<-paste(repx$rightcensored2, repy$rightcensored1, sep = "_")
} }
if (length(repy$rightcensored2)!=0){
if(tn_expand_new$Var1>=repx$rightcensored2 && tn_expand_new$Var2>=repy$rightcensored2) {
tn_expand_new$rowcol<-c("G2_G2")
tn_expand_new$Numbers<-paste(repx$rightcensored2, repy$rightcensored2, sep = "_")
} }
if (length(repy$nocensored)!=0){
if(tn_expand_new$Var1>=repx$rightcensored2 && any(tn_expand_new$Var2==repy$nocensored)) {
tn_expand_new$rowcol<-c("G2_U")
matchingvalue<-which(tn_expand_new$Var2==repy$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$rightcensored2, repy$nocensored[matchingvalue], sep = "_")
} }
} # end case where row x has G2
#############################
# case where row x has U
if (length(repx$nocensored) != 0){
if (length(repy$leftcensored1)!=0){
if(any(tn_expand_new$Var1==repx$nocensored) && tn_expand_new$Var2<repy$leftcensored1) {
tn_expand_new$rowcol<-c("U_L1")
matchingvalue<-which(tn_expand_new$Var1==repx$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$nocensored[matchingvalue], repy$leftcensored1, sep = "_")
} }
if (length(repy$leftcensored2)!=0){
if(any(tn_expand_new$Var1==repx$nocensored) && tn_expand_new$Var2<=repy$leftcensored2) {
tn_expand_new$rowcol<-c("U_L2")
matchingvalue<-which(tn_expand_new$Var1==repx$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$nocensored[matchingvalue], repy$leftcensored2, sep = "_")
} }
if (length(repy$intervalcensored)!=0){
if(any(tn_expand_new$Var1==repx$nocensored) && tn_expand_new$Var2>=min(repy$intervalcensored) && tn_expand_new$Var2<=max(repy$intervalcensored)) {
tn_expand_new$rowcol<-c("U_I")
matchingvalue<-which(tn_expand_new$Var1==repx$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$nocensored[matchingvalue], findinterval(tn_expand_new$Var2, repy$intervalcensored), sep = "_")
} }
if (length(repy$rightcensored1)!=0){
if(any(tn_expand_new$Var1==repx$nocensored) && tn_expand_new$Var2>repy$rightcensored1) {
tn_expand_new$rowcol<-c("U_G1")
matchingvalue<-which(tn_expand_new$Var1==repx$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$nocensored[matchingvalue], repy$rightcensored1, sep = "_")
} }
if (length(repy$rightcensored2)!=0){
if(any(tn_expand_new$Var1==repx$nocensored) && tn_expand_new$Var2>=repy$rightcensored2) {
tn_expand_new$rowcol<-c("U_G2")
matchingvalue<-which(tn_expand_new$Var1==repx$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$nocensored[matchingvalue], repy$rightcensored2, sep = "_")
} }
if (length(repy$nocensored)!=0){
if(any(tn_expand_new$Var1==repx$nocensored) && any(tn_expand_new$Var2==repy$nocensored)) {
tn_expand_new$rowcol<-c("U_U")
matchingvalue1<-which(tn_expand_new$Var1==repx$nocensored, arr.ind=TRUE)
matchingvalue2<-which(tn_expand_new$Var2==repy$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$nocensored[matchingvalue1], repy$nocensored[matchingvalue2], sep = "_")
} }
} # end case where row x has U
#############################
# case where row x has I
if (length(repx$intervalcensored) != 0){
if (length(repy$leftcensored1)!=0){
if(tn_expand_new$Var1>=min(repx$intervalcensored) && tn_expand_new$Var1<=max(repx$intervalcensored) && tn_expand_new$Var2<repy$leftcensored1) {
tn_expand_new$rowcol<-c("I_L1")
tn_expand_new$Numbers<-paste(findinterval(tn_expand_new$Var1, repx$intervalcensored), repy$leftcensored1, sep = "_")
} }
if (length(repy$leftcensored2)!=0){
if(tn_expand_new$Var1>=min(repx$intervalcensored) && tn_expand_new$Var1<=max(repx$intervalcensored) && tn_expand_new$Var2<=repy$leftcensored2) {
tn_expand_new$rowcol<-c("I_L2")
tn_expand_new$Numbers<-paste(findinterval(tn_expand_new$Var1, repx$intervalcensored), repy$leftcensored2, sep = "_")
} }
if (length(repy$intervalcensored)!=0){
if(tn_expand_new$Var1>=min(repx$intervalcensored) && tn_expand_new$Var1<=max(repx$intervalcensored) && tn_expand_new$Var2>=min(repy$intervalcensored) && tn_expand_new$Var2<=max(repy$intervalcensored)) {
tn_expand_new$rowcol<-c("I_I")
tn_expand_new$Numbers<-paste(findinterval(tn_expand_new$Var1, repx$intervalcensored), findinterval(tn_expand_new$Var2, repy$intervalcensored), sep = "_")
} }
if (length(repy$rightcensored1)!=0){
if(tn_expand_new$Var1>=min(repx$intervalcensored) && tn_expand_new$Var1<=max(repx$intervalcensored) && tn_expand_new$Var2>repy$rightcensored1) {
tn_expand_new$rowcol<-c("I_G1")
tn_expand_new$Numbers<-paste(findinterval(tn_expand_new$Var1, repx$intervalcensored), repy$rightcensored1, sep = "_")
} }
if (length(repy$rightcensored2)!=0){
if(tn_expand_new$Var1>=min(repx$intervalcensored) && tn_expand_new$Var1<=max(repx$intervalcensored) && tn_expand_new$Var2>=repy$rightcensored2) {
tn_expand_new$rowcol<-c("I_G2")
tn_expand_new$Numbers<-paste(findinterval(tn_expand_new$Var1, repx$intervalcensored), repy$rightcensored2, sep = "_")
} }
if (length(repy$nocensored)!=0){
if(tn_expand_new$Var1>=min(repx$intervalcensored) && tn_expand_new$Var1<=max(repx$intervalcensored) && any(tn_expand_new$Var2==repy$nocensored)) {
tn_expand_new$rowcol<-c("I_U")
matchingvalue<-which(tn_expand_new$Var2==repy$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(findinterval(tn_expand_new$Var1, repx$intervalcensored), repy$nocensored[matchingvalue], sep = "_")
} }
} # end case where row x has I
### end 36 cases..
# checking if user didn't censor correctly
if(any(tn_expand_new$rowcol=="") ==TRUE) stop('Check Censoring.')
# make merge column
tn_expand_new$Censoring_Numbers<-paste(tn_expand_new$rowcol, tn_expand_new$Numbers, sep = "_")
tn_expand_new<-tn_expand_new[, c("Var1", "Var2", "Censoring_Numbers")]
# return main function
return(tn_expand_new)}
# end function to give censoring symbols/pasted numbers to tn_expand_new
##########
# run function over all tn_expand_new
final= NULL
for (i in 1:nrow(tn_expand_new)){
final[[i]]<-censoringtypeforuncensoredtable(tn_expand_new=tn_expand_new[i,],repx=repx, repy = repy)
}
# dataframe with censoring symbols and numbers for all uncensored variables
final<-data.frame(matrix(unlist(final), nrow(tn_expand_new), 3, byrow =TRUE))
names(final)<-c("row", "col", "Censoring_Numbers")
# merge dataframe with censoring symbols and numbers for all uncensored variables (final) with tn_expanded so can get inside of table values
insidefortable<-inner_join(final, tn_expaned, by= c("Censoring_Numbers"))
# need to replace row and col values that start at 1:length of rows/cols to fill in table properly
rowreplace<-data.frame("row" = Xlowerbound:Xupperbound, "Wantr" = 1:(length(Xlowerbound:Xupperbound)))
colreplace<-data.frame("col" = Ylowerbound:Yupperbound, "Wantc" = 1:(length(Ylowerbound:Yupperbound)))
# mergining the new values to old
# inner_join has to have same class
insidefortable$row<-as.numeric(as.character(insidefortable$row))
rowreplacetable<-inner_join(insidefortable, rowreplace, by = c("row"))
rowreplacetable$col<-as.numeric(as.character(rowreplacetable$col))
colreplacetable<-inner_join(rowreplacetable, colreplace, by = c("col"))
# grab only columns needed
insidefortable<-colreplacetable
insidefortable<-insidefortable[,c("Wantr", "Wantc", "inside")]
colnames(insidefortable)[3]<-c("inside")
# create seed matrix
seed<-matrix(as.numeric(""), length(Xlowerbound:Xupperbound) , length(Ylowerbound:Yupperbound))
# fill seed
for (i in 1:nrow(insidefortable)) {
seed[insidefortable[i,1], insidefortable[i,2]]<-as.numeric(insidefortable[i,3])
}
colnames(seed)<-Ylowerbound:Yupperbound
row.names(seed)<-Xlowerbound:Xupperbound
seedp<-seed/sum(seed)
return(list("Exact"=seed,"Probabilities"=seedp))
} # end seed function
GIST-ORNL/revengc documentation built on May 29, 2019, 12:22 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
library(stringr)
library(dplyr)
# source("R/format_data_for_functions.R")
seedmatrix<-function(censoredtable, Xlowerbound, Xupperbound, Ylowerbound, Yupperbound){
# ################################################################################## start functions that help format data first
#The findtypeofcensoring_univariatetable function regonizes the symbols and divides a frequency table up into the 6 censored cases
findtypeofcensoring_univariatetable<-function (univariatefreqtable){
#making a dataframe from the category case (column one)
cases<-data.frame(univariatefreqtable)
cases<-cases[1]
#relabeled column with censoring as Censoring_Symbol
names(cases) <- c("Censoring_Symbol")
# changed lowercase up uppercase if users input "l, le, i, g, ge"
cases$Censoring_Symbol<-toupper(as.matrix(cases$Censoring_Symbol))
#will list censoring type in column called Type_of_Censoring
cases$Type_of_Censoring <- ""
#find what numbers go with censoring and put it in censor_number column
cases$Censor_Number<-str_replace_all(cases$Censoring_Symbol, "[-,<,<=,>,>=,+,\\,]", " ")
cases$Censor_Number<-str_replace_all(cases$Censor_Number, "[L, LE, I, G, GE]", " ")
cases$Censor_Number<-str_replace_all(cases$Censor_Number, "[l, le, i, g, ge]", " ")
# remove numbers from censoring_symbol column
cases$Censoring_Symbol<-gsub('[0-9]+', '', cases$Censoring_Symbol)
cases$Censoring_Symbol<-gsub('\\.', '', cases$Censoring_Symbol)
#named the symbols allowed in model
L1 <- c("<")
L1a <- c("L")
L2 <- c("<=")
L2a <- c("LE")
I <- c("-")
Ia <- c("I")
G1 <- c(">")
G1a <- c("G")
G2 <- c(">=")
G2a<-c("[+]")
G2b<-c("GE")
# remove any spaces found in symbol column
cases$Censoring_Symbol<-gsub('\\s+', '', cases$Censoring_Symbol)
#look to see if these symbols are in the provided table
leftcensorcase1<-grep("^<$", cases$Censoring_Symbol)
leftcensorcase1a<-grep("^L$", cases$Censoring_Symbol)
leftcensorcase2<-grep("^<=$", cases$Censoring_Symbol)
leftcensorcase2a<-grep("^LE$", cases$Censoring_Symbol)
intervalcensor<-grep("^[-]$", cases$Censoring_Symbol)
intervalcensora<-grep("^I$", cases$Censoring_Symbol)
rightcensorcase1<-grep("^>$", cases$Censoring_Symbol)
rightcensorcase1a<-grep("^G$", cases$Censoring_Symbol)
rightcensorcase2<-grep("^>=$", cases$Censoring_Symbol)
rightcensorcase2a<-grep("^[+]$", cases$Censoring_Symbol)
rightcensorcase2b<-grep("^GE$", cases$Censoring_Symbol)
#if the cases were there then this puts an L1, L2, I, G1, G2, or U in column called Type_of_Censoring
if (length(leftcensorcase1)>0){cases[which (str_detect(cases$Censoring_Symbol, L1)),"Type_of_Censoring"] <- "L1"}
if (length(leftcensorcase1a)>0){cases[which (str_detect(cases$Censoring_Symbol, L1a)),"Type_of_Censoring"] <- "L1a"}
if (length(leftcensorcase2)>0){cases[which (str_detect(cases$Censoring_Symbol, L2)),"Type_of_Censoring"] <- "L2"}
if (length(leftcensorcase2a)>0){cases[which (str_detect(cases$Censoring_Symbol, L2a)),"Type_of_Censoring"] <- "L2a"}
if (length(intervalcensor)>0){cases[which (str_detect(cases$Censoring_Symbol, I)),"Type_of_Censoring"] <- "I"}
if (length(intervalcensora)>0){cases[which (str_detect(cases$Censoring_Symbol, Ia)),"Type_of_Censoring"] <- "Ia"}
if (length(rightcensorcase1)>0){cases[which (str_detect(cases$Censoring_Symbol, G1)),"Type_of_Censoring"] <- "G1"}
if (length(rightcensorcase1a)>0){cases[which (str_detect(cases$Censoring_Symbol, G1a)),"Type_of_Censoring"] <- "G1a"}
if (length(rightcensorcase2)>0){cases[which (str_detect(cases$Censoring_Symbol, G2)),"Type_of_Censoring"] <- "G2"}
if (length(rightcensorcase2a)>0){cases[which (str_detect(cases$Censoring_Symbol, G2a)),"Type_of_Censoring"] <- "G2a"}
if (length(rightcensorcase2b)>0){cases[which (str_detect(cases$Censoring_Symbol, G2b)),"Type_of_Censoring"] <- "G2b"}
#make all the different labels of censoring consistent
cases$Type_of_Censoring[cases$Type_of_Censoring =="L1a"]<-c("L1")
cases$Type_of_Censoring[cases$Type_of_Censoring =="L2a"]<-c("L2")
cases$Type_of_Censoring[cases$Type_of_Censoring =="Ia"]<-c("I")
cases$Type_of_Censoring[cases$Type_of_Censoring =="G1a"]<-c("G1")
cases$Type_of_Censoring[cases$Type_of_Censoring =="G2a"]<-c("G2")
cases$Type_of_Censoring[cases$Type_of_Censoring =="G2b"]<-c("G2")
#listing the no censoring cases as "U"
cases$Type_of_Censoring[cases$Type_of_Censoring==""]<-"U"
#put in errors to let users know that there can't be duplicates of Greater than or Less than
if(length(grep("G1", cases$Type_of_Censoring))>1) stop ('Censored table can only have 1 greater than (> or G) category')
if(length(grep("G2", cases$Type_of_Censoring))>1) stop ('Censored table can only have 1 greater than or equal to (>= or GE) category')
if(length(grep("L2", cases$Type_of_Censoring))>1) stop ('Censored table can only have 1 less than or equal to (<= or LE) category')
if(length(grep("L1", cases$Type_of_Censoring))>1) stop ('Censored table can only have 1 less than (< or L) category')
if(length(grep("L1", cases$Type_of_Censoring))>1) stop ('Censored table can only have 1 less than (< or L) category')
if(length(grep("L1", cases$Type_of_Censoring))==1 && length(grep("L2", cases$Type_of_Censoring))==1) stop ('Censored table can not have both a less than (< or L) category and a less than or equal to category (<= or LE)')
if(length(grep("G1", cases$Type_of_Censoring))==1 && length(grep("G2", cases$Type_of_Censoring))==1) stop ('Censored table can not have both a greater than (< or G) category and a greater than or equal to category (<= or GE)')
return (cases)} #end findtypeofcensoring_univariatetable function
#####
#####
#The fixdata_univariatecase function regonizes the symbols and divides a frequency table up into the 6 censored cases
#This is a formatting data function
#This uses the findtypeofcensoring_univariatetable function
fixdata_univariatecase<-function(univariatefreqtable) {
# conduct findtypeofcensoring_univariatetable function on data
cases<-findtypeofcensoring_univariatetable(data.frame(univariatefreqtable))
#gives a row number for each of the 6 censoring types
lo1<-as.numeric(which(cases$Type_of_Censoring=='L1'))
lo2<-as.numeric(which(cases$Type_of_Censoring=='L2'))
inte<-as.numeric(which(cases$Type_of_Censoring=='I'))
gre1<-as.numeric(which(cases$Type_of_Censoring=='G1'))
gre2<-as.numeric(which(cases$Type_of_Censoring=='G2'))
ex<-as.numeric(which(cases$Type_of_Censoring=='U'))
#finding what number corresponds to the freqency value based off type of censoring
#put as.numeric and as.character to help with format
#R was changing decimals to whole numbers without putting as.numeric and as.character
countl1<-as.numeric(as.character(univariatefreqtable[lo1,2]))
countl2<-as.numeric(as.character(univariatefreqtable[lo2,2]))
counti<-as.numeric(as.character(univariatefreqtable[inte,2]))
countg1<-as.numeric(as.character(univariatefreqtable[gre1,2]))
countg2<-as.numeric(as.character(univariatefreqtable[gre2,2]))
counte<-as.numeric(as.character(univariatefreqtable[ex,2]))
#finding what number (in the Censor_Number) corresponds to the censor type
#values listed in cases$Censor_Number[] are factors
#intervalnumber will be as.vector because will have to run strsplit function on this value later
lowernumber1<-as.numeric(as.character(cases$Censor_Number[lo1]))
lowernumber2<-as.numeric(as.character(cases$Censor_Number[lo2]))
intervalnumber<-as.vector(cases$Censor_Number[inte])
greaternumber1<-as.numeric(as.character(cases$Censor_Number[gre1]))
greaternumber2<-as.numeric(as.character(cases$Censor_Number[gre2]))
exactnumber<-as.numeric(as.character(cases$Censor_Number[ex]))
#combining the category number (without its symbol) and the freqency number that corresponds to that category number
lower1<-t(c(lowernumber1,countl1))
lower2<-t(c(lowernumber2,countl2))
greater1<-t(c(greaternumber1,countg1))
greater2<-t(c(greaternumber2,countg2))
#unlike the left and right censor categories there could be multiple of the no censored category
exact<-unname(rbind(exactnumber,counte))
#spliting the interval(s)
if (length(intervalnumber)>0){
spl<-na.omit(as.numeric(unlist(strsplit(intervalnumber,' ', fixed=FALSE))))
interval<-matrix(spl,length(intervalnumber),2,byrow=TRUE)
interval<-unname(cbind(interval,counti))
} else {interval=NULL}
# testing to see if intervals are closed..
if (length(interval)!=0){
intervalclosed<-as.vector(interval[,1:2])
if (any(duplicated(intervalclosed))==TRUE) stop (paste(intervalclosed[which(duplicated(intervalclosed)==TRUE)],
'is repeated in different - or I categories and this is not allowed (i.e. need closed intervals)'))
}
#return values for later use
final<-list(leftcensored1=lower1,leftcensored2=lower2, nocensored=exact,
rightcensored1=greater1,
rightcensored2=greater2, intervalcensored=interval
# lowerbound = lowerbound,
# upperbound=upperbound
)
#replacing any negative numbers with 0
#there might be negative numbers, but these negative values will cause error in the likelihood function
final<-rapply(final,function(x) ifelse(x<0,0,x), how = "replace")
# add errors
if(length(final$leftcensored2)!= 0 && length(final$intervalcensored) != 0 &&
final$leftcensored2[1,1] == final$intervalcensored[1,1]) stop ('Censored table can not have the same number in both the <= or LE category and the - or I category (i.e. need closed intervals)')
if(length(final$rightcensored2)!= 0 && length(final$intervalcensored) != 0 &&
final$rightcensored2[1,1] == final$intervalcensored[nrow(final$intervalcensored),2]) stop ('Censored table can not have the same number in both the >= or GE or + category and the - or I category (i.e. need closed intervals)')
return(final)
} #end fixdata_univariatecase function
# ################################################################################## end functions that help format data first
# looking at provided table
# griding the row and col names
rnames<-findtypeofcensoring_univariatetable(row.marginal(censoredtable))$Type_of_Censoring
cnames<-findtypeofcensoring_univariatetable(column.marginal(censoredtable))$Type_of_Censoring
# tn = table names
tn_expaned<-expand.grid(rnames, cnames)
# removing marginals to get to inside of table
# br = bottom row, tr = top row, rc = right column, and lc = left column
brgone<-censoredtable[-nrow(censoredtable),]
# for removing the top row we have to also accounte for if user read in csv with header=TRUE or header=FALSE
if (any(na.omit(colnames(censoredtable))=="V1")) {trgone=brgone[-1,]} else {trgone=unname(brgone)}
rcgone<-trgone[, -ncol(trgone)]
lcgone<-rcgone[,-1]
Inside<-matrix(as.matrix(lcgone), dim(data.frame(lcgone))*dim(data.frame(lcgone))[2], 1)
#r emoving commas from inside of table
inside<-str_replace_all(Inside,",","")
suminside<-sum(as.numeric(inside))
# make probabilities
if (suminside != 1) {inside<-as.numeric(inside)/sum(as.numeric(inside))}
# put inside table with corresponding rows and cols
tn_expaned$repvar<-inside
names(tn_expaned)<-c("row", "col", "inside")
tn_expaned$rowcol<-paste(tn_expaned$row, tn_expaned$col, sep = "_")
# final inside of table with censoring symbols
tn_expaned<-tn_expaned[3:4]
# find numbers for each name
rnumb<-findtypeofcensoring_univariatetable(row.marginal(censoredtable))$Censor_Number
cnumb<-findtypeofcensoring_univariatetable(column.marginal(censoredtable))$Censor_Number
# remove spaces from the numbers
rnumb<-gsub(" ", "", rnumb)
cnumb<-gsub(" ", "", cnumb)
# expand grid for numbers just like did for censored symbols
rowandcolnumb<-expand.grid(rnumb, cnumb)
# final inside of table with censoring symbols and numbers
tn_expaned<-cbind(tn_expaned, "Numbers" = paste(rowandcolnumb$Var1, rowandcolnumb$Var2, sep = "_"))
# create merge column for later..
tn_expaned<-cbind(tn_expaned, "Censoring_Numbers" = paste(tn_expaned$rowcol, tn_expaned$Numbers, sep = "_"))[-c(2,3)]
# run function to know cases of the provided table
# quasipoisson_phiX and quasipoisson_phiY doesn't actually equal one.. just a place filler
repx<-fixdata_univariatecase(row.marginal(censoredtable))
repy<-fixdata_univariatecase(column.marginal(censoredtable))
# uncensored table names expaned grid
tn_expand_new<-expand.grid(Xlowerbound:Xupperbound, Ylowerbound:Yupperbound)
# function to give censoring symbols/pasted numbers to tn_expand_new
##########
censoringtypeforuncensoredtable<-function (tn_expand_new,repx,repy ){
# get rid of count values in repx
if(length(repx$leftcensored1)!=0) {repx$leftcensored1<-repx$leftcensored1[1,1]}
if(length(repx$leftcensored2)!=0) {repx$leftcensored2<-repx$leftcensored2[1,1]}
if(length(repx$intervalcensored)!=0) {repx$intervalcensored<-repx$intervalcensored[,c(1,2)]}
if(length(repx$rightcensored1)!=0) {repx$rightcensored1<-repx$rightcensored1[1,1]}
if(length(repx$rightcensored2)!=0) {repx$rightcensored2<-repx$rightcensored2[1,1]}
if(length(repx$nocensored)!=0) {repx$nocensored<-repx$nocensored[1,]}
# get rid of count values in repy
if(length(repy$leftcensored1)!=0) {repy$leftcensored1<-repy$leftcensored1[1,1]}
if(length(repy$leftcensored2)!=0) {repy$leftcensored2<-repy$leftcensored2[1,1]}
if(length(repy$intervalcensored)!=0) {repy$intervalcensored<-repy$intervalcensored[,c(1,2)]}
if(length(repy$rightcensored1)!=0) {repy$rightcensored1<-repy$rightcensored1[1,1]}
if(length(repy$rightcensored2)!=0) {repy$rightcensored2<-repy$rightcensored2[1,1]}
if(length(repy$nocensored)!=0) {repy$nocensored<-repy$nocensored[1,]}
# function for to find what uncensored number falls between inteval values
findinterval<-function (x, y){
if (is.null(nrow(y))) {y=paste0(y[1], y[2])} else {
result = NULL
for (i in 1:nrow(y)){
if(x>=y[i,1] && x <=y[i,2]) {result[i]<-c("yes")} else {result[i]<-c("no")}
}
y = y[which(result=="yes"),]
y = paste0(y[1], y[2])
} # end else statement
return(y)
}
### going through the 36 cases..
# case where row x has L1
if (length(repx$leftcensored1) != 0){
if (length(repy$leftcensored1)!=0){
if(tn_expand_new$Var1<repx$leftcensored1 && tn_expand_new$Var2<repy$leftcensored1) {
tn_expand_new$rowcol<-c("L1_L1")
tn_expand_new$Numbers<-paste(repx$leftcensored1, repy$leftcensored1, sep = "_")
} }
if (length(repy$leftcensored2)!=0){
if(tn_expand_new$Var1<repx$leftcensored1 && tn_expand_new$Var2<=repy$leftcensored2) {
tn_expand_new$rowcol<-c("L1_L2")
tn_expand_new$Numbers<-paste(repx$leftcensored1, repy$leftcensored2, sep = "_")
} }
if (length(repy$intervalcensored)!=0){
if(tn_expand_new$Var1<repx$leftcensored1 && tn_expand_new$Var2>=min(repy$intervalcensored) && tn_expand_new$Var2<=max(repy$intervalcensored)) {
tn_expand_new$rowcol<-c("L1_I")
tn_expand_new$Numbers<-paste(repx$leftcensored1, findinterval(tn_expand_new$Var2, repy$intervalcensored), sep = "_")
} }
if (length(repy$rightcensored1)!=0){
if(tn_expand_new$Var1<repx$rightcensored1 && tn_expand_new$Var2>repy$rightcensored1) {
tn_expand_new$rowcol<-c("L1_G1")
tn_expand_new$Numbers<-paste(repx$leftcensored1, repy$rightcensored1, sep = "_")
} }
if (length(repy$rightcensored2)!=0){
if(tn_expand_new$Var1<repx$leftcensored1 && tn_expand_new$Var2>=repy$rightcensored2) {
tn_expand_new$rowcol<-c("L1_G2")
tn_expand_new$Numbers<-paste(repx$leftcensored1, repy$rightcensored2, sep = "_")
} }
if (length(repy$nocensored)!=0){
if(tn_expand_new$Var1<repx$leftcensored1 && any(tn_expand_new$Var2==repy$nocensored)) {
tn_expand_new$rowcol<-c("L1_U")
matchingvalue<-which(tn_expand_new$Var2==repy$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$leftcensored1, repy$nocensored[matchingvalue], sep = "_")
} }
} # end case where row x has L1
#############################
# case where row x has L2
if (length(repx$leftcensored2) != 0){
if (length(repy$leftcensored1)!=0){
if(tn_expand_new$Var1<=repx$leftcensored2 && tn_expand_new$Var2<repy$leftcensored1) {
tn_expand_new$rowcol<-c("L2_L1")
tn_expand_new$Numbers<-paste(repx$leftcensored2, repy$leftcensored1, sep = "_")
} }
if (length(repy$leftcensored2)!=0){
if(tn_expand_new$Var1<=repx$leftcensored2 && tn_expand_new$Var2<=repy$leftcensored2) {
tn_expand_new$rowcol<-c("L2_L2")
tn_expand_new$Numbers<-paste(repx$leftcensored2, repy$leftcensored2, sep = "_")
} }
if (length(repy$intervalcensored)!=0){
if(tn_expand_new$Var1<=repx$leftcensored2 && tn_expand_new$Var2>=min(repy$intervalcensored) && tn_expand_new$Var2<=max(repy$intervalcensored)) {
tn_expand_new$rowcol<-c("L2_I")
tn_expand_new$Numbers<-paste(repx$leftcensored2, findinterval(tn_expand_new$Var2, repy$intervalcensored), sep = "_")
} }
if (length(repy$rightcensored1)!=0){
if(tn_expand_new$Var1<=repx$rightcensored1 && tn_expand_new$Var2>repy$rightcensored1) {
tn_expand_new$rowcol<-c("L2_G1")
tn_expand_new$Numbers<-paste(repx$leftcensored2, repy$rightcensored1, sep = "_")
} }
if (length(repy$rightcensored2)!=0){
if(tn_expand_new$Var1<=repx$leftcensored2 && tn_expand_new$Var2>=repy$rightcensored2) {
tn_expand_new$rowcol<-c("L2_G2")
tn_expand_new$Numbers<-paste(repx$leftcensored2, repy$rightcensored2, sep = "_")
} }
if (length(repy$nocensored)!=0){
if(tn_expand_new$Var1<=repx$leftcensored2 && any(tn_expand_new$Var2==repy$nocensored)) {
tn_expand_new$rowcol<-c("L2_U")
matchingvalue<-which(tn_expand_new$Var2==repy$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$leftcensored2, repy$nocensored[matchingvalue], sep = "_")
} }
} # end case where row x has L2
#############################
# case where row x has G1
if (length(repx$rightcensored1) != 0){
if (length(repy$leftcensored1)!=0){
if(tn_expand_new$Var1>repx$rightcensored1 && tn_expand_new$Var2<repy$leftcensored1) {
tn_expand_new$rowcol<-c("G1_L1")
tn_expand_new$Numbers<-paste(repx$rightcensored1, repy$leftcensored1, sep = "_")
} }
if (length(repy$leftcensored2)!=0){
if(tn_expand_new$Var1>repx$rightcensored1 && tn_expand_new$Var2<=repy$leftcensored2) {
tn_expand_new$rowcol<-c("G1_L2")
tn_expand_new$Numbers<-paste(repx$rightcensored1, repy$leftcensored2, sep = "_")
} }
if (length(repy$intervalcensored)!=0){
if(tn_expand_new$Var1>repx$rightcensored1 && tn_expand_new$Var2>=min(repy$intervalcensored) && tn_expand_new$Var2<=max(repy$intervalcensored)) {
tn_expand_new$rowcol<-c("G1_I")
tn_expand_new$Numbers<-paste(repx$rightcensored1, findinterval(tn_expand_new$Var2, repy$intervalcensored), sep = "_")
} }
if (length(repy$rightcensored1)!=0){
if(tn_expand_new$Var1>repx$rightcensored1 && tn_expand_new$Var2>repy$rightcensored1) {
tn_expand_new$rowcol<-c("G1_G1")
tn_expand_new$Numbers<-paste(repx$rightcensored1, repy$rightcensored1, sep = "_")
} }
if (length(repy$rightcensored2)!=0){
if(tn_expand_new$Var1>repx$rightcensored1 && tn_expand_new$Var2>=repy$rightcensored2) {
tn_expand_new$rowcol<-c("G1_G2")
tn_expand_new$Numbers<-paste(repx$rightcensored1, repy$rightcensored2, sep = "_")
} }
if (length(repy$nocensored)!=0){
if(tn_expand_new$Var1>repx$rightcensored1 && any(tn_expand_new$Var2==repy$nocensored)) {
tn_expand_new$rowcol<-c("G1_U")
matchingvalue<-which(tn_expand_new$Var2==repy$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$rightcensored1, repy$nocensored[matchingvalue], sep = "_")
} }
} # end case where row x has G1
#############################
# case where row x has G2
if (length(repx$rightcensored2) != 0){
if (length(repy$leftcensored1)!=0){
if(tn_expand_new$Var1>=repx$rightcensored2 && tn_expand_new$Var2<repy$leftcensored1) {
tn_expand_new$rowcol<-c("G2_L1")
tn_expand_new$Numbers<-paste(repx$rightcensored2, repy$leftcensored1, sep = "_")
} }
if (length(repy$leftcensored2)!=0){
if(tn_expand_new$Var1>=repx$rightcensored2 && tn_expand_new$Var2<=repy$leftcensored2) {
tn_expand_new$rowcol<-c("G2_L2")
tn_expand_new$Numbers<-paste(repx$rightcensored2, repy$leftcensored2, sep = "_")
} }
if (length(repy$intervalcensored)!=0){
if(tn_expand_new$Var1>=repx$rightcensored2 && tn_expand_new$Var2>=min(repy$intervalcensored) && tn_expand_new$Var2<=max(repy$intervalcensored)) {
tn_expand_new$rowcol<-c("G2_I")
tn_expand_new$Numbers<-paste(repx$rightcensored2, findinterval(tn_expand_new$Var2, repy$intervalcensored), sep = "_")
} }
if (length(repy$rightcensored1)!=0){
if(tn_expand_new$Var1>=repx$rightcensored2 && tn_expand_new$Var2>repy$rightcensored1) {
tn_expand_new$rowcol<-c("G2_G1")
tn_expand_new$Numbers<-paste(repx$rightcensored2, repy$rightcensored1, sep = "_")
} }
if (length(repy$rightcensored2)!=0){
if(tn_expand_new$Var1>=repx$rightcensored2 && tn_expand_new$Var2>=repy$rightcensored2) {
tn_expand_new$rowcol<-c("G2_G2")
tn_expand_new$Numbers<-paste(repx$rightcensored2, repy$rightcensored2, sep = "_")
} }
if (length(repy$nocensored)!=0){
if(tn_expand_new$Var1>=repx$rightcensored2 && any(tn_expand_new$Var2==repy$nocensored)) {
tn_expand_new$rowcol<-c("G2_U")
matchingvalue<-which(tn_expand_new$Var2==repy$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$rightcensored2, repy$nocensored[matchingvalue], sep = "_")
} }
} # end case where row x has G2
#############################
# case where row x has U
if (length(repx$nocensored) != 0){
if (length(repy$leftcensored1)!=0){
if(any(tn_expand_new$Var1==repx$nocensored) && tn_expand_new$Var2<repy$leftcensored1) {
tn_expand_new$rowcol<-c("U_L1")
matchingvalue<-which(tn_expand_new$Var1==repx$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$nocensored[matchingvalue], repy$leftcensored1, sep = "_")
} }
if (length(repy$leftcensored2)!=0){
if(any(tn_expand_new$Var1==repx$nocensored) && tn_expand_new$Var2<=repy$leftcensored2) {
tn_expand_new$rowcol<-c("U_L2")
matchingvalue<-which(tn_expand_new$Var1==repx$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$nocensored[matchingvalue], repy$leftcensored2, sep = "_")
} }
if (length(repy$intervalcensored)!=0){
if(any(tn_expand_new$Var1==repx$nocensored) && tn_expand_new$Var2>=min(repy$intervalcensored) && tn_expand_new$Var2<=max(repy$intervalcensored)) {
tn_expand_new$rowcol<-c("U_I")
matchingvalue<-which(tn_expand_new$Var1==repx$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$nocensored[matchingvalue], findinterval(tn_expand_new$Var2, repy$intervalcensored), sep = "_")
} }
if (length(repy$rightcensored1)!=0){
if(any(tn_expand_new$Var1==repx$nocensored) && tn_expand_new$Var2>repy$rightcensored1) {
tn_expand_new$rowcol<-c("U_G1")
matchingvalue<-which(tn_expand_new$Var1==repx$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$nocensored[matchingvalue], repy$rightcensored1, sep = "_")
} }
if (length(repy$rightcensored2)!=0){
if(any(tn_expand_new$Var1==repx$nocensored) && tn_expand_new$Var2>=repy$rightcensored2) {
tn_expand_new$rowcol<-c("U_G2")
matchingvalue<-which(tn_expand_new$Var1==repx$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$nocensored[matchingvalue], repy$rightcensored2, sep = "_")
} }
if (length(repy$nocensored)!=0){
if(any(tn_expand_new$Var1==repx$nocensored) && any(tn_expand_new$Var2==repy$nocensored)) {
tn_expand_new$rowcol<-c("U_U")
matchingvalue1<-which(tn_expand_new$Var1==repx$nocensored, arr.ind=TRUE)
matchingvalue2<-which(tn_expand_new$Var2==repy$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(repx$nocensored[matchingvalue1], repy$nocensored[matchingvalue2], sep = "_")
} }
} # end case where row x has U
#############################
# case where row x has I
if (length(repx$intervalcensored) != 0){
if (length(repy$leftcensored1)!=0){
if(tn_expand_new$Var1>=min(repx$intervalcensored) && tn_expand_new$Var1<=max(repx$intervalcensored) && tn_expand_new$Var2<repy$leftcensored1) {
tn_expand_new$rowcol<-c("I_L1")
tn_expand_new$Numbers<-paste(findinterval(tn_expand_new$Var1, repx$intervalcensored), repy$leftcensored1, sep = "_")
} }
if (length(repy$leftcensored2)!=0){
if(tn_expand_new$Var1>=min(repx$intervalcensored) && tn_expand_new$Var1<=max(repx$intervalcensored) && tn_expand_new$Var2<=repy$leftcensored2) {
tn_expand_new$rowcol<-c("I_L2")
tn_expand_new$Numbers<-paste(findinterval(tn_expand_new$Var1, repx$intervalcensored), repy$leftcensored2, sep = "_")
} }
if (length(repy$intervalcensored)!=0){
if(tn_expand_new$Var1>=min(repx$intervalcensored) && tn_expand_new$Var1<=max(repx$intervalcensored) && tn_expand_new$Var2>=min(repy$intervalcensored) && tn_expand_new$Var2<=max(repy$intervalcensored)) {
tn_expand_new$rowcol<-c("I_I")
tn_expand_new$Numbers<-paste(findinterval(tn_expand_new$Var1, repx$intervalcensored), findinterval(tn_expand_new$Var2, repy$intervalcensored), sep = "_")
} }
if (length(repy$rightcensored1)!=0){
if(tn_expand_new$Var1>=min(repx$intervalcensored) && tn_expand_new$Var1<=max(repx$intervalcensored) && tn_expand_new$Var2>repy$rightcensored1) {
tn_expand_new$rowcol<-c("I_G1")
tn_expand_new$Numbers<-paste(findinterval(tn_expand_new$Var1, repx$intervalcensored), repy$rightcensored1, sep = "_")
} }
if (length(repy$rightcensored2)!=0){
if(tn_expand_new$Var1>=min(repx$intervalcensored) && tn_expand_new$Var1<=max(repx$intervalcensored) && tn_expand_new$Var2>=repy$rightcensored2) {
tn_expand_new$rowcol<-c("I_G2")
tn_expand_new$Numbers<-paste(findinterval(tn_expand_new$Var1, repx$intervalcensored), repy$rightcensored2, sep = "_")
} }
if (length(repy$nocensored)!=0){
if(tn_expand_new$Var1>=min(repx$intervalcensored) && tn_expand_new$Var1<=max(repx$intervalcensored) && any(tn_expand_new$Var2==repy$nocensored)) {
tn_expand_new$rowcol<-c("I_U")
matchingvalue<-which(tn_expand_new$Var2==repy$nocensored, arr.ind=TRUE)
tn_expand_new$Numbers<-paste(findinterval(tn_expand_new$Var1, repx$intervalcensored), repy$nocensored[matchingvalue], sep = "_")
} }
} # end case where row x has I
### end 36 cases..
# checking if user didn't censor correctly
if(any(tn_expand_new$rowcol=="") ==TRUE) stop('Check Censoring.')
# make merge column
tn_expand_new$Censoring_Numbers<-paste(tn_expand_new$rowcol, tn_expand_new$Numbers, sep = "_")
tn_expand_new<-tn_expand_new[, c("Var1", "Var2", "Censoring_Numbers")]
# return main function
return(tn_expand_new)}
# end function to give censoring symbols/pasted numbers to tn_expand_new
##########
# run function over all tn_expand_new
final= NULL
for (i in 1:nrow(tn_expand_new)){
final[[i]]<-censoringtypeforuncensoredtable(tn_expand_new=tn_expand_new[i,],repx=repx, repy = repy)
}
# dataframe with censoring symbols and numbers for all uncensored variables
final<-data.frame(matrix(unlist(final), nrow(tn_expand_new), 3, byrow =TRUE))
names(final)<-c("row", "col", "Censoring_Numbers")
# merge dataframe with censoring symbols and numbers for all uncensored variables (final) with tn_expanded so can get inside of table values
insidefortable<-inner_join(final, tn_expaned, by= c("Censoring_Numbers"))
# need to replace row and col values that start at 1:length of rows/cols to fill in table properly
rowreplace<-data.frame("row" = Xlowerbound:Xupperbound, "Wantr" = 1:(length(Xlowerbound:Xupperbound)))
colreplace<-data.frame("col" = Ylowerbound:Yupperbound, "Wantc" = 1:(length(Ylowerbound:Yupperbound)))
# mergining the new values to old
# inner_join has to have same class
insidefortable$row<-as.numeric(as.character(insidefortable$row))
rowreplacetable<-inner_join(insidefortable, rowreplace, by = c("row"))
rowreplacetable$col<-as.numeric(as.character(rowreplacetable$col))
colreplacetable<-inner_join(rowreplacetable, colreplace, by = c("col"))
# grab only columns needed
insidefortable<-colreplacetable
insidefortable<-insidefortable[,c("Wantr", "Wantc", "inside")]
colnames(insidefortable)[3]<-c("inside")
# create seed matrix
seed<-matrix(as.numeric(""), length(Xlowerbound:Xupperbound) , length(Ylowerbound:Yupperbound))
# fill seed
for (i in 1:nrow(insidefortable)) {
seed[insidefortable[i,1], insidefortable[i,2]]<-as.numeric(insidefortable[i,3])
}
colnames(seed)<-Ylowerbound:Yupperbound
row.names(seed)<-Xlowerbound:Xupperbound
seedp<-seed/sum(seed)
return(list("Exact"=seed,"Probabilities"=seedp))
} # end seed function
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.