Nothing
"ratiofun"<-function(Q1, a1=rep(0, nrow(Q1)), d1=0, Q2, a2=rep(0, nrow(Q2)), d2=0, id=1:nrow(Q1), name="ratio.fun"){
### Check if the function is well defined ###
if(!is.matrix(Q1)){Q1 <- as(Q1, "matrix")}
if(!is.matrix(Q2)){Q2 <- as(Q2, "matrix")}
a1 <- c(a1)
a2 <- c(a2)
d1 <- c(d1)
d2 <- c(d2)
id <- c(id)
name <- c(name)
storage.mode(Q1) <- "double"
storage.mode(Q2) <- "double"
storage.mode(a1) <- "double"
storage.mode(a2) <- "double"
storage.mode(d1) <- "double"
storage.mode(d2) <- "double"
storage.mode(id) <- "character"
storage.mode(name)<- "character"
if(!is.vector(a1)){ stop("Argument a1 must be a numeric vector.\n")}
if(!is.vector(a2)){ stop("Argument a2 must be a numeric vector.\n")}
if(!is.vector(d1)){ stop("Argument d1 must be a number.\n")}
if(!is.vector(d2)){ stop("Argument d2 must be a number.\n")}
if(!is.vector(id)){ stop("Argument id (if present) must be a character vector.\n")}
if(!is.vector(name)){ stop("Argument 'name' must be a character string.\n")}
if(nrow(Q1)!=ncol(Q1)){ stop("Matrix Q1 must be quadratic.\n")}
if(nrow(Q2)!=ncol(Q2)){ stop("Matrix Q2 must be quadratic.\n")}
if(nrow(Q1)!=nrow(Q2)){ stop("Matrices Q1 and Q2 must have the same dimension.\n")}
if(nrow(Q1)!=length(a1)){stop("Length of vector a1 must be equal to nrow(Q1).\n")}
if(nrow(Q2)!=length(a2)){stop("Length of vector a2 must be equal to nrow(Q2).\n")}
if(length(d1)>1){ stop("Argument d1 must be a number.\n")}
if(length(d2)>1){ stop("Argument d2 must be a number.\n")}
if(length(name)>1){ stop("Argument 'name' must be a character string.\n")}
if(ncol(Q1)!=length(id)){stop("Length of id (if present) must be equal to ncol(Q1).\n")}
if(any(is.na(d1))){ stop("Parameter d1 is NA.\n")}
if(any(is.na(a1))){ stop("Vector a1 contains NA values.\n")}
if(any(is.na(Q1))){ stop("Matrix Q1 contains NA values.\n")}
if(any(is.na(d2))){ stop("Parameter d2 is NA.\n")}
if(any(is.na(a2))){ stop("Vector a2 contains NA values.\n")}
if(any(is.na(Q2))){ stop("Matrix Q2 contains NA values.\n")}
if(any(is.na(id))){ stop("Vector id contains NA values.\n")}
if(is.na(name)){ stop("Arument 'name' is NA.\n")}
if(any(duplicated(id))){ stop("Vector id contains duplicated values.\n")}
rownames(Q1) <- id
colnames(Q1) <- id
rownames(Q2) <- id
colnames(Q2) <- id
names(a1) <- id
names(a2) <- id
Range <- range(Q1-t(Q1))
if(Range[2]-Range[1]>1e-09){
Q1 <- (Q1 + t(Q1))/2
}
Range <- range(Q2-t(Q2))
if(Range[2]-Range[1]>1e-09){
Q2 <- (Q2 + t(Q2))/2
}
### Return the function as a list ###
fun <- list(Q1=Q1, a1=a1, d1=d1, Q2=Q2, a2=a2, d2=d2, id=id, name=name)
class(fun) <- "ratioFun"
fun
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.