R/04operations.R
In njm18/gmatrix: GPU Computing in R
Defines functions
gmm
.cp
.tcp
gouter
gRowLogSums
gorder
gmatTimesDiagVec
gkroneckerProd
gsumby
Documented in
gkroneckerProd
gmatTimesDiagVec
gmm
gorder
gouter
gRowLogSums
gsumby
# Various Operations
#
# Author: nmorris
###############################################################################
.exprs_xy = bquote( {
if(x@type!=y@type) {
totype=min(c(x@type,y@type))
if(x@type!=totype)
x=convertType(x,totype)
if(y@type!=totype)
y=convertType(y,totype)
} else if (x@type==3L) {
x=convertType(x,2L)
y=convertType(y,2L)
}
checkDevice(c(y@device,x@device))
})
# if(max(c(x@type,y@type))>1)
# stop("Operation can only be performed on 'double' or 'single' type.", call. = FALSE)
.exprs_sf_xy = bquote({
totype=min(c(x@type,y@type))
if(x@type!=y@type || totype>1L) {
if(totype>1L)
totype=0L
if(x@type!=totype)
x=convertType(x,totype)
if(y@type!=totype)
y=convertType(y,totype)
}
checkDevice(c(y@device,x@device))
})
.exprs_compare_xy = bquote( {
if(x@type!=y@type) {
tmp=c(x@type,y@type)
totype=min(tmp)
if(totype==0 && max(tmp)==1)
totype=1L #these comparisons lead to counterintuitive results otherwise
if(x@type!=totype)
x=convertType(x,totype)
if(y@type!=totype)
y=convertType(y,totype)
}
checkDevice(c(y@device,x@device))
})
.exprs_l_xy = bquote({
if(x@type!=3L)
x=convertType(x,3L)
if(y@type!=3L)
y=convertType(y,3L)
checkDevice(c(y@device,x@device))
})
.exprs_gpu_cpu_xy = bquote({
type2 =.Rclass_to_type(y)
if(x@type!=type2) {
if(x@type<2L) {
y=as.double(y)
}else {
totype=min(c(x@type,type2))
if(x@type!=totype)
x=convertType(x,totype)
if(type2!=totype ) {
if(totype==0L || totype==1L)
y=as.double(y)
else if( totype==2L)
y=as.integer(y)
else
y=as.logical(y)
}
}
} else if(type2==3L) {#both inputs are logical
y=as.integer(y)
x=convertType(x,2L)
}
checkDevice(x@device)
})
.exprs_sf_gpu_cpu_xy = bquote({ #the case where everything must be double or single
y=as.double(y)
if(x@type>1L) #if x is not single, then make it double
x=convertType(x,0L)
checkDevice(x@device)
})
.exprs_l_gpu_cpu_xy = bquote({ #for logical operators
if(x@type!=3L)
x=convertType(x,3L)
y=as.logical(y)
checkDevice(x@device)
})
###################################
# matrix multiplication
###################################
setMethod("%*%", signature(x = "gmatrix", y = "gmatrix"),
function(x,y) {
#browser()
eval(.exprs_sf_xy)
return(.Call("matrix_multiply", x, y, FALSE, FALSE, x@type))
})
setMethod("%*%", signature(x = "gmatrix", y = "gvector"),
function(x,y) {
eval(.exprs_sf_xy)
ytmp=new("gmatrix",nrow=length(y),ncol=1L,ptr=y@ptr, type=y@type)
return(.Call("matrix_multiply", x, ytmp, FALSE, FALSE, x@type))
})
setMethod("%*%", signature(x = "gvector", y = "gmatrix"),
function(x,y) {
eval(.exprs_sf_xy)
xtmp=new("gmatrix",ncol=length(x),nrow=1L,ptr=x@ptr, type=x@type)
return(.Call("matrix_multiply", xtmp, y, FALSE, FALSE, x@type))
})
setMethod("%*%", signature(x = "gmatrix", y = "numeric"),
function(x,y) {
if(x@type==1L) {
y=as.gvector(y, type=1L)
} else
y=as.gvector(y)
return(x%*%y)
})
setMethod("%*%", signature(x = "numeric", y = "gmatrix"),
function(x,y) {
if(y@type==1L) {
x=as.gvector(x, type=1L)
} else
x=as.gvector(x)
return(x%*%y)
})
setMethod("%*%", signature(x = "gmatrix", y = "matrix"),
function(x,y) {
if(x@type==1L) {
y=as.gmatrix(y, type=1L)
} else
y=as.gmatrix(y)
return(x%*%y)
})
setMethod("%*%", signature(x = "matrix", y = "gmatrix"),
function(x,y) {
if(y@type==1L) {
x=as.gmatrix(x, type=1L)
} else
x=as.gmatrix(x)
return(x%*%y)
})
setMethod("%*%", signature(x = "gmatrix", y = "logical"),
function(x,y) {
if(x@type==1L) {
y=as.gvector(y, type=1L)
} else
y=as.gvector(y)
return(x%*%y)
})
setMethod("%*%", signature(x = "logical", y = "gmatrix"),
function(x,y) {
if(y@type==1L) {
x=as.gvector(x, type=1L)
} else
x=as.gvector(x)
return(x%*%y)
})
setMethod("%*%", signature(x = "gvector", y= "gvector"),
function(x,y) {
#browser()
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE))
})
setMethod("%*%", signature(x = "numeric", y= "gvector"),
function(x,y) {
#browser()
if(y@type==1L)
return(gmatrix(x,nrow=1,dup=FALSE, type=1L) %*% gmatrix(y,ncol=1,dup=FALSE))
else
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE))
})
setMethod("%*%", signature(x = "gvector", y= "numeric"),
function(x,y) {
#browser()
if(x@type==1L)
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE, type=1L))
else
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE))
})
setMethod("%*%", signature(x = "logical", y= "gvector"),
function(x,y) {
if(y@type==1L)
return(gmatrix(x,nrow=1,dup=FALSE, type=1L) %*% gmatrix(y,ncol=1,dup=FALSE))
else
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE))
})
setMethod("%*%", signature(x = "gvector", y= "logical"),
function(x,y) {
if(x@type==1L)
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE, type=1L))
else
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE))
})
setMethod("%*%", signature(x = "gvector", y= "matrix"),
function(x,y) {
if(x@type==1L) {
y=as.gmatrix(y, type=1L)
} else
y=as.gmatrix(y)
return(x%*%y)
})
setMethod("%*%", signature(x = "matrix", y= "gvector"),
function(x,y) {
if(y@type==1L) {
x=as.gmatrix(x, type=1L)
} else
x=as.gmatrix(x)
return(x%*%y)
})
##############################################
# GMM function to avoid the allocating C
##############################################
gmm = function(A, B, C, trA=FALSE, trB=FALSE, accum=FALSE) {
if(class(A)=="gvector")
A=gmatrix(A,nrow=1,dup=FALSE)
else if(class(A)!="gmatrix")
stop("A must be of class 'gmatrix' or 'gvector.'")
if(class(B)=="gvector")
B=gmatrix(B,ncol=1,dup=FALSE)
else if(class(B)!="gmatrix")
stop("B must be of class 'gmatrix' or 'gvector.'")
if(class(C)=="gvector")
C=gmatrix(C,ncol=1,dup=FALSE)
else if(class(C)!="gmatrix")
stop("C must be of class 'gmatrix' or 'gvector.'")
accum=as.logical(accum)[1]
if(A@type!=B@type || B@type !=C@type)
stop("A, B and C must all have the same type.")
if(A@type>1)
stop("The 'gmm' function may only be used for type 'single' or 'double.' Please convert first.")
# SEXP gpu_gmm(SEXP A_in, SEXP B_in, SEXP C_in, SEXP transa, SEXP transb, SEXP accum, SEXP in_type)
invisible(.Call("gpu_gmm", A, B, C, trA, trB, accum, A@type))
}
##############################################
# Cross Product
##############################################
setMethod("crossprod", signature(x = "gmatrix", y = "missing"),
function(x,y){
if(x@type>1L)
type(x)=0
checkDevice(x@device)
return(.Call("matrix_multiply", x, x, TRUE, FALSE,x@type))
})
setMethod("crossprod", signature(x = "gmatrix", y = "gmatrix"),
function(x,y){
eval(.exprs_sf_xy)
return(.Call("matrix_multiply", x, y, TRUE, FALSE,x@type))
})
setMethod("crossprod", signature(x = "gmatrix", y = "matrix"),
function(x,y){
if(x@type==1L)
y=g(y, type=1L)
else
y=g(y)
eval(.exprs_sf_xy)
return(.Call("matrix_multiply", x, y, TRUE, FALSE, x@type))
})
setMethod("crossprod", signature(x = "matrix", y = "gmatrix"),
function(x,y){
if(y@type==1L)
x=g(x, type=1L)
else
x=g(x)
eval(.exprs_sf_xy)
return(.Call("matrix_multiply", x, y, TRUE, FALSE,x@type))
})
setMethod("crossprod", signature(x = "matrix", y = "gmatrix"),
function(x,y){
if(y@type==1L)
x=g(x, type=1L)
else
x=g(x)
eval(.exprs_sf_xy)
return(.Call("matrix_multiply", x, y, TRUE, FALSE,x@type))
})
.cp = function(x,y) {
flgx=!(class(x) %in% c("gmatrix", "gvector"))
flgy=!(class(y) %in% c("gmatrix", "gvector"))
if(flgx) {
if(!flgy) {
if(y@type==1)
x=g(x,type=1L)
else
x=g(x)
} else
x=g(x)
}
if(flgy) {
if(!flgx) {
if(x@type==1)
y=g(y,type=1L)
else
y=g(y)
} else
y=g(y)
}
eval(.exprs_sf_xy)
if(class(x)=="gvector"){
x=gmatrix(x,nrow=1,dup=FALSE)
if(class(y)=="gvector")
y=gmatrix(y,ncol=1,dup=FALSE)
return(.Call("matrix_multiply", x, y, FALSE, FALSE,x@type))
}
#if here then y is a gvector (b/c one of the two must be a gvector) and x is a gmatrix
y=gmatrix(y,ncol=1,dup=FALSE)
return(.Call("matrix_multiply", x, y, TRUE, FALSE,x@type))
}
setMethod("crossprod", signature(x = "numeric", y = "gmatrix"), .cp)
setMethod("crossprod", signature(x = "gmatrix", y = "numeric"), .cp)
setMethod("crossprod", signature(x = "logical", y = "gmatrix"), .cp)
setMethod("crossprod", signature(x = "gmatrix", y = "logical"), .cp)
setMethod("crossprod", signature(x = "gvector", y = "gmatrix"), .cp)
setMethod("crossprod", signature(x = "gmatrix", y = "gvector"), .cp)
setMethod("crossprod", signature(x = "gvector", y = "gvector"), .cp)
setMethod("crossprod", signature(x = "gvector", y = "missing"), function(x,y) {.cp(x,x)})
setMethod("crossprod", signature(x = "gvector", y = "numeric"), .cp)
setMethod("crossprod", signature(x = "numeric", y = "gvector"), .cp)
setMethod("crossprod", signature(x = "gvector", y = "logical"), .cp)
setMethod("crossprod", signature(x = "logical", y = "gvector"), .cp)
setMethod("crossprod", signature(x = "gvector", y = "matrix"), .cp)
setMethod("crossprod", signature(x = "matrix", y = "gvector"), .cp)
##############################################
# Transpose Cross Product
##############################################
setMethod("tcrossprod", signature(x = "gmatrix", y = "missing"),
function(x,y){
if(x@type>1L)
type(x)=0
checkDevice(x@device)
return(.Call("matrix_multiply", x, x, FALSE, TRUE,x@type))
})
setMethod("tcrossprod", signature(x = "gmatrix", y = "gmatrix"),
function(x,y){
eval(.exprs_sf_xy)
return(.Call("matrix_multiply", x, y, FALSE, TRUE,x@type))
})
setMethod("tcrossprod", signature(x = "gmatrix", y = "matrix"),
function(x,y){
if(x@type==1L)
y=g(y, type=1L)
else
y=g(y)
eval(.exprs_sf_xy)
return(.Call("matrix_multiply",x, y, FALSE, TRUE, x@type))
})
setMethod("tcrossprod", signature(x = "matrix", y = "gmatrix"),
function(x,y){
if(y@type==1L)
x=g(x, type=1L)
else
x=g(x)
eval(.exprs_sf_xy)
return(.Call("matrix_multiply",x ,y, FALSE, TRUE, x@type))
})
.tcp = function(x,y) {
flgx=!(class(x) %in% c("gmatrix", "gvector"))
flgy=!(class(y) %in% c("gmatrix", "gvector"))
if(flgx) {
if(!flgy) {
if(y@type==1)
x=g(x,type=1L)
else
x=g(x)
} else
x=g(x)
}
if(flgy) {
if(!flgx) {
if(x@type==1)
y=g(y,type=1L)
else
y=g(y)
} else
y=g(y)
}
eval(.exprs_sf_xy)
#browser()
if(class(x)=="gvector"){
if(class(y)=="gvector") {
x=gmatrix(x,ncol=1,dup=FALSE)
y=gmatrix(y,nrow=1,dup=FALSE)
return(.Call("matrix_multiply", x, y, FALSE, FALSE, x@type))
} else {
# browser()
x=gmatrix(x,nrow=1,dup=FALSE)
return(.Call("matrix_multiply", x, y, FALSE, TRUE, x@type))
}
}
#if here then y is a gvector (b/c one of the two must be a gvector) and x is a gmatrix
y=gmatrix(y,ncol=1,dup=FALSE)
return(.Call("matrix_multiply", x, y, FALSE, TRUE, x@type))
}
setMethod("tcrossprod", signature(x = "numeric", y = "gmatrix"), .tcp)
setMethod("tcrossprod", signature(x = "gmatrix", y = "numeric"), .tcp)
setMethod("tcrossprod", signature(x = "logical", y = "gmatrix"), .tcp)
setMethod("tcrossprod", signature(x = "gmatrix", y = "logical"), .tcp)
setMethod("tcrossprod", signature(x = "gvector", y = "gmatrix"), .tcp)
setMethod("tcrossprod", signature(x = "gmatrix", y = "gvector"), .tcp)
setMethod("tcrossprod", signature(x = "gvector", y = "gvector"), .tcp)
setMethod("tcrossprod", signature(x = "gvector", y = "missing"), function(x,y) {.tcp(x,x)})
setMethod("tcrossprod", signature(x = "gvector", y = "numeric"), .tcp)
setMethod("tcrossprod", signature(x = "numeric", y = "gvector"), .tcp)
setMethod("tcrossprod", signature(x = "gvector", y = "logical"), .tcp)
setMethod("tcrossprod", signature(x = "logical", y = "gvector"), .tcp)
setMethod("tcrossprod", signature(x = "gvector", y = "matrix"), .tcp)
setMethod("tcrossprod", signature(x = "matrix", y = "gvector"), .tcp)
#####################################################
# Outer Product
#####################################################
gouter<-function(x,y,FUN="*", normalOrder=TRUE ){
if(is.vector(x))
if(class(y)=="gvector") {
if(y@type==1L)
x=as.gvector(x,type=1L)
else
x=as.gvector(x)
} else
x=as.gvector(x)
if(is.vector(y))
if(class(x)=="gvector") {
if(x@type==1L)
y=as.gvector(y,type=1L)
else
y=as.gvector(y)
} else
y=as.gvector(y)
if(class(x)!="gvector" && class(y)!="gvector")
stop("Expected input types of 'gvector' or 'vector'.")
eval(.exprs_sf_xy)
checkDevice(c(x@device,y@device))
if(class(x)!="gvector")
x=as.gvector(x)
if(class(y)!="gvector")
y=as.gvector(y)
# if(op==1)
# ret[i] = x[row] * y[col];
# else if(op==2)
# ret[i] = x[row] + y[col];
# else if(op==3)
# ret[i] =x[row] - y[col];
# else if(op==4)
# ret[i] =y[row] - x[col];
# else if(op==5)
# ret[i] =x[row] / y[col];
# else if(op==6)
# ret[i] =y[row] / x[col];
# else if(op==7)
# ret[i] = pow(x[row] , y[col]) ;
# else if(op==8)
# ret[i] = pow(y[row] , x[col]) ;
if(FUN=="*")
op=1L
else if(FUN=="+")
op=2L
else if(FUN=="-"){
if(normalOrder)
op=3L
else
op=4L
} else if(FUN=="/"){
if(normalOrder)
op=5L
else
op=6L
}else if(FUN=="^"){
if(normalOrder)
op=7L
else
op=8L
} else
stop("Invalid function.")
#gpu_outer(SEXP A_in, SEXP B_in,SEXP n_A_in, SEXP n_B_in, SEXP op_in)
return(new("gmatrix",
ptr=.Call("gpu_outer",x@ptr,y@ptr,length(x),length(y),op, x@type),
nrow=length(x),ncol=length(y),
rownames=names(x),colnames=names(y),
type=x@type))
}
setMethod("%o%", signature(X = "gvector", Y= "gvector"),
function(X,Y) {
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE))
})
setMethod("%o%", signature(X = "numeric", Y= "gvector"),
function(X,Y) {
if(Y@type==1L)
return(gmatrix(X,ncol=1,dup=FALSE, type=1L) %*% gmatrix(Y,nrow=1,dup=FALSE))
else
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE))
})
setMethod("%o%", signature(X = "gvector", Y= "numeric"),
function(X,Y) {
if(X@type==1L)
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE, type=1L))
else
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE))
})
setMethod("%o%", signature(X = "logical", Y= "gvector"),
function(X,Y) {
if(Y@type==1L)
return(gmatrix(X,ncol=1,dup=FALSE, type=1L) %*% gmatrix(Y,nrow=1,dup=FALSE))
else
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE))
})
setMethod("%o%", signature(X = "gvector", Y= "logical"),
function(X,Y) {
if(X@type==1L)
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE, type=1L))
else
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE))
})
################################################
# Sums and Means
################################################
setMethod("colSums", "gmatrix",
function(x, na.rm = FALSE, dims = 1) {
if(na.rm)
stop("na.rm not implemented on the GPU")
if(dims!=1)
stop("invalid 'dims'")
return(as.gvector( rep(1,nrow(x)) %*% x , dup=FALSE))
}
)
setMethod("rowSums", "gmatrix",
function(x, na.rm = FALSE, dims = 1) {
if(na.rm)
stop("na.rm not implemented on the GPU")
if(dims!=1)
stop("invalid 'dims'")
# browser()
return(as.gvector(x %*% g.rep(1,ncol(x)), dup=FALSE))
}
)
gRowLogSums = function(x, startCol=1L, endCol=ncol(x)) {
if(class(x)!="gmatrix")
stop("Object must be of class 'gmatrix.'")
if(x@type>1L)
stop("Invalid type")
startCol=as.integer(startCol)
endCol=as.integer(endCol)
if(startCol<1L || startCol>ncol(x) || startCol>endCol)
stop("Invalid startCol.")
if(endCol<1L || endCol>ncol(x) )
stop("Invalid endCol.")
checkDevice(x@device)
ret = new("gvector", ptr=.Call("gpu_rowLogSums", ptr=x@ptr,
nrow(x), endCol, startCol, x@type),
length=nrow(x),type=x@type)
return(ret)
}
setMethod("colMeans", "gmatrix",
function(x, na.rm = FALSE, dims = 1) {
# browser()
if(na.rm)
stop("na.rm not implemented on the GPU")
if(dims!=1)
stop("invalid 'dims'")
return(g.rep(1,nrow(x)) %*% x/nrow(x))
}
)
setMethod("rowMeans", "gmatrix",
function(x, na.rm = FALSE, dims = 1) {
if(na.rm)
stop("na.rm not implemented on the GPU")
if(dims!=1)
stop("invalid 'dims'")
return(as.gvector(x %*% rep(1,ncol(x)), dup=FALSE)/ncol(x))
}
)
setMethod("sum", "gvector",
function(x, na.rm = FALSE, retgpu=TRUE) {
if(na.rm)
stop("na.rm not implemented on the GPU")
ret=.Call("gpu_sum",x@ptr, length(x), x@type)
if(retgpu)
ret=as.gvector(ret)
return(ret)
}
)
setMethod("mean", "gvector",
function(x, na.rm = FALSE, trim=0,retgpu=TRUE) {
if(trim != 0)
stop("trim not supported on GPU")
if(na.rm)
stop("na.rm not implemented on the GPU")
checkDevice(x@device)
ret=.Call("gpu_sum",x@ptr, length(x), x@type)/length(x)
if(retgpu)
ret=as.gvector(ret)
return(ret)
}
)
setMethod("sum", "gmatrix", function(x,...)
return(sum(as.gvector(x,dup=FALSE),...)))
setMethod("mean", "gmatrix", function(x,...)
return(mean(as.gvector(x,dup=FALSE),...)))
setMethod("max", "gvector",
function(x, na.rm = FALSE, retgpu=TRUE, pos=FALSE) {
if(na.rm)
stop("na.rm not implemented on the GPU")
checkDevice(x@device)
ret=.Call("gpu_max",x@ptr, length(x), x@type)
if(retgpu)
ret=as.gvector(ret)
return(ret)
}
)
setMethod("max", "gmatrix", function(x,...)
return(max(as.gvector(x,dup=FALSE),...)))
setMethod("min", "gvector",
function(x, na.rm = FALSE, retgpu=TRUE, pos=FALSE) {
if(na.rm)
stop("na.rm not implemented on the GPU")
checkDevice(x@device)
ret=.Call("gpu_min",x@ptr, length(x), x@type)
if(retgpu)
ret=as.gvector(ret)
return(ret)
}
)
setMethod("min", "gmatrix", function(x,...)
return(max(as.gvector(x,dup=FALSE),...)))
setMethod("sort", "gvector",
function(x, decreasing = FALSE, dup=TRUE) {
if(length(names(x))>0) {
warning("Names are being striped for sorting")
x=gnamestrip(x)
}
#browser()
if(dup)
x=gdup(x)
#if(x@type==0 && stable)
# warning("There may be problems with stable sorting for type 'double'. We suggest that the user set stable to 'FALSE' when sorting doubles. This is likely a problem with the thrust library which will be fixed in future releases.")
#SEXP gpu_sort(SEXP A_in, SEXP n_in, SEXP stable_in, SEXP decreasing_in, SEXP in_type)
checkDevice(x@device)
if(x@type ==0L)
ret=.Call("gpu_sort",x@ptr, length(x),FALSE, as.logical(decreasing), x@type)
else if (x@type ==1L)
ret=.Call("gpu_sort",x@ptr, length(x),TRUE, as.logical(decreasing), x@type)
else {
#ok... jerry rig this just so it works... this could use some attention so it isn't so strange
outype=x@type
type(x)=0L
ret=.Call("gpu_sort",x@ptr, length(x),FALSE, as.logical(decreasing), x@type)
type(x)=outype
}
return(x)
}
)
#setMethod("order", "gvector",
#suppressWarnings(setGeneric("order",
# function(x,...)
# base::order(x,...)
# ))
gorder = function(x, decreasing = FALSE, stable=TRUE, sortx=FALSE) {
if(class(x) != "gvector")
x=as.gvector(x)
else
if(!sortx)
x=gdup(x)
#SEXP gpu_sort(SEXP A_in, SEXP n_in, SEXP stable_in, SEXP decreasing_in, SEXP in_type)
#warning("figure out na last")
checkDevice(x@device)
ret=.Call("gpu_order",x@ptr, length(x),as.logical(stable), as.logical(decreasing), x@type)
return(ret)
}
setMethod("which", "gvector",
function(x, arr.ind = FALSE, useNames = TRUE) {
if(arr.ind)
stop("Error in which: 'arr.ind' = TRUE has not been implemented on the GPU. Transfer to CPU first.")
#SEXP gpu_sort(SEXP A_in, SEXP n_in, SEXP stable_in, SEXP decreasing_in, SEXP in_type)
#gpu_which(SEXP A_in, SEXP n_in)
if(x@type!=3L)
stop("Error in which: argument to 'which' is not logical")
checkDevice(x@device)
ret=.Call("gpu_which",x@ptr, length(x))
return(ret)
}
)
setMethod("ifelse", "gvector",
function(test, yes, no) {
if(!(class(yes) %in% c("gvector","gmatrix")))
yes=g(yes)
if(!(class(no) %in% c("gvector","gmatrix")))
no=g(no)
if(test@type!=3L)
type(test)=3L
if(yes@type!=no@type) {
totype=min(c(yes@type,no@type))
if(yes@type!=totype)
yes=convertType(yes,totype)
if(no@type!=totype)
no=convertType(no,totype)
}
#SEXP gpu_if(SEXP H_in, SEXP A_in, SEXP B_in,SEXP snh, SEXP sna, SEXP snb, SEXP in_type)
checkDevice(c(test@device,yes@device,no@device))
ret=new("gvector",
length=length(test),
names=names(test),
type=yes@type,
ptr=.Call("gpu_if",test@ptr,yes@ptr, no@ptr, length(test), length(yes),length(no), yes@type ))
return(ret)
}
)
setMethod("ifelse", "gmatrix",
function(test, yes, no) {
if(!(class(yes) %in% c("gvector","gmatrix")))
yes=g(yes)
if(!(class(no) %in% c("gvector","gmatrix")))
no=g(no)
if(test@type!=3L)
type(test)=3L
if(yes@type!=no@type) {
totype=min(c(yes@type,no@type))
if(yes@type!=totype)
yes=convertType(yes,totype)
if(no@type!=totype)
no=convertType(no,totype)
}
#SEXP gpu_if(SEXP H_in, SEXP A_in, SEXP B_in,SEXP snh, SEXP sna, SEXP snb, SEXP in_type)
checkDevice(c(test@device,yes@device,no@device))
ret=new("gmatrix",
nrow = test@nrow,
ncol = test@ncol,
rownames=test@rownames,
colnames=test@rownames,
type=yes@type,
ptr=.Call("gpu_if",test@ptr,yes@ptr, no@ptr, length(test), length(yes),length(no), yes@type ))
return(ret)
}
)
#setMethod("min", "gvector",
# function(x, na.rm = FALSE, retgpu=TRUE, pos=FALSE) {
# if(na.rm)
# stop("na.rm not implemented on the GPU")
# ret=.Call("gpu_min_pos",x@ptr, length(x))
# if(!pos) {
# ret=x[ret]
# if(!retgpu)
# ret=as.numeric(ret)
# } else if(retgpu)
# ret=as.gvector(ret)
#
# return(ret)
# }
#)
#setMethod("min", "gmatrix", function(x,...)
# return(min(as.gvector(x,dup=FALSE),...)))
.exprs_Av=eval(substitute(substitute(e, list(x = bquote(A), y=bquote(v))), list(e = .exprs_xy)))
gmatTimesDiagVec=function(A,v) {
if(class(A)!="gmatrix") {
if(is.matrix(A))
A=as.gmatrix(A, dup=FALSE)
else
stop("Input 'A' must be a 'matrix' or 'gmatrix'.")
}
if(class(v)!="gvector")
v=as.gvector(v, dup=FALSE)
if(ncol(A)!=length(v))
stop("Mismatched dimensions.")
eval(.exprs_Av)
ret=A
ret@ptr=.Call("gpu_mat_times_diag_vec",A@ptr, v@ptr, nrow(A), ncol(A), ret@type)
return(ret)
}
.exprs_AB=eval(substitute(substitute(e, list(x = bquote(A), y=bquote(B))), list(e = .exprs_xy)))
gkroneckerProd=function(A,B) {
if(class(A)=="gvector")
A=gmatrix(A, dup=FALSE)
if(class(B)=="gvector")
B=gmatrix(B, dup=FALSE)
if(class(A)!="gmatrix") {
if(is.matrix(A)|| is.vector(B)) {
if(class(B)%in%c("gmatrix","gvector")) {
if(B@type==1L)
A=as.gmatrix(A, type=1L)
else
A=as.gmatrix(A)
} else
A=as.gmatrix(A)
}else
stop("Input 'A' must be a 'vector', 'matrix', 'gmatrix' or 'gvector'.")
}
if(class(B)!="gmatrix") {
if(is.matrix(B) || is.vector(B))
if(class(A)%in%c("gmatrix","gvector")){
if(A@type==1L)
B=as.gmatrix(B, type=1L)
else
B=as.gmatrix(B)
} else
B=as.gmatrix(B)
else
stop("Input 'B' must be a 'vector', 'matrix', 'gmatrix' or 'gvector'.")
}
.exprs_AB
#SEXP gpu_kronecker(SEXP A_in, SEXP B_in,SEXP n_A_row_in,SEXP n_A_col_in, SEXP n_B_row_in,SEXP n_B_col_in);
ret = new("gmatrix",ptr=.Call("gpu_kronecker",A@ptr, B@ptr, nrow(A), ncol(A), nrow(B), ncol(B), A@type),
nrow=nrow(A)*nrow(B),ncol=ncol(A)*ncol(B), type=A@type)
return(ret)
}
gsumby=function(v,startPos,stopPos) {
if(class(v)!="gvector")
v=as.gvector(v, dup=FALSE)
if(type(v)==3L)
type(v)=2L
if(!is.integer(startPos))
startPos=as.integer(startPos)
if(!is.integer(stopPos))
stopPos=as.integer(stopPos)
if(length(startPos)!=length(stopPos))
stop("The length of startPos and stopPos must be the same.")
#SEXP gpu_kernal_sumby(SEXP A_in, SEXP index1_in,SEXP index2_in,SEXP n_A_in,SEXP n_index_in);
checkDevice(v@device) #Todo: make the C code utilize startPos of class gvector
ret = new("gvector",
ptr = .Call("gpu_kernal_sumby", v@ptr, startPos, stopPos, length(v), length(stopPos), v@type),
length = length(startPos),
names = names(startPos),
type=v@type)
return(ret)
}
setMethod("%x%", signature(X = "gvector", Y = "gvector"), function(X,Y) return(as.gvector(gkroneckerProd(X,Y),dup=FALSE)))
setMethod("%x%", signature(X = "gvector", Y = "numeric"), function(X,Y) return(as.gvector(gkroneckerProd(X,Y),dup=FALSE)) )
setMethod("%x%", signature(X = "numeric", Y = "gvector"), function(X,Y) return(as.gvector(gkroneckerProd(X,Y),dup=FALSE)))
setMethod("%x%", signature(X = "gmatrix", Y = "gmatrix"), function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "gmatrix", Y = "gvector"), function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "gvector", Y = "gmatrix"), function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "gmatrix", Y = "numeric"),function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "numeric", Y = "gmatrix"), function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "gmatrix", Y = "matrix"),function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "matrix", Y = "gmatrix"), function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "gvector", Y = "matrix"),function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "matrix", Y = "gvector"), function(X,Y) return(gkroneckerProd(X,Y)))
#######################################
# elementwise special functions
#######################################
setMethod("!","gvector", function(x) return(x==0L) )
setMethod("!","gmatrix", function(x) return(x==0L) )
setMethod("-", signature(e1 = "gmatrix", e2 = "missing"), function(e1) return(-1*e1))
setMethod("-", signature(e1 = "gvector", e2 = "missing"), function(e1) return(-1*e1))
setMethod("+", signature(e1 = "gmatrix", e2 = "missing"), function(e1) return(gdup(e1)))
setMethod("+", signature(e1 = "gvector", e2 = "missing"), function(e1) return(gdup(e1)))
#one_over=function(x)
# return(1/x)
#setGeneric("one_over")
.str_unaryops ='
setMethod("MRNAME","gvector", function(x) {
if(x@type>1L)
x=convertType(x,0L)
if(length(gvector)<1L)
return(x)
checkDevice(x@device)
return(new("gvector",ptr=.Call("gpu_MNAME",x@ptr, length(x), x@type),
length=x@length, names=x@names, type=MTYPE))})
setMethod("MRNAME","gmatrix", function(x) {
if(x@type>1L)
x=convertType(x,0L)
checkDevice(x@device)
return(new("gmatrix",ptr=.Call("gpu_MNAME",x@ptr, as.integer(prod(dim(x))),x@type),
nrow=x@nrow, ncol=x@ncol, rownames=x@rownames, colnames=x@colnames, type=MTYPE))})
'
.str_unaryops_ip ='
setGeneric("MRNAMEIp",
function(x)
standardGeneric("MRNAMEIp"))
setMethod("MRNAMEIp","gvector", function(x) {
if(x@type>1L)
stop("In place operations must be for \'double\' or \'single.\'")
if(length(gvector)<1L)
return(x)
checkDevice(x@device)
return(new("gvector",ptr=.Call("gpu_ip_MNAME",x@ptr, length(x), x@type),
length=x@length, names=x@names, type=MTYPE))})
setMethod("MRNAMEIp","gmatrix", function(x) {
if(x@type>1L)
stop("In place operations must be for \'double\' or \'single.\'")
checkDevice(x@device)
return(new("gmatrix",ptr=.Call("gpu_ip_MNAME",x@ptr, as.integer(prod(dim(x))),x@type),
nrow=x@nrow, ncol=x@ncol, rownames=x@rownames, colnames=x@colnames, type=MTYPE))})
'
.unOps= list(
# c('one_over','one_over', "x@type"),
c('sqrt','sqrt', "x@type"),
c('exp','exp', "x@type"),
c('expm1','expm1', "x@type"),
c('log','log', "x@type"),
c('log2','log2', 'x@type'),
c('log10','log10', 'x@type'),
c('log1p','log1p', 'x@type'),
c('sin','sin', 'x@type'),
c('cos','cos', 'x@type'),
c('tan','tan', 'x@type'),
c('asin','asin', 'x@type'),
c('acos','acos', 'x@type'),
c('atan','atan', 'x@type'),
c('sinh','sinh', 'x@type'),
c('cosh','cosh', 'x@type'),
c('tanh','tanh', 'x@type'),
c('asinh','asinh','x@type'),
c('acosh','acosh', 'x@type'),
c('atanh','atanh', 'x@type'),
c('abs','fabs', 'x@type'),
c('lgamma','lgamma', 'x@type'),
c('gamma','gamma', 'x@type'),
c('sign','sign', 'x@type'),
c('round','round', '2L'),
c('ceiling','ceil', '2L'),
c('floor','floor', '2L'),
c('is.na','isna', '3L'),
c('is.nan','isnan', '3L'),
c('is.finite','isfinite', '3L'),
c('is.infinite','isinfinite', '3L')
)
lapply(.unOps, function(op) {
exprStr = gsub("MRNAME",op[1],.str_unaryops)
exprStr = gsub("MNAME",op[2],exprStr)
exprStr = gsub("MTYPE",op[3],exprStr)
#cat(exprStr)
eval(parse(text=exprStr))
} )
lapply(.unOps[sapply(.unOps, function(x) x[3]=="x@type")], function(op) {
exprStr = gsub("MRNAME",op[1],.str_unaryops_ip)
exprStr = gsub("MNAME",op[2],exprStr)
exprStr = gsub("MTYPE",op[3],exprStr)
#cat(exprStr)
eval(parse(text=exprStr))
} )
#######################################
# elementwise binary operations
#######################################
#Non-exchangeable binary operations
.strOpNonExchang = '
setMethod("MOP", signature(e1 = "gvector", e2 = "gvector"),
function(e1,e2) {
MEXPRS
if(length(e2)<1L)
return(e2)
else if(length(e1)<1L)
return(e1)
else if(length(e2)==1L){
tryCatch(e2 <- .convert_to_appropriate_class(e2,e1@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
#e2=as.double(e2)
ret=new("gvector", length=length(e1), names=names(e1), type=MT1)
ret@ptr=.Call("gpu_scaler_MNAME12", e1@ptr, e2, length(e1), e1@type)
} else if(length(e1)==1L){
tryCatch(e1 <- .convert_to_appropriate_class(e1,e2@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
#e1=as.double(e1)
ret=new("gvector", length=length(e2), names=names(e2), type=MT2)
ret@ptr=.Call("gpu_scaler_MNAME21", e2@ptr, e1, length(e2), e2@type)
} else if(length(e1)==length(e2)) {
ret=new("gvector",length=length(e1), names=names(e1), type=MT1)
ret@ptr=.Call("gpu_same_size_MNAME12", e1@ptr, e2@ptr, e2@length, e1@type)
} else {
if(length(e1)<length(e2)) {
small=e1
big=e2
reverse=TRUE
} else {
small=e2
big=e1
reverse=FALSE
}
if((length(big) %% length(small)) !=0)
stop("longer object length is not a multiple of shorter object length", call. = FALSE)
ret=new("gvector",length=length(big), names=names(big), type=MT1)
if(reverse)
ret@ptr=.Call("gpu_diff_size_MNAME21", big@ptr, small@ptr, big@length, small@length, e1@type)
else
ret@ptr=.Call("gpu_diff_size_MNAME12", big@ptr, small@ptr, big@length, small@length, e1@type)
}
return(ret)
}
)
.gvec.vec.MNAME = function(e1,e2) {
if(length(e2)<1L)
return(e2)
else if(length(e1)<1L)
return(e1)
else if(length(e2)==1L){
#tryCatch(e2 <- .convert_to_appropriate_class(e2,e1@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
#e2=as.double(e2)
MDIFEXPRS12
ret=new("gvector", length=length(e1), names=names(e1), type=MT1)
ret@ptr=.Call("gpu_scaler_MNAME12", e1@ptr, e2, length(e1), e1@type)
} else {
if(e1@type==1L)
tmp=as.gvector(e2, type=1L)
else
tmp=as.gvector(e2)
ret=e1 MOP tmp
}
return(ret)
}
.vec.gvec.MNAME = function(e1,e2) {
if(length(e2)<1L)
return(e2)
else if(length(e1)<1L)
return(e1)
else if(length(e1)==1L){
#tryCatch(e1 <- .convert_to_appropriate_class(e1,e2@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
#e1=as.double(e1)
MDIFEXPRS21
ret=new("gvector", length=length(e2), names=names(e2), type=MT2)
ret@ptr=.Call("gpu_scaler_MNAME21", e2@ptr, e1, length(e2), e2@type)
} else {
if(e2@type==1L)
tmp=as.gvector(e1, type=1L)
else
tmp=as.gvector(e1)
ret=tmp MOP e2
}
return(ret)
}
setMethod("MOP", signature(e1 = "gvector", e2 = "numeric"), .gvec.vec.MNAME )
setMethod("MOP", signature(e1 = "gvector", e2 = "logical"), .gvec.vec.MNAME )
setMethod("MOP", signature(e1 = "numeric", e2 = "gvector"), .vec.gvec.MNAME )
setMethod("MOP", signature(e1 = "logical", e2 = "gvector"), .vec.gvec.MNAME )
setMethod("MOP", signature(e1 = "gmatrix", e2 = "gmatrix"),
function(e1,e2) {
MEXPRS
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operations.", call. = FALSE)
myn=as.integer(prod(dim(e1)))
ret=new("gmatrix", nrow = e1@nrow, ncol = e1@ncol,
rownames=e1@rownames, colnames=e1@colnames, type=MT1)
ret@ptr=.Call("gpu_same_size_MNAME12", e1@ptr, e2@ptr, myn, e1@type)
return(ret)
})
.gmat.vec.MNAME=function(e1,e2) {
checkDevice(e1@device)
tmp1=new("gvector",length=as.integer(prod(dim(e1))),ptr=e1@ptr, type=e1@type)
if(length(tmp1)==1) {
ret = tmp1 MOP e2
}else if(length(tmp1) < length(e2)) {
stop("Dimensions do not match for elementwise operations.", call. = FALSE)
}else {
ret=e1
tmpret=tmp1 MOP e2
ret@ptr=tmpret@ptr
ret@type=tmpret@type
}
return(ret)
}
.vec.gmat.MNAME =function(e1,e2) {
checkDevice(e2@device)
tmp2=new("gvector",length=as.integer(prod(dim(e2))),ptr=e2@ptr, type=e2@type)
if(length(tmp2)==1) {
ret = e1 MOP tmp2
}else if(length(tmp2) < length(e1)) {
stop("Dimensions do not match for elementwise operations.", call. = FALSE)
}else {
ret=e2
tmpret=e1 MOP tmp2
ret@ptr=tmpret@ptr
ret@type=tmpret@type
}
return(ret)
}
setMethod("MOP", signature(e1 = "gmatrix", e2 = "numeric"), .gmat.vec.MNAME)
setMethod("MOP", signature(e1 = "gmatrix", e2 = "logical"), .gmat.vec.MNAME)
setMethod("MOP", signature(e1 = "numeric", e2 = "gmatrix"), .vec.gmat.MNAME)
setMethod("MOP", signature(e1 = "logical", e2 = "gmatrix"), .vec.gmat.MNAME)
setMethod("MOP", signature(e1 = "gmatrix", e2 = "gvector"),
function(e1,e2) {
checkDevice(c(e1@device,e2@device))
tmp1=new("gvector",length=as.integer(prod(dim(e1))),ptr=e1@ptr, type=e1@type)
if(length(tmp1)==1) {
ret = tmp1 MOP e2
}else if(length(tmp1) < length(e2)) {
stop("Dimensions do not match for elementwise operations.", call. = FALSE)
}else {
ret=e1
tmpret=tmp1 MOP e2
ret@ptr=tmpret@ptr
ret@type=tmpret@type
}
return(ret)
})
setMethod("MOP", signature(e1 = "gvector", e2 = "gmatrix"),
function(e1,e2) {
checkDevice(c(e1@device,e2@device))
MEXPRS
tmp2=new("gvector",length=as.integer(prod(dim(e2))),ptr=e2@ptr, type= e2@type)
if(length(tmp2)==1) {
ret = e1 MOP tmp2
}else if(length(tmp2) < length(e1)) {
stop("Dimensions do not match for elementwise operations.", call. = FALSE)
}else {
ret=e2
tmpret=e1 MOP tmp2
ret@ptr=tmpret@ptr
ret@type=tmpret@type
}
return(ret)
}
)
setMethod("MOP", signature(e1 = "gvector", e2 = "matrix"),
function(e1,e2) {
if(e1@type==1L)
tmp=as.gmatrix(e2,type=1L)
else
tmp=as.gmatrix(e2)
return(e1 MOP tmp)
}
)
setMethod("MOP", signature(e1 = "matrix", e2 = "gvector"),
function(e1,e2) {
if(e2@type==1L)
tmp=as.gmatrix(e1,type=1L)
else
tmp=as.gmatrix(e1)
return(tmp MOP e2)
}
)
setMethod("MOP", signature(e1 = "gmatrix", e2 = "matrix"),
function(e1,e2) {
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
if(e1@type==1L)
return(e1 MOP as.gmatrix(e2, type=1L))
else
return(e1 MOP as.gmatrix(e2))
})
setMethod("MOP", signature(e1 = "matrix", e2 = "gmatrix"),
function(e1,e2) {
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
if(e2@type==1L)
return(as.gmatrix(e1, type=1L) MOP e2)
else
return(as.gmatrix(e1) MOP e2)
})
'
#Exchangeable binary operations
.strOpExchang = '
setMethod("MOP", signature(e1 = "gvector", e2 = "gvector"),
function(e1,e2) {
MEXPRS
if(length(e2)<1L)
return(e2)
else if(length(e1)<1L)
return(e1)
else if(length(e1)<length(e2)) {
small=e1
big=e2
} else {
small=e2
big=e1
}
if(length(small)==1L){
tryCatch(small <- .convert_to_appropriate_class(small,big@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
#small=as.double(small)
ret=new("gvector", length=length(big), type = MT2)
ret@ptr=.Call("gpu_scaler_MNAME", big@ptr, small, length(big), big@type)
} else if(length(big)==length(small)) {
ret=new("gvector",length=length(big), type=MT1)
ret@ptr=.Call("gpu_same_size_MNAME", big@ptr, small@ptr, small@length, big@type)
} else if((length(big) %% length(small)) ==0) {
ret=new("gvector",length=length(big), type=MT1)
ret@ptr=.Call("gpu_diff_size_MNAME", big@ptr, small@ptr, big@length, small@length, big@type)
} else
stop("longer object length is not a multiple of shorter object length", call. = FALSE)
return(ret)
}
)
.gvec.vec.MNAME =
function(e1,e2) {
if(length(e2)<1L)
return(e2)
else if(length(e1)<1L)
return(e1)
else if(length(e2)==1L){
MDIFEXPRS12
ret=new("gvector", length=length(e1), type=MT1)
#tryCatch(e2 <- .convert_to_appropriate_class(e2,e1@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
ret@ptr=.Call("gpu_scaler_MNAME", e1@ptr, e2, length(e1), e1@type)
} else {
#if(length(e1)<length(e2))
# stop("for elementwise operations, the larger vector/matrix must be on the gpu", call. = FALSE)
if(e1@type==1L)
tmp=as.gvector(e2, type=1L)
else
tmp=as.gvector(e2)
ret=e1 MOP tmp
}
return(ret)
}
setMethod("MOP", signature(e1 = "gvector", e2 = "numeric"), .gvec.vec.MNAME )
setMethod("MOP", signature(e1 = "gvector", e2 = "logical"), .gvec.vec.MNAME )
setMethod("MOP", signature(e1 = "numeric", e2 = "gvector"), function(e1,e2) .gvec.vec.MNAME(e2, e1))
setMethod("MOP", signature(e1 = "logical", e2 = "gvector"), function(e1,e2) .gvec.vec.MNAME(e2, e1))
setMethod("MOP", signature(e1 = "gmatrix", e2 = "gmatrix"),
function(e1,e2) {
#browser()
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
MEXPRS
myn=as.integer(prod(dim(e1)))
ret=new("gmatrix", nrow = e1@nrow, ncol = e1@ncol,rownames=e1@rownames,colnames=e1@colnames, type=MT1)
ret@ptr=.Call("gpu_same_size_MNAME", e1@ptr, e2@ptr, myn, e1@type)
#browser()
return(ret)
})
.gmat.vec.MNAME = function(e1,e2) {
checkDevice(e1@device)
tmp1=new("gvector",length=as.integer(prod(dim(e1))),ptr=e1@ptr, type=e1@type)
if(length(tmp1)==1) {
ret=tmp1 MOP e2
}else if(length(tmp1)< length(e2)) {
stop("Length of the matrix does not match for elementwise multiplication", call. = FALSE)
}else {
ret=e1
tmpret=tmp1 MOP e2
ret@type=tmpret@type
ret@ptr=tmpret@ptr
}
return(ret)
}
setMethod("MOP", signature(e1 = "gmatrix", e2 = "numeric"), .gmat.vec.MNAME)
setMethod("MOP", signature(e1 = "gmatrix", e2 = "logical"), .gmat.vec.MNAME)
setMethod("MOP", signature(e1 = "numeric", e2 = "gmatrix"), function(e1,e2) .gmat.vec.MNAME(e2,e1))
setMethod("MOP", signature(e1 = "logical", e2 = "gmatrix"), function(e1,e2) .gmat.vec.MNAME(e2,e1))
setMethod("MOP", signature(e1 = "gmatrix", e2 = "gvector"),
function(e1,e2) {
checkDevice(c(e1@device,e2@device))
tmp1=new("gvector",length=as.integer(prod(dim(e1))),ptr=e1@ptr, type=e1@type)
if(length(tmp1)==1) {
ret=tmp1 MOP e2
}else if(length(tmp1)< length(e2)) {
stop("Length of the matrix does not match for elementwise multiplication", call. = FALSE)
}else {
ret=e1
tmpret=tmp1 MOP e2
ret@type=tmpret@type
ret@ptr=tmpret@ptr
}
return(ret)
})
setMethod("MOP", signature(e1 = "gvector", e2 = "gmatrix"), function(e1,e2) return(e2 MOP e1))
setMethod("MOP", signature(e1 = "gmatrix", e2 = "matrix"),
function(e1,e2) {
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
if(e1@type==1L)
return(e1 MOP as.gmatrix(e2, type=1L))
else
return(e1 MOP as.gmatrix(e2))
})
setMethod("MOP", signature(e1 = "matrix", e2 = "gmatrix"),
function(e1,e2) {
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
if(e2@type==1L)
return(as.gmatrix(e1, type=1L) MOP e2)
else
return(as.gmatrix(e1) MOP e2)
})
setMethod("MOP", signature(e1 = "gvector", e2 = "matrix"),
function(e1,e2) {
if(e1@type==1L)
tmp=as.gmatrix(e2,type=1L)
else
tmp=as.gmatrix(e2)
return(e1 MOP tmp)
}
)
setMethod("MOP", signature(e1 = "matrix", e2 = "gvector"),
function(e1,e2) {
if(e2@type==1L)
tmp=as.gmatrix(e1,type=1L)
else
tmp=as.gmatrix(e1)
return(tmp MOP e2)
}
)
'
#binary operations in place
.strOpIp = '
setGeneric("MOP",
function(e1,e2)
standardGeneric("MOP")
)
setMethod("MOP", signature(e1 = "gvector", e2 = "gvector"),
function(e1,e2) {
if(max(length(e1),length(e2))<1L)
stop("Length of object must be greater than 1 for operator: MOP.", call. = FALSE)
else if(length(e1)<length(e2)) {
stop("Length of first vector must be longer than second vector for operator: MOP.", call. = FALSE)
}
checkDevice(c(e1@device,e2@device))
MCHECK
if(length(e2)==1L){
tryCatch(e2 <- .convert_to_appropriate_class(e2,e1@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
.Call("gpu_scaler_ip_MNAME", e1@ptr, e2, length(e1), e1@type)
} else if(length(e1)==length(e2)) {
if(e1@type!=e2@type)
stop("Type of both objects must be the same for operator: MOP.", call. = FALSE)
.Call("gpu_same_size_ip_MNAME", e1@ptr, e2@ptr, e2@length, e1@type)
} else if((length(e1) %% length(e2)) ==0) {
if(e1@type!=e2@type)
stop("Type of both objects must be the same for operator: MOP.", call. = FALSE)
.Call("gpu_diff_size_ip_MNAME", e1@ptr, e2@ptr, e1@length, e2@length, e1@type)
} else
stop("longer object length is not a multiple of shorter object length.", call. = FALSE)
return(e1)
}
)
setMethod("MOP", signature(e1 = "gvector", e2 = "numeric"), function(e1,e2) {
if(max(length(e1),length(e2))<1L)
stop("Length of object must be greater than 1 for operator: MOP.", call. = FALSE)
else if(length(e1)<length(e2)) {
stop("Length of first vector must be longer than second vector for operator: MOP.", call. = FALSE)
}
checkDevice(e1@device)
if(length(e2)==1L){
if(e1@type>1L & !any( c("integer", "logical") %in% class(e2) ) )
stop("Types do not match.")
else if(e1@type<=1L & !any( "numeric" %in% class(e2) ) )
stop("Types do not match.")
.Call("gpu_scaler_ip_MNAME", e1@ptr, e2, length(e1), e1@type)
} else {
if(e1@type==1L)
tmp=as.gvector(e2, type=1L)
else
tmp=as.gvector(e2)
ret=e1 MOP tmp
}
return(e1)
} )
setMethod("MOP", signature(e1 = "gvector", e2 = "logical"), getMethod("MOP", signature(e1 = "gvector", e2 = "numeric"))@.Data)
setMethod("MOP", signature(e1 = "gmatrix", e2 = "gmatrix"),
function(e1,e2) {
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
myn=as.integer(prod(dim(e1)))
MCHECK
if(e1@type!=e2@type)
stop("Type of both objects must be the same for operator: MOP.", call. = FALSE)
checkDevice(c(e1@device,e2@device))
.Call("gpu_same_size_ip_MNAME", e1@ptr, e2@ptr, myn, e1@type)
return(e1)
})
setMethod("MOP", signature(e1 = "gmatrix", e2 = "numeric"), function(e1,e2) {
checkDevice(e1@device)
tmp1=new("gvector",length=as.integer(prod(dim(e1))),ptr=e1@ptr, type=e1@type)
tmpret=tmp1 MOP e2
return(e1)
})
setMethod("MOP", signature(e1 = "gmatrix", e2 = "logical"), getMethod("MOP", signature(e1 = "gmatrix", e2 = "numeric"))@.Data)
setMethod("MOP", signature(e1 = "gmatrix", e2 = "gvector"),
function(e1,e2) {
checkDevice(c(e1@device,e2@device))
tmp1=new("gvector",length=as.integer(prod(dim(e1))),ptr=e1@ptr, type=e1@type)
tmpret=tmp1 MOP e2
return(e1)
})
setMethod("MOP", signature(e1 = "gvector", e2 = "gmatrix"),
function(e1,e2) {
checkDevice(c(e1@device,e2@device))
tmp2=new("gvector",length=as.integer(prod(dim(e2))),ptr=e2@ptr, type=e2@type)
tmpret1=e1 MOP tmp2 #note I am counting on this to error out if the dimensions dont match
tmpret1=new("gmatrix",nrow=as.integer(nrow(e2)), ncol=as.integer(ncol(e2)),ptr=e1@ptr, type=e1@type)
return(tmpret1)
})
setMethod("MOP", signature(e1 = "gmatrix", e2 = "matrix"),
function(e1,e2) {
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
if(e1@type==1L)
return(e1 MOP as.gmatrix(e2, type=1L))
else
return(e1 MOP as.gmatrix(e2))
})
setMethod("MOP", signature(e1 = "gvector", e2 = "matrix"),
function(e1,e2) {
if(e1@type==1L)
tmp=as.gmatrix(e2,type=1L)
else
tmp=as.gmatrix(e2)
return(e1 MOP tmp)
}
)
'
.exprs_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_xy)))
.exprs_str = paste( deparse(.exprs_e1e2),collapse="\n")
.exprs_sf_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_sf_xy )))
.exprs_sf_str = paste( deparse(.exprs_sf_e1e2),collapse="\n")
.exprs_l_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_l_xy )))
.exprs_l_str = paste( deparse(.exprs_l_e1e2),collapse="\n")
.exprs_gc_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_gpu_cpu_xy )))
.exprs_gc12_str = paste( deparse(.exprs_gc_e1e2),collapse="\n")
.exprs_gc_e2e1=eval(substitute(substitute(e, list(x = bquote(e2), y=bquote(e1))), list(e = .exprs_gpu_cpu_xy )))
.exprs_gc21_str = paste( deparse(.exprs_gc_e2e1),collapse="\n")
.exprs_l_gc_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_l_gpu_cpu_xy )))
.exprs_l_gc12_str = paste( deparse(.exprs_l_gc_e1e2),collapse="\n")
.exprs_l_gc_e2e1=eval(substitute(substitute(e, list(x = bquote(e2), y=bquote(e1))), list(e = .exprs_l_gpu_cpu_xy )))
.exprs_l_gc21_str = paste( deparse(.exprs_l_gc_e2e1),collapse="\n")
.exprs_compare_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_compare_xy )))
.exprs_compare_str = paste( deparse(.exprs_compare_e1e2),collapse="\n")
.exprs_sf_gc_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_sf_gpu_cpu_xy )))
.exprs_sf_gc12_str = paste( deparse(.exprs_sf_gc_e1e2),collapse="\n")
.exprs_sf_gc_e2e1=eval(substitute(substitute(e, list(x = bquote(e2), y=bquote(e1))), list(e = .exprs_sf_gpu_cpu_xy )))
.exprs_sf_gc21_str = paste( deparse(.exprs_sf_gc_e2e1),collapse="\n")
.logical_check= "if(e1@type!=3L | e2@type!=3L) stop(\"Type must be\'logical\'\")"
setGeneric("%lgspadd%",
function(e1,e2)
standardGeneric("%lgspadd%")
)
.exOps=list(
c("lgspadd","%lgspadd%", .exprs_str, "e1@type", "big@type", .exprs_gc12_str,.exprs_gc21_str , "%lgspadd=%", "" ),
c("mult","*", .exprs_str, "e1@type", "big@type", .exprs_gc12_str,.exprs_gc21_str , "%*=%", "" ),
c("add" ,"+", .exprs_str, "e1@type", "big@type", .exprs_gc12_str,.exprs_gc21_str , "%+=%", "" ),
c("eq" ,"==", .exprs_compare_str, "3L", "3L", .exprs_gc12_str, .exprs_gc21_str , "none" , "" ),
c("ne" ,"!=", .exprs_compare_str, "3L", "3L" , .exprs_gc12_str, .exprs_gc21_str ,"none" , "" ),
c("and" ,"&", .exprs_l_str, "3L", "3L", .exprs_l_gc12_str, .exprs_l_gc21_str , "%&=%" ,.logical_check),
c("or" ,"|", .exprs_l_str, "3L", "3L", .exprs_l_gc12_str, .exprs_l_gc21_str , "%|=%",.logical_check )
)
lapply(.exOps, function(op) {
#browser()
exprStr = gsub("MDIFEXPRS21",op[7],
gsub("MDIFEXPRS12",op[6],
gsub("MT2",op[5],
gsub("MT1",op[4],
gsub("MEXPRS",op[3],
gsub("MNAME", op[1],
gsub("MOP",op[2],.strOpExchang)))))))
#cat(exprStr)
eval(parse(text=exprStr))
} )
lapply(.exOps[sapply(.exOps, function(x) return(x[8]!="none"))],
function(op) {
exprStr = gsub("MCHECK", op[9], gsub("MNAME", op[1], gsub("MOP",op[8],.strOpIp)))
eval(parse(text=exprStr))
} )
.nonExOps=list( c("sub","-",.exprs_str, "e1@type", "e2@type",.exprs_gc12_str,.exprs_gc21_str, "%-=%", "" ),
c("div","/", .exprs_sf_str, "e1@type", "e2@type",.exprs_sf_gc12_str,.exprs_sf_gc21_str, "%/=%" , ""),
c("pow","^", .exprs_sf_str, "e1@type", "e2@type",.exprs_sf_gc12_str,.exprs_sf_gc21_str, "%^=%" , ""),
c("mod","%%", .exprs_sf_str, "e1@type", "e2@type",.exprs_sf_gc12_str,.exprs_sf_gc21_str, "%mod=%", ""),
c("gt" ,">", .exprs_compare_str, "3L", "3L", .exprs_gc12_str,.exprs_gc21_str , "none" , ""),
c("lt" ,"<", .exprs_compare_str, "3L", "3L", .exprs_gc12_str,.exprs_gc21_str , "none" , ""),
c("gte" ,">=", .exprs_compare_str, "3L", "3L", .exprs_gc12_str,.exprs_gc21_str , "none", "" ),
c("lte" ,"<=", .exprs_compare_str, "3L", "3L", .exprs_gc12_str,.exprs_gc21_str ,"none" , "")
)
lapply(.nonExOps, function(op) {
exprStr = gsub("MDIFEXPRS21",op[7],
gsub("MDIFEXPRS12",op[6],
gsub("MT2",op[5],
gsub("MT1",op[4],
gsub("MEXPRS",op[3],
gsub("MNAME", op[1],
gsub("MOP",op[2],.strOpNonExchang)))))))
eval(parse(text=exprStr))
} )
lapply(.nonExOps[sapply(.nonExOps, function(x) return(x[8]!="none"))],
function(op) {
exprStr = gsub("MCHECK", op[9], gsub("MNAME", op[1], gsub("MOP",op[8],.strOpIp)))
eval(parse(text=exprStr))
} )
njm18/gmatrix documentation built on May 23, 2019, 7:07 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.
Defines functions gmm .cp .tcp gouter gRowLogSums gorder gmatTimesDiagVec gkroneckerProd gsumby
Documented in gkroneckerProd gmatTimesDiagVec gmm gorder gouter gRowLogSums gsumby
# Various Operations
#
# Author: nmorris
###############################################################################
.exprs_xy = bquote( {
if(x@type!=y@type) {
totype=min(c(x@type,y@type))
if(x@type!=totype)
x=convertType(x,totype)
if(y@type!=totype)
y=convertType(y,totype)
} else if (x@type==3L) {
x=convertType(x,2L)
y=convertType(y,2L)
}
checkDevice(c(y@device,x@device))
})
# if(max(c(x@type,y@type))>1)
# stop("Operation can only be performed on 'double' or 'single' type.", call. = FALSE)
.exprs_sf_xy = bquote({
totype=min(c(x@type,y@type))
if(x@type!=y@type || totype>1L) {
if(totype>1L)
totype=0L
if(x@type!=totype)
x=convertType(x,totype)
if(y@type!=totype)
y=convertType(y,totype)
}
checkDevice(c(y@device,x@device))
})
.exprs_compare_xy = bquote( {
if(x@type!=y@type) {
tmp=c(x@type,y@type)
totype=min(tmp)
if(totype==0 && max(tmp)==1)
totype=1L #these comparisons lead to counterintuitive results otherwise
if(x@type!=totype)
x=convertType(x,totype)
if(y@type!=totype)
y=convertType(y,totype)
}
checkDevice(c(y@device,x@device))
})
.exprs_l_xy = bquote({
if(x@type!=3L)
x=convertType(x,3L)
if(y@type!=3L)
y=convertType(y,3L)
checkDevice(c(y@device,x@device))
})
.exprs_gpu_cpu_xy = bquote({
type2 =.Rclass_to_type(y)
if(x@type!=type2) {
if(x@type<2L) {
y=as.double(y)
}else {
totype=min(c(x@type,type2))
if(x@type!=totype)
x=convertType(x,totype)
if(type2!=totype ) {
if(totype==0L || totype==1L)
y=as.double(y)
else if( totype==2L)
y=as.integer(y)
else
y=as.logical(y)
}
}
} else if(type2==3L) {#both inputs are logical
y=as.integer(y)
x=convertType(x,2L)
}
checkDevice(x@device)
})
.exprs_sf_gpu_cpu_xy = bquote({ #the case where everything must be double or single
y=as.double(y)
if(x@type>1L) #if x is not single, then make it double
x=convertType(x,0L)
checkDevice(x@device)
})
.exprs_l_gpu_cpu_xy = bquote({ #for logical operators
if(x@type!=3L)
x=convertType(x,3L)
y=as.logical(y)
checkDevice(x@device)
})
###################################
# matrix multiplication
###################################
setMethod("%*%", signature(x = "gmatrix", y = "gmatrix"),
function(x,y) {
#browser()
eval(.exprs_sf_xy)
return(.Call("matrix_multiply", x, y, FALSE, FALSE, x@type))
})
setMethod("%*%", signature(x = "gmatrix", y = "gvector"),
function(x,y) {
eval(.exprs_sf_xy)
ytmp=new("gmatrix",nrow=length(y),ncol=1L,ptr=y@ptr, type=y@type)
return(.Call("matrix_multiply", x, ytmp, FALSE, FALSE, x@type))
})
setMethod("%*%", signature(x = "gvector", y = "gmatrix"),
function(x,y) {
eval(.exprs_sf_xy)
xtmp=new("gmatrix",ncol=length(x),nrow=1L,ptr=x@ptr, type=x@type)
return(.Call("matrix_multiply", xtmp, y, FALSE, FALSE, x@type))
})
setMethod("%*%", signature(x = "gmatrix", y = "numeric"),
function(x,y) {
if(x@type==1L) {
y=as.gvector(y, type=1L)
} else
y=as.gvector(y)
return(x%*%y)
})
setMethod("%*%", signature(x = "numeric", y = "gmatrix"),
function(x,y) {
if(y@type==1L) {
x=as.gvector(x, type=1L)
} else
x=as.gvector(x)
return(x%*%y)
})
setMethod("%*%", signature(x = "gmatrix", y = "matrix"),
function(x,y) {
if(x@type==1L) {
y=as.gmatrix(y, type=1L)
} else
y=as.gmatrix(y)
return(x%*%y)
})
setMethod("%*%", signature(x = "matrix", y = "gmatrix"),
function(x,y) {
if(y@type==1L) {
x=as.gmatrix(x, type=1L)
} else
x=as.gmatrix(x)
return(x%*%y)
})
setMethod("%*%", signature(x = "gmatrix", y = "logical"),
function(x,y) {
if(x@type==1L) {
y=as.gvector(y, type=1L)
} else
y=as.gvector(y)
return(x%*%y)
})
setMethod("%*%", signature(x = "logical", y = "gmatrix"),
function(x,y) {
if(y@type==1L) {
x=as.gvector(x, type=1L)
} else
x=as.gvector(x)
return(x%*%y)
})
setMethod("%*%", signature(x = "gvector", y= "gvector"),
function(x,y) {
#browser()
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE))
})
setMethod("%*%", signature(x = "numeric", y= "gvector"),
function(x,y) {
#browser()
if(y@type==1L)
return(gmatrix(x,nrow=1,dup=FALSE, type=1L) %*% gmatrix(y,ncol=1,dup=FALSE))
else
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE))
})
setMethod("%*%", signature(x = "gvector", y= "numeric"),
function(x,y) {
#browser()
if(x@type==1L)
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE, type=1L))
else
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE))
})
setMethod("%*%", signature(x = "logical", y= "gvector"),
function(x,y) {
if(y@type==1L)
return(gmatrix(x,nrow=1,dup=FALSE, type=1L) %*% gmatrix(y,ncol=1,dup=FALSE))
else
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE))
})
setMethod("%*%", signature(x = "gvector", y= "logical"),
function(x,y) {
if(x@type==1L)
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE, type=1L))
else
return(gmatrix(x,nrow=1,dup=FALSE) %*% gmatrix(y,ncol=1,dup=FALSE))
})
setMethod("%*%", signature(x = "gvector", y= "matrix"),
function(x,y) {
if(x@type==1L) {
y=as.gmatrix(y, type=1L)
} else
y=as.gmatrix(y)
return(x%*%y)
})
setMethod("%*%", signature(x = "matrix", y= "gvector"),
function(x,y) {
if(y@type==1L) {
x=as.gmatrix(x, type=1L)
} else
x=as.gmatrix(x)
return(x%*%y)
})
##############################################
# GMM function to avoid the allocating C
##############################################
gmm = function(A, B, C, trA=FALSE, trB=FALSE, accum=FALSE) {
if(class(A)=="gvector")
A=gmatrix(A,nrow=1,dup=FALSE)
else if(class(A)!="gmatrix")
stop("A must be of class 'gmatrix' or 'gvector.'")
if(class(B)=="gvector")
B=gmatrix(B,ncol=1,dup=FALSE)
else if(class(B)!="gmatrix")
stop("B must be of class 'gmatrix' or 'gvector.'")
if(class(C)=="gvector")
C=gmatrix(C,ncol=1,dup=FALSE)
else if(class(C)!="gmatrix")
stop("C must be of class 'gmatrix' or 'gvector.'")
accum=as.logical(accum)[1]
if(A@type!=B@type || B@type !=C@type)
stop("A, B and C must all have the same type.")
if(A@type>1)
stop("The 'gmm' function may only be used for type 'single' or 'double.' Please convert first.")
# SEXP gpu_gmm(SEXP A_in, SEXP B_in, SEXP C_in, SEXP transa, SEXP transb, SEXP accum, SEXP in_type)
invisible(.Call("gpu_gmm", A, B, C, trA, trB, accum, A@type))
}
##############################################
# Cross Product
##############################################
setMethod("crossprod", signature(x = "gmatrix", y = "missing"),
function(x,y){
if(x@type>1L)
type(x)=0
checkDevice(x@device)
return(.Call("matrix_multiply", x, x, TRUE, FALSE,x@type))
})
setMethod("crossprod", signature(x = "gmatrix", y = "gmatrix"),
function(x,y){
eval(.exprs_sf_xy)
return(.Call("matrix_multiply", x, y, TRUE, FALSE,x@type))
})
setMethod("crossprod", signature(x = "gmatrix", y = "matrix"),
function(x,y){
if(x@type==1L)
y=g(y, type=1L)
else
y=g(y)
eval(.exprs_sf_xy)
return(.Call("matrix_multiply", x, y, TRUE, FALSE, x@type))
})
setMethod("crossprod", signature(x = "matrix", y = "gmatrix"),
function(x,y){
if(y@type==1L)
x=g(x, type=1L)
else
x=g(x)
eval(.exprs_sf_xy)
return(.Call("matrix_multiply", x, y, TRUE, FALSE,x@type))
})
setMethod("crossprod", signature(x = "matrix", y = "gmatrix"),
function(x,y){
if(y@type==1L)
x=g(x, type=1L)
else
x=g(x)
eval(.exprs_sf_xy)
return(.Call("matrix_multiply", x, y, TRUE, FALSE,x@type))
})
.cp = function(x,y) {
flgx=!(class(x) %in% c("gmatrix", "gvector"))
flgy=!(class(y) %in% c("gmatrix", "gvector"))
if(flgx) {
if(!flgy) {
if(y@type==1)
x=g(x,type=1L)
else
x=g(x)
} else
x=g(x)
}
if(flgy) {
if(!flgx) {
if(x@type==1)
y=g(y,type=1L)
else
y=g(y)
} else
y=g(y)
}
eval(.exprs_sf_xy)
if(class(x)=="gvector"){
x=gmatrix(x,nrow=1,dup=FALSE)
if(class(y)=="gvector")
y=gmatrix(y,ncol=1,dup=FALSE)
return(.Call("matrix_multiply", x, y, FALSE, FALSE,x@type))
}
#if here then y is a gvector (b/c one of the two must be a gvector) and x is a gmatrix
y=gmatrix(y,ncol=1,dup=FALSE)
return(.Call("matrix_multiply", x, y, TRUE, FALSE,x@type))
}
setMethod("crossprod", signature(x = "numeric", y = "gmatrix"), .cp)
setMethod("crossprod", signature(x = "gmatrix", y = "numeric"), .cp)
setMethod("crossprod", signature(x = "logical", y = "gmatrix"), .cp)
setMethod("crossprod", signature(x = "gmatrix", y = "logical"), .cp)
setMethod("crossprod", signature(x = "gvector", y = "gmatrix"), .cp)
setMethod("crossprod", signature(x = "gmatrix", y = "gvector"), .cp)
setMethod("crossprod", signature(x = "gvector", y = "gvector"), .cp)
setMethod("crossprod", signature(x = "gvector", y = "missing"), function(x,y) {.cp(x,x)})
setMethod("crossprod", signature(x = "gvector", y = "numeric"), .cp)
setMethod("crossprod", signature(x = "numeric", y = "gvector"), .cp)
setMethod("crossprod", signature(x = "gvector", y = "logical"), .cp)
setMethod("crossprod", signature(x = "logical", y = "gvector"), .cp)
setMethod("crossprod", signature(x = "gvector", y = "matrix"), .cp)
setMethod("crossprod", signature(x = "matrix", y = "gvector"), .cp)
##############################################
# Transpose Cross Product
##############################################
setMethod("tcrossprod", signature(x = "gmatrix", y = "missing"),
function(x,y){
if(x@type>1L)
type(x)=0
checkDevice(x@device)
return(.Call("matrix_multiply", x, x, FALSE, TRUE,x@type))
})
setMethod("tcrossprod", signature(x = "gmatrix", y = "gmatrix"),
function(x,y){
eval(.exprs_sf_xy)
return(.Call("matrix_multiply", x, y, FALSE, TRUE,x@type))
})
setMethod("tcrossprod", signature(x = "gmatrix", y = "matrix"),
function(x,y){
if(x@type==1L)
y=g(y, type=1L)
else
y=g(y)
eval(.exprs_sf_xy)
return(.Call("matrix_multiply",x, y, FALSE, TRUE, x@type))
})
setMethod("tcrossprod", signature(x = "matrix", y = "gmatrix"),
function(x,y){
if(y@type==1L)
x=g(x, type=1L)
else
x=g(x)
eval(.exprs_sf_xy)
return(.Call("matrix_multiply",x ,y, FALSE, TRUE, x@type))
})
.tcp = function(x,y) {
flgx=!(class(x) %in% c("gmatrix", "gvector"))
flgy=!(class(y) %in% c("gmatrix", "gvector"))
if(flgx) {
if(!flgy) {
if(y@type==1)
x=g(x,type=1L)
else
x=g(x)
} else
x=g(x)
}
if(flgy) {
if(!flgx) {
if(x@type==1)
y=g(y,type=1L)
else
y=g(y)
} else
y=g(y)
}
eval(.exprs_sf_xy)
#browser()
if(class(x)=="gvector"){
if(class(y)=="gvector") {
x=gmatrix(x,ncol=1,dup=FALSE)
y=gmatrix(y,nrow=1,dup=FALSE)
return(.Call("matrix_multiply", x, y, FALSE, FALSE, x@type))
} else {
# browser()
x=gmatrix(x,nrow=1,dup=FALSE)
return(.Call("matrix_multiply", x, y, FALSE, TRUE, x@type))
}
}
#if here then y is a gvector (b/c one of the two must be a gvector) and x is a gmatrix
y=gmatrix(y,ncol=1,dup=FALSE)
return(.Call("matrix_multiply", x, y, FALSE, TRUE, x@type))
}
setMethod("tcrossprod", signature(x = "numeric", y = "gmatrix"), .tcp)
setMethod("tcrossprod", signature(x = "gmatrix", y = "numeric"), .tcp)
setMethod("tcrossprod", signature(x = "logical", y = "gmatrix"), .tcp)
setMethod("tcrossprod", signature(x = "gmatrix", y = "logical"), .tcp)
setMethod("tcrossprod", signature(x = "gvector", y = "gmatrix"), .tcp)
setMethod("tcrossprod", signature(x = "gmatrix", y = "gvector"), .tcp)
setMethod("tcrossprod", signature(x = "gvector", y = "gvector"), .tcp)
setMethod("tcrossprod", signature(x = "gvector", y = "missing"), function(x,y) {.tcp(x,x)})
setMethod("tcrossprod", signature(x = "gvector", y = "numeric"), .tcp)
setMethod("tcrossprod", signature(x = "numeric", y = "gvector"), .tcp)
setMethod("tcrossprod", signature(x = "gvector", y = "logical"), .tcp)
setMethod("tcrossprod", signature(x = "logical", y = "gvector"), .tcp)
setMethod("tcrossprod", signature(x = "gvector", y = "matrix"), .tcp)
setMethod("tcrossprod", signature(x = "matrix", y = "gvector"), .tcp)
#####################################################
# Outer Product
#####################################################
gouter<-function(x,y,FUN="*", normalOrder=TRUE ){
if(is.vector(x))
if(class(y)=="gvector") {
if(y@type==1L)
x=as.gvector(x,type=1L)
else
x=as.gvector(x)
} else
x=as.gvector(x)
if(is.vector(y))
if(class(x)=="gvector") {
if(x@type==1L)
y=as.gvector(y,type=1L)
else
y=as.gvector(y)
} else
y=as.gvector(y)
if(class(x)!="gvector" && class(y)!="gvector")
stop("Expected input types of 'gvector' or 'vector'.")
eval(.exprs_sf_xy)
checkDevice(c(x@device,y@device))
if(class(x)!="gvector")
x=as.gvector(x)
if(class(y)!="gvector")
y=as.gvector(y)
# if(op==1)
# ret[i] = x[row] * y[col];
# else if(op==2)
# ret[i] = x[row] + y[col];
# else if(op==3)
# ret[i] =x[row] - y[col];
# else if(op==4)
# ret[i] =y[row] - x[col];
# else if(op==5)
# ret[i] =x[row] / y[col];
# else if(op==6)
# ret[i] =y[row] / x[col];
# else if(op==7)
# ret[i] = pow(x[row] , y[col]) ;
# else if(op==8)
# ret[i] = pow(y[row] , x[col]) ;
if(FUN=="*")
op=1L
else if(FUN=="+")
op=2L
else if(FUN=="-"){
if(normalOrder)
op=3L
else
op=4L
} else if(FUN=="/"){
if(normalOrder)
op=5L
else
op=6L
}else if(FUN=="^"){
if(normalOrder)
op=7L
else
op=8L
} else
stop("Invalid function.")
#gpu_outer(SEXP A_in, SEXP B_in,SEXP n_A_in, SEXP n_B_in, SEXP op_in)
return(new("gmatrix",
ptr=.Call("gpu_outer",x@ptr,y@ptr,length(x),length(y),op, x@type),
nrow=length(x),ncol=length(y),
rownames=names(x),colnames=names(y),
type=x@type))
}
setMethod("%o%", signature(X = "gvector", Y= "gvector"),
function(X,Y) {
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE))
})
setMethod("%o%", signature(X = "numeric", Y= "gvector"),
function(X,Y) {
if(Y@type==1L)
return(gmatrix(X,ncol=1,dup=FALSE, type=1L) %*% gmatrix(Y,nrow=1,dup=FALSE))
else
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE))
})
setMethod("%o%", signature(X = "gvector", Y= "numeric"),
function(X,Y) {
if(X@type==1L)
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE, type=1L))
else
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE))
})
setMethod("%o%", signature(X = "logical", Y= "gvector"),
function(X,Y) {
if(Y@type==1L)
return(gmatrix(X,ncol=1,dup=FALSE, type=1L) %*% gmatrix(Y,nrow=1,dup=FALSE))
else
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE))
})
setMethod("%o%", signature(X = "gvector", Y= "logical"),
function(X,Y) {
if(X@type==1L)
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE, type=1L))
else
return(gmatrix(X,ncol=1,dup=FALSE) %*% gmatrix(Y,nrow=1,dup=FALSE))
})
################################################
# Sums and Means
################################################
setMethod("colSums", "gmatrix",
function(x, na.rm = FALSE, dims = 1) {
if(na.rm)
stop("na.rm not implemented on the GPU")
if(dims!=1)
stop("invalid 'dims'")
return(as.gvector( rep(1,nrow(x)) %*% x , dup=FALSE))
}
)
setMethod("rowSums", "gmatrix",
function(x, na.rm = FALSE, dims = 1) {
if(na.rm)
stop("na.rm not implemented on the GPU")
if(dims!=1)
stop("invalid 'dims'")
# browser()
return(as.gvector(x %*% g.rep(1,ncol(x)), dup=FALSE))
}
)
gRowLogSums = function(x, startCol=1L, endCol=ncol(x)) {
if(class(x)!="gmatrix")
stop("Object must be of class 'gmatrix.'")
if(x@type>1L)
stop("Invalid type")
startCol=as.integer(startCol)
endCol=as.integer(endCol)
if(startCol<1L || startCol>ncol(x) || startCol>endCol)
stop("Invalid startCol.")
if(endCol<1L || endCol>ncol(x) )
stop("Invalid endCol.")
checkDevice(x@device)
ret = new("gvector", ptr=.Call("gpu_rowLogSums", ptr=x@ptr,
nrow(x), endCol, startCol, x@type),
length=nrow(x),type=x@type)
return(ret)
}
setMethod("colMeans", "gmatrix",
function(x, na.rm = FALSE, dims = 1) {
# browser()
if(na.rm)
stop("na.rm not implemented on the GPU")
if(dims!=1)
stop("invalid 'dims'")
return(g.rep(1,nrow(x)) %*% x/nrow(x))
}
)
setMethod("rowMeans", "gmatrix",
function(x, na.rm = FALSE, dims = 1) {
if(na.rm)
stop("na.rm not implemented on the GPU")
if(dims!=1)
stop("invalid 'dims'")
return(as.gvector(x %*% rep(1,ncol(x)), dup=FALSE)/ncol(x))
}
)
setMethod("sum", "gvector",
function(x, na.rm = FALSE, retgpu=TRUE) {
if(na.rm)
stop("na.rm not implemented on the GPU")
ret=.Call("gpu_sum",x@ptr, length(x), x@type)
if(retgpu)
ret=as.gvector(ret)
return(ret)
}
)
setMethod("mean", "gvector",
function(x, na.rm = FALSE, trim=0,retgpu=TRUE) {
if(trim != 0)
stop("trim not supported on GPU")
if(na.rm)
stop("na.rm not implemented on the GPU")
checkDevice(x@device)
ret=.Call("gpu_sum",x@ptr, length(x), x@type)/length(x)
if(retgpu)
ret=as.gvector(ret)
return(ret)
}
)
setMethod("sum", "gmatrix", function(x,...)
return(sum(as.gvector(x,dup=FALSE),...)))
setMethod("mean", "gmatrix", function(x,...)
return(mean(as.gvector(x,dup=FALSE),...)))
setMethod("max", "gvector",
function(x, na.rm = FALSE, retgpu=TRUE, pos=FALSE) {
if(na.rm)
stop("na.rm not implemented on the GPU")
checkDevice(x@device)
ret=.Call("gpu_max",x@ptr, length(x), x@type)
if(retgpu)
ret=as.gvector(ret)
return(ret)
}
)
setMethod("max", "gmatrix", function(x,...)
return(max(as.gvector(x,dup=FALSE),...)))
setMethod("min", "gvector",
function(x, na.rm = FALSE, retgpu=TRUE, pos=FALSE) {
if(na.rm)
stop("na.rm not implemented on the GPU")
checkDevice(x@device)
ret=.Call("gpu_min",x@ptr, length(x), x@type)
if(retgpu)
ret=as.gvector(ret)
return(ret)
}
)
setMethod("min", "gmatrix", function(x,...)
return(max(as.gvector(x,dup=FALSE),...)))
setMethod("sort", "gvector",
function(x, decreasing = FALSE, dup=TRUE) {
if(length(names(x))>0) {
warning("Names are being striped for sorting")
x=gnamestrip(x)
}
#browser()
if(dup)
x=gdup(x)
#if(x@type==0 && stable)
# warning("There may be problems with stable sorting for type 'double'. We suggest that the user set stable to 'FALSE' when sorting doubles. This is likely a problem with the thrust library which will be fixed in future releases.")
#SEXP gpu_sort(SEXP A_in, SEXP n_in, SEXP stable_in, SEXP decreasing_in, SEXP in_type)
checkDevice(x@device)
if(x@type ==0L)
ret=.Call("gpu_sort",x@ptr, length(x),FALSE, as.logical(decreasing), x@type)
else if (x@type ==1L)
ret=.Call("gpu_sort",x@ptr, length(x),TRUE, as.logical(decreasing), x@type)
else {
#ok... jerry rig this just so it works... this could use some attention so it isn't so strange
outype=x@type
type(x)=0L
ret=.Call("gpu_sort",x@ptr, length(x),FALSE, as.logical(decreasing), x@type)
type(x)=outype
}
return(x)
}
)
#setMethod("order", "gvector",
#suppressWarnings(setGeneric("order",
# function(x,...)
# base::order(x,...)
# ))
gorder = function(x, decreasing = FALSE, stable=TRUE, sortx=FALSE) {
if(class(x) != "gvector")
x=as.gvector(x)
else
if(!sortx)
x=gdup(x)
#SEXP gpu_sort(SEXP A_in, SEXP n_in, SEXP stable_in, SEXP decreasing_in, SEXP in_type)
#warning("figure out na last")
checkDevice(x@device)
ret=.Call("gpu_order",x@ptr, length(x),as.logical(stable), as.logical(decreasing), x@type)
return(ret)
}
setMethod("which", "gvector",
function(x, arr.ind = FALSE, useNames = TRUE) {
if(arr.ind)
stop("Error in which: 'arr.ind' = TRUE has not been implemented on the GPU. Transfer to CPU first.")
#SEXP gpu_sort(SEXP A_in, SEXP n_in, SEXP stable_in, SEXP decreasing_in, SEXP in_type)
#gpu_which(SEXP A_in, SEXP n_in)
if(x@type!=3L)
stop("Error in which: argument to 'which' is not logical")
checkDevice(x@device)
ret=.Call("gpu_which",x@ptr, length(x))
return(ret)
}
)
setMethod("ifelse", "gvector",
function(test, yes, no) {
if(!(class(yes) %in% c("gvector","gmatrix")))
yes=g(yes)
if(!(class(no) %in% c("gvector","gmatrix")))
no=g(no)
if(test@type!=3L)
type(test)=3L
if(yes@type!=no@type) {
totype=min(c(yes@type,no@type))
if(yes@type!=totype)
yes=convertType(yes,totype)
if(no@type!=totype)
no=convertType(no,totype)
}
#SEXP gpu_if(SEXP H_in, SEXP A_in, SEXP B_in,SEXP snh, SEXP sna, SEXP snb, SEXP in_type)
checkDevice(c(test@device,yes@device,no@device))
ret=new("gvector",
length=length(test),
names=names(test),
type=yes@type,
ptr=.Call("gpu_if",test@ptr,yes@ptr, no@ptr, length(test), length(yes),length(no), yes@type ))
return(ret)
}
)
setMethod("ifelse", "gmatrix",
function(test, yes, no) {
if(!(class(yes) %in% c("gvector","gmatrix")))
yes=g(yes)
if(!(class(no) %in% c("gvector","gmatrix")))
no=g(no)
if(test@type!=3L)
type(test)=3L
if(yes@type!=no@type) {
totype=min(c(yes@type,no@type))
if(yes@type!=totype)
yes=convertType(yes,totype)
if(no@type!=totype)
no=convertType(no,totype)
}
#SEXP gpu_if(SEXP H_in, SEXP A_in, SEXP B_in,SEXP snh, SEXP sna, SEXP snb, SEXP in_type)
checkDevice(c(test@device,yes@device,no@device))
ret=new("gmatrix",
nrow = test@nrow,
ncol = test@ncol,
rownames=test@rownames,
colnames=test@rownames,
type=yes@type,
ptr=.Call("gpu_if",test@ptr,yes@ptr, no@ptr, length(test), length(yes),length(no), yes@type ))
return(ret)
}
)
#setMethod("min", "gvector",
# function(x, na.rm = FALSE, retgpu=TRUE, pos=FALSE) {
# if(na.rm)
# stop("na.rm not implemented on the GPU")
# ret=.Call("gpu_min_pos",x@ptr, length(x))
# if(!pos) {
# ret=x[ret]
# if(!retgpu)
# ret=as.numeric(ret)
# } else if(retgpu)
# ret=as.gvector(ret)
#
# return(ret)
# }
#)
#setMethod("min", "gmatrix", function(x,...)
# return(min(as.gvector(x,dup=FALSE),...)))
.exprs_Av=eval(substitute(substitute(e, list(x = bquote(A), y=bquote(v))), list(e = .exprs_xy)))
gmatTimesDiagVec=function(A,v) {
if(class(A)!="gmatrix") {
if(is.matrix(A))
A=as.gmatrix(A, dup=FALSE)
else
stop("Input 'A' must be a 'matrix' or 'gmatrix'.")
}
if(class(v)!="gvector")
v=as.gvector(v, dup=FALSE)
if(ncol(A)!=length(v))
stop("Mismatched dimensions.")
eval(.exprs_Av)
ret=A
ret@ptr=.Call("gpu_mat_times_diag_vec",A@ptr, v@ptr, nrow(A), ncol(A), ret@type)
return(ret)
}
.exprs_AB=eval(substitute(substitute(e, list(x = bquote(A), y=bquote(B))), list(e = .exprs_xy)))
gkroneckerProd=function(A,B) {
if(class(A)=="gvector")
A=gmatrix(A, dup=FALSE)
if(class(B)=="gvector")
B=gmatrix(B, dup=FALSE)
if(class(A)!="gmatrix") {
if(is.matrix(A)|| is.vector(B)) {
if(class(B)%in%c("gmatrix","gvector")) {
if(B@type==1L)
A=as.gmatrix(A, type=1L)
else
A=as.gmatrix(A)
} else
A=as.gmatrix(A)
}else
stop("Input 'A' must be a 'vector', 'matrix', 'gmatrix' or 'gvector'.")
}
if(class(B)!="gmatrix") {
if(is.matrix(B) || is.vector(B))
if(class(A)%in%c("gmatrix","gvector")){
if(A@type==1L)
B=as.gmatrix(B, type=1L)
else
B=as.gmatrix(B)
} else
B=as.gmatrix(B)
else
stop("Input 'B' must be a 'vector', 'matrix', 'gmatrix' or 'gvector'.")
}
.exprs_AB
#SEXP gpu_kronecker(SEXP A_in, SEXP B_in,SEXP n_A_row_in,SEXP n_A_col_in, SEXP n_B_row_in,SEXP n_B_col_in);
ret = new("gmatrix",ptr=.Call("gpu_kronecker",A@ptr, B@ptr, nrow(A), ncol(A), nrow(B), ncol(B), A@type),
nrow=nrow(A)*nrow(B),ncol=ncol(A)*ncol(B), type=A@type)
return(ret)
}
gsumby=function(v,startPos,stopPos) {
if(class(v)!="gvector")
v=as.gvector(v, dup=FALSE)
if(type(v)==3L)
type(v)=2L
if(!is.integer(startPos))
startPos=as.integer(startPos)
if(!is.integer(stopPos))
stopPos=as.integer(stopPos)
if(length(startPos)!=length(stopPos))
stop("The length of startPos and stopPos must be the same.")
#SEXP gpu_kernal_sumby(SEXP A_in, SEXP index1_in,SEXP index2_in,SEXP n_A_in,SEXP n_index_in);
checkDevice(v@device) #Todo: make the C code utilize startPos of class gvector
ret = new("gvector",
ptr = .Call("gpu_kernal_sumby", v@ptr, startPos, stopPos, length(v), length(stopPos), v@type),
length = length(startPos),
names = names(startPos),
type=v@type)
return(ret)
}
setMethod("%x%", signature(X = "gvector", Y = "gvector"), function(X,Y) return(as.gvector(gkroneckerProd(X,Y),dup=FALSE)))
setMethod("%x%", signature(X = "gvector", Y = "numeric"), function(X,Y) return(as.gvector(gkroneckerProd(X,Y),dup=FALSE)) )
setMethod("%x%", signature(X = "numeric", Y = "gvector"), function(X,Y) return(as.gvector(gkroneckerProd(X,Y),dup=FALSE)))
setMethod("%x%", signature(X = "gmatrix", Y = "gmatrix"), function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "gmatrix", Y = "gvector"), function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "gvector", Y = "gmatrix"), function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "gmatrix", Y = "numeric"),function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "numeric", Y = "gmatrix"), function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "gmatrix", Y = "matrix"),function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "matrix", Y = "gmatrix"), function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "gvector", Y = "matrix"),function(X,Y) return(gkroneckerProd(X,Y)))
setMethod("%x%", signature(X = "matrix", Y = "gvector"), function(X,Y) return(gkroneckerProd(X,Y)))
#######################################
# elementwise special functions
#######################################
setMethod("!","gvector", function(x) return(x==0L) )
setMethod("!","gmatrix", function(x) return(x==0L) )
setMethod("-", signature(e1 = "gmatrix", e2 = "missing"), function(e1) return(-1*e1))
setMethod("-", signature(e1 = "gvector", e2 = "missing"), function(e1) return(-1*e1))
setMethod("+", signature(e1 = "gmatrix", e2 = "missing"), function(e1) return(gdup(e1)))
setMethod("+", signature(e1 = "gvector", e2 = "missing"), function(e1) return(gdup(e1)))
#one_over=function(x)
# return(1/x)
#setGeneric("one_over")
.str_unaryops ='
setMethod("MRNAME","gvector", function(x) {
if(x@type>1L)
x=convertType(x,0L)
if(length(gvector)<1L)
return(x)
checkDevice(x@device)
return(new("gvector",ptr=.Call("gpu_MNAME",x@ptr, length(x), x@type),
length=x@length, names=x@names, type=MTYPE))})
setMethod("MRNAME","gmatrix", function(x) {
if(x@type>1L)
x=convertType(x,0L)
checkDevice(x@device)
return(new("gmatrix",ptr=.Call("gpu_MNAME",x@ptr, as.integer(prod(dim(x))),x@type),
nrow=x@nrow, ncol=x@ncol, rownames=x@rownames, colnames=x@colnames, type=MTYPE))})
'
.str_unaryops_ip ='
setGeneric("MRNAMEIp",
function(x)
standardGeneric("MRNAMEIp"))
setMethod("MRNAMEIp","gvector", function(x) {
if(x@type>1L)
stop("In place operations must be for \'double\' or \'single.\'")
if(length(gvector)<1L)
return(x)
checkDevice(x@device)
return(new("gvector",ptr=.Call("gpu_ip_MNAME",x@ptr, length(x), x@type),
length=x@length, names=x@names, type=MTYPE))})
setMethod("MRNAMEIp","gmatrix", function(x) {
if(x@type>1L)
stop("In place operations must be for \'double\' or \'single.\'")
checkDevice(x@device)
return(new("gmatrix",ptr=.Call("gpu_ip_MNAME",x@ptr, as.integer(prod(dim(x))),x@type),
nrow=x@nrow, ncol=x@ncol, rownames=x@rownames, colnames=x@colnames, type=MTYPE))})
'
.unOps= list(
# c('one_over','one_over', "x@type"),
c('sqrt','sqrt', "x@type"),
c('exp','exp', "x@type"),
c('expm1','expm1', "x@type"),
c('log','log', "x@type"),
c('log2','log2', 'x@type'),
c('log10','log10', 'x@type'),
c('log1p','log1p', 'x@type'),
c('sin','sin', 'x@type'),
c('cos','cos', 'x@type'),
c('tan','tan', 'x@type'),
c('asin','asin', 'x@type'),
c('acos','acos', 'x@type'),
c('atan','atan', 'x@type'),
c('sinh','sinh', 'x@type'),
c('cosh','cosh', 'x@type'),
c('tanh','tanh', 'x@type'),
c('asinh','asinh','x@type'),
c('acosh','acosh', 'x@type'),
c('atanh','atanh', 'x@type'),
c('abs','fabs', 'x@type'),
c('lgamma','lgamma', 'x@type'),
c('gamma','gamma', 'x@type'),
c('sign','sign', 'x@type'),
c('round','round', '2L'),
c('ceiling','ceil', '2L'),
c('floor','floor', '2L'),
c('is.na','isna', '3L'),
c('is.nan','isnan', '3L'),
c('is.finite','isfinite', '3L'),
c('is.infinite','isinfinite', '3L')
)
lapply(.unOps, function(op) {
exprStr = gsub("MRNAME",op[1],.str_unaryops)
exprStr = gsub("MNAME",op[2],exprStr)
exprStr = gsub("MTYPE",op[3],exprStr)
#cat(exprStr)
eval(parse(text=exprStr))
} )
lapply(.unOps[sapply(.unOps, function(x) x[3]=="x@type")], function(op) {
exprStr = gsub("MRNAME",op[1],.str_unaryops_ip)
exprStr = gsub("MNAME",op[2],exprStr)
exprStr = gsub("MTYPE",op[3],exprStr)
#cat(exprStr)
eval(parse(text=exprStr))
} )
#######################################
# elementwise binary operations
#######################################
#Non-exchangeable binary operations
.strOpNonExchang = '
setMethod("MOP", signature(e1 = "gvector", e2 = "gvector"),
function(e1,e2) {
MEXPRS
if(length(e2)<1L)
return(e2)
else if(length(e1)<1L)
return(e1)
else if(length(e2)==1L){
tryCatch(e2 <- .convert_to_appropriate_class(e2,e1@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
#e2=as.double(e2)
ret=new("gvector", length=length(e1), names=names(e1), type=MT1)
ret@ptr=.Call("gpu_scaler_MNAME12", e1@ptr, e2, length(e1), e1@type)
} else if(length(e1)==1L){
tryCatch(e1 <- .convert_to_appropriate_class(e1,e2@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
#e1=as.double(e1)
ret=new("gvector", length=length(e2), names=names(e2), type=MT2)
ret@ptr=.Call("gpu_scaler_MNAME21", e2@ptr, e1, length(e2), e2@type)
} else if(length(e1)==length(e2)) {
ret=new("gvector",length=length(e1), names=names(e1), type=MT1)
ret@ptr=.Call("gpu_same_size_MNAME12", e1@ptr, e2@ptr, e2@length, e1@type)
} else {
if(length(e1)<length(e2)) {
small=e1
big=e2
reverse=TRUE
} else {
small=e2
big=e1
reverse=FALSE
}
if((length(big) %% length(small)) !=0)
stop("longer object length is not a multiple of shorter object length", call. = FALSE)
ret=new("gvector",length=length(big), names=names(big), type=MT1)
if(reverse)
ret@ptr=.Call("gpu_diff_size_MNAME21", big@ptr, small@ptr, big@length, small@length, e1@type)
else
ret@ptr=.Call("gpu_diff_size_MNAME12", big@ptr, small@ptr, big@length, small@length, e1@type)
}
return(ret)
}
)
.gvec.vec.MNAME = function(e1,e2) {
if(length(e2)<1L)
return(e2)
else if(length(e1)<1L)
return(e1)
else if(length(e2)==1L){
#tryCatch(e2 <- .convert_to_appropriate_class(e2,e1@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
#e2=as.double(e2)
MDIFEXPRS12
ret=new("gvector", length=length(e1), names=names(e1), type=MT1)
ret@ptr=.Call("gpu_scaler_MNAME12", e1@ptr, e2, length(e1), e1@type)
} else {
if(e1@type==1L)
tmp=as.gvector(e2, type=1L)
else
tmp=as.gvector(e2)
ret=e1 MOP tmp
}
return(ret)
}
.vec.gvec.MNAME = function(e1,e2) {
if(length(e2)<1L)
return(e2)
else if(length(e1)<1L)
return(e1)
else if(length(e1)==1L){
#tryCatch(e1 <- .convert_to_appropriate_class(e1,e2@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
#e1=as.double(e1)
MDIFEXPRS21
ret=new("gvector", length=length(e2), names=names(e2), type=MT2)
ret@ptr=.Call("gpu_scaler_MNAME21", e2@ptr, e1, length(e2), e2@type)
} else {
if(e2@type==1L)
tmp=as.gvector(e1, type=1L)
else
tmp=as.gvector(e1)
ret=tmp MOP e2
}
return(ret)
}
setMethod("MOP", signature(e1 = "gvector", e2 = "numeric"), .gvec.vec.MNAME )
setMethod("MOP", signature(e1 = "gvector", e2 = "logical"), .gvec.vec.MNAME )
setMethod("MOP", signature(e1 = "numeric", e2 = "gvector"), .vec.gvec.MNAME )
setMethod("MOP", signature(e1 = "logical", e2 = "gvector"), .vec.gvec.MNAME )
setMethod("MOP", signature(e1 = "gmatrix", e2 = "gmatrix"),
function(e1,e2) {
MEXPRS
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operations.", call. = FALSE)
myn=as.integer(prod(dim(e1)))
ret=new("gmatrix", nrow = e1@nrow, ncol = e1@ncol,
rownames=e1@rownames, colnames=e1@colnames, type=MT1)
ret@ptr=.Call("gpu_same_size_MNAME12", e1@ptr, e2@ptr, myn, e1@type)
return(ret)
})
.gmat.vec.MNAME=function(e1,e2) {
checkDevice(e1@device)
tmp1=new("gvector",length=as.integer(prod(dim(e1))),ptr=e1@ptr, type=e1@type)
if(length(tmp1)==1) {
ret = tmp1 MOP e2
}else if(length(tmp1) < length(e2)) {
stop("Dimensions do not match for elementwise operations.", call. = FALSE)
}else {
ret=e1
tmpret=tmp1 MOP e2
ret@ptr=tmpret@ptr
ret@type=tmpret@type
}
return(ret)
}
.vec.gmat.MNAME =function(e1,e2) {
checkDevice(e2@device)
tmp2=new("gvector",length=as.integer(prod(dim(e2))),ptr=e2@ptr, type=e2@type)
if(length(tmp2)==1) {
ret = e1 MOP tmp2
}else if(length(tmp2) < length(e1)) {
stop("Dimensions do not match for elementwise operations.", call. = FALSE)
}else {
ret=e2
tmpret=e1 MOP tmp2
ret@ptr=tmpret@ptr
ret@type=tmpret@type
}
return(ret)
}
setMethod("MOP", signature(e1 = "gmatrix", e2 = "numeric"), .gmat.vec.MNAME)
setMethod("MOP", signature(e1 = "gmatrix", e2 = "logical"), .gmat.vec.MNAME)
setMethod("MOP", signature(e1 = "numeric", e2 = "gmatrix"), .vec.gmat.MNAME)
setMethod("MOP", signature(e1 = "logical", e2 = "gmatrix"), .vec.gmat.MNAME)
setMethod("MOP", signature(e1 = "gmatrix", e2 = "gvector"),
function(e1,e2) {
checkDevice(c(e1@device,e2@device))
tmp1=new("gvector",length=as.integer(prod(dim(e1))),ptr=e1@ptr, type=e1@type)
if(length(tmp1)==1) {
ret = tmp1 MOP e2
}else if(length(tmp1) < length(e2)) {
stop("Dimensions do not match for elementwise operations.", call. = FALSE)
}else {
ret=e1
tmpret=tmp1 MOP e2
ret@ptr=tmpret@ptr
ret@type=tmpret@type
}
return(ret)
})
setMethod("MOP", signature(e1 = "gvector", e2 = "gmatrix"),
function(e1,e2) {
checkDevice(c(e1@device,e2@device))
MEXPRS
tmp2=new("gvector",length=as.integer(prod(dim(e2))),ptr=e2@ptr, type= e2@type)
if(length(tmp2)==1) {
ret = e1 MOP tmp2
}else if(length(tmp2) < length(e1)) {
stop("Dimensions do not match for elementwise operations.", call. = FALSE)
}else {
ret=e2
tmpret=e1 MOP tmp2
ret@ptr=tmpret@ptr
ret@type=tmpret@type
}
return(ret)
}
)
setMethod("MOP", signature(e1 = "gvector", e2 = "matrix"),
function(e1,e2) {
if(e1@type==1L)
tmp=as.gmatrix(e2,type=1L)
else
tmp=as.gmatrix(e2)
return(e1 MOP tmp)
}
)
setMethod("MOP", signature(e1 = "matrix", e2 = "gvector"),
function(e1,e2) {
if(e2@type==1L)
tmp=as.gmatrix(e1,type=1L)
else
tmp=as.gmatrix(e1)
return(tmp MOP e2)
}
)
setMethod("MOP", signature(e1 = "gmatrix", e2 = "matrix"),
function(e1,e2) {
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
if(e1@type==1L)
return(e1 MOP as.gmatrix(e2, type=1L))
else
return(e1 MOP as.gmatrix(e2))
})
setMethod("MOP", signature(e1 = "matrix", e2 = "gmatrix"),
function(e1,e2) {
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
if(e2@type==1L)
return(as.gmatrix(e1, type=1L) MOP e2)
else
return(as.gmatrix(e1) MOP e2)
})
'
#Exchangeable binary operations
.strOpExchang = '
setMethod("MOP", signature(e1 = "gvector", e2 = "gvector"),
function(e1,e2) {
MEXPRS
if(length(e2)<1L)
return(e2)
else if(length(e1)<1L)
return(e1)
else if(length(e1)<length(e2)) {
small=e1
big=e2
} else {
small=e2
big=e1
}
if(length(small)==1L){
tryCatch(small <- .convert_to_appropriate_class(small,big@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
#small=as.double(small)
ret=new("gvector", length=length(big), type = MT2)
ret@ptr=.Call("gpu_scaler_MNAME", big@ptr, small, length(big), big@type)
} else if(length(big)==length(small)) {
ret=new("gvector",length=length(big), type=MT1)
ret@ptr=.Call("gpu_same_size_MNAME", big@ptr, small@ptr, small@length, big@type)
} else if((length(big) %% length(small)) ==0) {
ret=new("gvector",length=length(big), type=MT1)
ret@ptr=.Call("gpu_diff_size_MNAME", big@ptr, small@ptr, big@length, small@length, big@type)
} else
stop("longer object length is not a multiple of shorter object length", call. = FALSE)
return(ret)
}
)
.gvec.vec.MNAME =
function(e1,e2) {
if(length(e2)<1L)
return(e2)
else if(length(e1)<1L)
return(e1)
else if(length(e2)==1L){
MDIFEXPRS12
ret=new("gvector", length=length(e1), type=MT1)
#tryCatch(e2 <- .convert_to_appropriate_class(e2,e1@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
ret@ptr=.Call("gpu_scaler_MNAME", e1@ptr, e2, length(e1), e1@type)
} else {
#if(length(e1)<length(e2))
# stop("for elementwise operations, the larger vector/matrix must be on the gpu", call. = FALSE)
if(e1@type==1L)
tmp=as.gvector(e2, type=1L)
else
tmp=as.gvector(e2)
ret=e1 MOP tmp
}
return(ret)
}
setMethod("MOP", signature(e1 = "gvector", e2 = "numeric"), .gvec.vec.MNAME )
setMethod("MOP", signature(e1 = "gvector", e2 = "logical"), .gvec.vec.MNAME )
setMethod("MOP", signature(e1 = "numeric", e2 = "gvector"), function(e1,e2) .gvec.vec.MNAME(e2, e1))
setMethod("MOP", signature(e1 = "logical", e2 = "gvector"), function(e1,e2) .gvec.vec.MNAME(e2, e1))
setMethod("MOP", signature(e1 = "gmatrix", e2 = "gmatrix"),
function(e1,e2) {
#browser()
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
MEXPRS
myn=as.integer(prod(dim(e1)))
ret=new("gmatrix", nrow = e1@nrow, ncol = e1@ncol,rownames=e1@rownames,colnames=e1@colnames, type=MT1)
ret@ptr=.Call("gpu_same_size_MNAME", e1@ptr, e2@ptr, myn, e1@type)
#browser()
return(ret)
})
.gmat.vec.MNAME = function(e1,e2) {
checkDevice(e1@device)
tmp1=new("gvector",length=as.integer(prod(dim(e1))),ptr=e1@ptr, type=e1@type)
if(length(tmp1)==1) {
ret=tmp1 MOP e2
}else if(length(tmp1)< length(e2)) {
stop("Length of the matrix does not match for elementwise multiplication", call. = FALSE)
}else {
ret=e1
tmpret=tmp1 MOP e2
ret@type=tmpret@type
ret@ptr=tmpret@ptr
}
return(ret)
}
setMethod("MOP", signature(e1 = "gmatrix", e2 = "numeric"), .gmat.vec.MNAME)
setMethod("MOP", signature(e1 = "gmatrix", e2 = "logical"), .gmat.vec.MNAME)
setMethod("MOP", signature(e1 = "numeric", e2 = "gmatrix"), function(e1,e2) .gmat.vec.MNAME(e2,e1))
setMethod("MOP", signature(e1 = "logical", e2 = "gmatrix"), function(e1,e2) .gmat.vec.MNAME(e2,e1))
setMethod("MOP", signature(e1 = "gmatrix", e2 = "gvector"),
function(e1,e2) {
checkDevice(c(e1@device,e2@device))
tmp1=new("gvector",length=as.integer(prod(dim(e1))),ptr=e1@ptr, type=e1@type)
if(length(tmp1)==1) {
ret=tmp1 MOP e2
}else if(length(tmp1)< length(e2)) {
stop("Length of the matrix does not match for elementwise multiplication", call. = FALSE)
}else {
ret=e1
tmpret=tmp1 MOP e2
ret@type=tmpret@type
ret@ptr=tmpret@ptr
}
return(ret)
})
setMethod("MOP", signature(e1 = "gvector", e2 = "gmatrix"), function(e1,e2) return(e2 MOP e1))
setMethod("MOP", signature(e1 = "gmatrix", e2 = "matrix"),
function(e1,e2) {
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
if(e1@type==1L)
return(e1 MOP as.gmatrix(e2, type=1L))
else
return(e1 MOP as.gmatrix(e2))
})
setMethod("MOP", signature(e1 = "matrix", e2 = "gmatrix"),
function(e1,e2) {
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
if(e2@type==1L)
return(as.gmatrix(e1, type=1L) MOP e2)
else
return(as.gmatrix(e1) MOP e2)
})
setMethod("MOP", signature(e1 = "gvector", e2 = "matrix"),
function(e1,e2) {
if(e1@type==1L)
tmp=as.gmatrix(e2,type=1L)
else
tmp=as.gmatrix(e2)
return(e1 MOP tmp)
}
)
setMethod("MOP", signature(e1 = "matrix", e2 = "gvector"),
function(e1,e2) {
if(e2@type==1L)
tmp=as.gmatrix(e1,type=1L)
else
tmp=as.gmatrix(e1)
return(tmp MOP e2)
}
)
'
#binary operations in place
.strOpIp = '
setGeneric("MOP",
function(e1,e2)
standardGeneric("MOP")
)
setMethod("MOP", signature(e1 = "gvector", e2 = "gvector"),
function(e1,e2) {
if(max(length(e1),length(e2))<1L)
stop("Length of object must be greater than 1 for operator: MOP.", call. = FALSE)
else if(length(e1)<length(e2)) {
stop("Length of first vector must be longer than second vector for operator: MOP.", call. = FALSE)
}
checkDevice(c(e1@device,e2@device))
MCHECK
if(length(e2)==1L){
tryCatch(e2 <- .convert_to_appropriate_class(e2,e1@type), error=function(e) stop("Invalid value for operator: MOP.", call. = FALSE))
.Call("gpu_scaler_ip_MNAME", e1@ptr, e2, length(e1), e1@type)
} else if(length(e1)==length(e2)) {
if(e1@type!=e2@type)
stop("Type of both objects must be the same for operator: MOP.", call. = FALSE)
.Call("gpu_same_size_ip_MNAME", e1@ptr, e2@ptr, e2@length, e1@type)
} else if((length(e1) %% length(e2)) ==0) {
if(e1@type!=e2@type)
stop("Type of both objects must be the same for operator: MOP.", call. = FALSE)
.Call("gpu_diff_size_ip_MNAME", e1@ptr, e2@ptr, e1@length, e2@length, e1@type)
} else
stop("longer object length is not a multiple of shorter object length.", call. = FALSE)
return(e1)
}
)
setMethod("MOP", signature(e1 = "gvector", e2 = "numeric"), function(e1,e2) {
if(max(length(e1),length(e2))<1L)
stop("Length of object must be greater than 1 for operator: MOP.", call. = FALSE)
else if(length(e1)<length(e2)) {
stop("Length of first vector must be longer than second vector for operator: MOP.", call. = FALSE)
}
checkDevice(e1@device)
if(length(e2)==1L){
if(e1@type>1L & !any( c("integer", "logical") %in% class(e2) ) )
stop("Types do not match.")
else if(e1@type<=1L & !any( "numeric" %in% class(e2) ) )
stop("Types do not match.")
.Call("gpu_scaler_ip_MNAME", e1@ptr, e2, length(e1), e1@type)
} else {
if(e1@type==1L)
tmp=as.gvector(e2, type=1L)
else
tmp=as.gvector(e2)
ret=e1 MOP tmp
}
return(e1)
} )
setMethod("MOP", signature(e1 = "gvector", e2 = "logical"), getMethod("MOP", signature(e1 = "gvector", e2 = "numeric"))@.Data)
setMethod("MOP", signature(e1 = "gmatrix", e2 = "gmatrix"),
function(e1,e2) {
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
myn=as.integer(prod(dim(e1)))
MCHECK
if(e1@type!=e2@type)
stop("Type of both objects must be the same for operator: MOP.", call. = FALSE)
checkDevice(c(e1@device,e2@device))
.Call("gpu_same_size_ip_MNAME", e1@ptr, e2@ptr, myn, e1@type)
return(e1)
})
setMethod("MOP", signature(e1 = "gmatrix", e2 = "numeric"), function(e1,e2) {
checkDevice(e1@device)
tmp1=new("gvector",length=as.integer(prod(dim(e1))),ptr=e1@ptr, type=e1@type)
tmpret=tmp1 MOP e2
return(e1)
})
setMethod("MOP", signature(e1 = "gmatrix", e2 = "logical"), getMethod("MOP", signature(e1 = "gmatrix", e2 = "numeric"))@.Data)
setMethod("MOP", signature(e1 = "gmatrix", e2 = "gvector"),
function(e1,e2) {
checkDevice(c(e1@device,e2@device))
tmp1=new("gvector",length=as.integer(prod(dim(e1))),ptr=e1@ptr, type=e1@type)
tmpret=tmp1 MOP e2
return(e1)
})
setMethod("MOP", signature(e1 = "gvector", e2 = "gmatrix"),
function(e1,e2) {
checkDevice(c(e1@device,e2@device))
tmp2=new("gvector",length=as.integer(prod(dim(e2))),ptr=e2@ptr, type=e2@type)
tmpret1=e1 MOP tmp2 #note I am counting on this to error out if the dimensions dont match
tmpret1=new("gmatrix",nrow=as.integer(nrow(e2)), ncol=as.integer(ncol(e2)),ptr=e1@ptr, type=e1@type)
return(tmpret1)
})
setMethod("MOP", signature(e1 = "gmatrix", e2 = "matrix"),
function(e1,e2) {
if(any(dim(e1)!=dim(e2)))
stop("Dimensions of matrix do not match for elementwise operation.", call. = FALSE)
if(e1@type==1L)
return(e1 MOP as.gmatrix(e2, type=1L))
else
return(e1 MOP as.gmatrix(e2))
})
setMethod("MOP", signature(e1 = "gvector", e2 = "matrix"),
function(e1,e2) {
if(e1@type==1L)
tmp=as.gmatrix(e2,type=1L)
else
tmp=as.gmatrix(e2)
return(e1 MOP tmp)
}
)
'
.exprs_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_xy)))
.exprs_str = paste( deparse(.exprs_e1e2),collapse="\n")
.exprs_sf_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_sf_xy )))
.exprs_sf_str = paste( deparse(.exprs_sf_e1e2),collapse="\n")
.exprs_l_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_l_xy )))
.exprs_l_str = paste( deparse(.exprs_l_e1e2),collapse="\n")
.exprs_gc_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_gpu_cpu_xy )))
.exprs_gc12_str = paste( deparse(.exprs_gc_e1e2),collapse="\n")
.exprs_gc_e2e1=eval(substitute(substitute(e, list(x = bquote(e2), y=bquote(e1))), list(e = .exprs_gpu_cpu_xy )))
.exprs_gc21_str = paste( deparse(.exprs_gc_e2e1),collapse="\n")
.exprs_l_gc_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_l_gpu_cpu_xy )))
.exprs_l_gc12_str = paste( deparse(.exprs_l_gc_e1e2),collapse="\n")
.exprs_l_gc_e2e1=eval(substitute(substitute(e, list(x = bquote(e2), y=bquote(e1))), list(e = .exprs_l_gpu_cpu_xy )))
.exprs_l_gc21_str = paste( deparse(.exprs_l_gc_e2e1),collapse="\n")
.exprs_compare_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_compare_xy )))
.exprs_compare_str = paste( deparse(.exprs_compare_e1e2),collapse="\n")
.exprs_sf_gc_e1e2=eval(substitute(substitute(e, list(x = bquote(e1), y=bquote(e2))), list(e = .exprs_sf_gpu_cpu_xy )))
.exprs_sf_gc12_str = paste( deparse(.exprs_sf_gc_e1e2),collapse="\n")
.exprs_sf_gc_e2e1=eval(substitute(substitute(e, list(x = bquote(e2), y=bquote(e1))), list(e = .exprs_sf_gpu_cpu_xy )))
.exprs_sf_gc21_str = paste( deparse(.exprs_sf_gc_e2e1),collapse="\n")
.logical_check= "if(e1@type!=3L | e2@type!=3L) stop(\"Type must be\'logical\'\")"
setGeneric("%lgspadd%",
function(e1,e2)
standardGeneric("%lgspadd%")
)
.exOps=list(
c("lgspadd","%lgspadd%", .exprs_str, "e1@type", "big@type", .exprs_gc12_str,.exprs_gc21_str , "%lgspadd=%", "" ),
c("mult","*", .exprs_str, "e1@type", "big@type", .exprs_gc12_str,.exprs_gc21_str , "%*=%", "" ),
c("add" ,"+", .exprs_str, "e1@type", "big@type", .exprs_gc12_str,.exprs_gc21_str , "%+=%", "" ),
c("eq" ,"==", .exprs_compare_str, "3L", "3L", .exprs_gc12_str, .exprs_gc21_str , "none" , "" ),
c("ne" ,"!=", .exprs_compare_str, "3L", "3L" , .exprs_gc12_str, .exprs_gc21_str ,"none" , "" ),
c("and" ,"&", .exprs_l_str, "3L", "3L", .exprs_l_gc12_str, .exprs_l_gc21_str , "%&=%" ,.logical_check),
c("or" ,"|", .exprs_l_str, "3L", "3L", .exprs_l_gc12_str, .exprs_l_gc21_str , "%|=%",.logical_check )
)
lapply(.exOps, function(op) {
#browser()
exprStr = gsub("MDIFEXPRS21",op[7],
gsub("MDIFEXPRS12",op[6],
gsub("MT2",op[5],
gsub("MT1",op[4],
gsub("MEXPRS",op[3],
gsub("MNAME", op[1],
gsub("MOP",op[2],.strOpExchang)))))))
#cat(exprStr)
eval(parse(text=exprStr))
} )
lapply(.exOps[sapply(.exOps, function(x) return(x[8]!="none"))],
function(op) {
exprStr = gsub("MCHECK", op[9], gsub("MNAME", op[1], gsub("MOP",op[8],.strOpIp)))
eval(parse(text=exprStr))
} )
.nonExOps=list( c("sub","-",.exprs_str, "e1@type", "e2@type",.exprs_gc12_str,.exprs_gc21_str, "%-=%", "" ),
c("div","/", .exprs_sf_str, "e1@type", "e2@type",.exprs_sf_gc12_str,.exprs_sf_gc21_str, "%/=%" , ""),
c("pow","^", .exprs_sf_str, "e1@type", "e2@type",.exprs_sf_gc12_str,.exprs_sf_gc21_str, "%^=%" , ""),
c("mod","%%", .exprs_sf_str, "e1@type", "e2@type",.exprs_sf_gc12_str,.exprs_sf_gc21_str, "%mod=%", ""),
c("gt" ,">", .exprs_compare_str, "3L", "3L", .exprs_gc12_str,.exprs_gc21_str , "none" , ""),
c("lt" ,"<", .exprs_compare_str, "3L", "3L", .exprs_gc12_str,.exprs_gc21_str , "none" , ""),
c("gte" ,">=", .exprs_compare_str, "3L", "3L", .exprs_gc12_str,.exprs_gc21_str , "none", "" ),
c("lte" ,"<=", .exprs_compare_str, "3L", "3L", .exprs_gc12_str,.exprs_gc21_str ,"none" , "")
)
lapply(.nonExOps, function(op) {
exprStr = gsub("MDIFEXPRS21",op[7],
gsub("MDIFEXPRS12",op[6],
gsub("MT2",op[5],
gsub("MT1",op[4],
gsub("MEXPRS",op[3],
gsub("MNAME", op[1],
gsub("MOP",op[2],.strOpNonExchang)))))))
eval(parse(text=exprStr))
} )
lapply(.nonExOps[sapply(.nonExOps, function(x) return(x[8]!="none"))],
function(op) {
exprStr = gsub("MCHECK", op[9], gsub("MNAME", op[1], gsub("MOP",op[8],.strOpIp)))
eval(parse(text=exprStr))
} )
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.