I have a below R code. The code works fine in computing shortest path between minimal input. If my input is big the code throws error in my coding environment.
Is there a way to fine tune the below code to achieve faster implementation. Suggestions/Corrections are highly appreciable.
Note : I am trying to implement without external packages
input <- suppressWarnings(readLines(stdin(), n=7))
5 6
1 2 30
1 3 10
5 2 40
3 5 20
5 1 30
5 4 20
l1 <- unlist(strsplit(input[1]," "))
cities <- as.numeric(l1[1])
roads <- as.numeric(l1[2])
L <- matrix(100000000,cities,roads)
#L <- format(L,scientific = FALSE)
distance <- function(inp){
f <- unlist(strsplit(input[inp+1]," "))
m <- as.numeric(f[1])
n <- as.numeric(f[2])
L[m,n] <<- as.numeric(f[3])
}
invisible(mapply(distance,seq_along(1:roads )))
if(cities > dim(L)[2])
{
cat("NOT POSSIBLE")
} else {
n=length(L[,1])
v=1
dest=n
cost=L
dijkstra = function(n, v, cost, dest) {
dest = numeric(n)
flag = numeric(n)
prev = numeric(n)
dstv <- function(i){
prev[i] <<- -1
dest[i] <<- cost[v, i]
}
invisible(mapply(dstv,seq_along(1:n)))
count = 2
while (count <= n) {
min = 100000000
destw <- function(w) {
if (dest[w] < min && !flag[w]) {
min <<- dest[w]
u <<- w
}
}
invisible(mapply(destw,seq_along(1:n)))
flag[u] = 1
count = count + 1
destu <- function(w) {
if ((dest[u] + cost[u, w] < dest[w]) && !flag[w]) {
dest[w] <<- dest[u] + cost[u, w]
prev[w] <<- u
}
}
invisible(mapply(destu,seq_along(1:n)))
}
return(prev)
}
savepath = function(f, x) {
path = x
while (f[x] != -1) {
path = c(path, f[x])
x = f[x]
savepath(f, x)
}
path = c(path, 1)
return(path)
}
prev = dijkstra(n,v,cost,dest)
path = sort(savepath(prev,dest))
}
quicksort <- function(x, s, e) {
p = s
i = 0
j = 0
for (k in 1:length(x)) {
if (x[p] < x[k])
i = k
}
if (!i)
i = e
for (k in length(x):1) {
if (x[p] > x[k])
j = k
}
if (!j)
j = s
if (i < j) {
t = x[i]
x[i] = x[j]
x[j] = t
} else {
t = x[j]
x[j] = x[p]
x[p] = t
quicksort(x, s, j - 1)
quicksort(x, j + 1, e)
}
x
}
quick = function(x) {
quicksort(x, 1, length(x))
}
When I run this i R console with a Vector I getting Error
> x<-c(4,47,480,15,0,147,1,56862,12)
> quick(x)
Error: node stack overflow
Its working when testing each command in R console but complete code doesn't work perfectly is the logic correct or wrong with code
Modified the Code as
quicksort<-function(x){
if(length(x)<=1)return(x)
p<-x[1]
therest<-x[-1]
i<-therest[therest<p]
j<-therest[therest>p]
i<-quicksort(i)
j<-quicksort(j)
return(c(i,p,j))
}
Now it Works The Console is responded as
> x<-c(4,47,480,15,0,147,1,56862,12)
> quicksort(x)
[1] 0 1 4 12 15 47 147 480 56862
The Code in the Question is implementation from C++ but code there in the answer is direct R
My reproducible R example:
f = runif(1500,10,50)
p = matrix(0, nrow=1250, ncol=250)
count = rep(0, 1250)
for(i in 1:1250) {
ref=f[i]
for(j in 1:250) {
p[i,j] = f[i + j - 1] / ref-1
if(p[i,j] == "NaN") {
count[i] = count[i]
}
else if(p[i,j] > (0.026)) {
count[i] = (count[i] + 1)
ref = f[i + j - 1]
}
}
}
To be more precise, I have a set of 600 f-series and this code runs 200 times for each f-series. Currently I am doing the iterations in loops and most of the operations are element-wise. My random variables are f, the condition if(p[i,j] > (0.026)), and the number 0.026 in itself.
One can drastically reduce the run-time by vectorizing my code and using functions, specifically the apply family, but I am rusty with apply and looking for some advice to proceed in the right direction.
It is quite easy to put for loops in Rcpp. I just copy-pasted your code to Rcpp and haven't checked the validity. In case of discrepancy, let me know. fCpp returns the list of p and c.
cppFunction('List fCpp(NumericVector f) {
const int n=1250;
const int k=250;
NumericMatrix p(n, k);
NumericVector c(n);
for(int i = 0; i < n; i++) {
double ref=f[i];
for(int j = 0; j < k; j++) {
p(i,j) = f[i+j+1]/ref-1;
if(p(i,j) == NAN){
c[i]=c[i];
}
else if(p(i,j) > 0.026){
c[i] = c[i]+1;
ref = f[i+j+1];
}
}
}
return List::create(p, c);
}')
Benchmark
set.seed(1)
f = runif(1500,10,50)
f1 <- function(f){
p = matrix(0, nrow=1250, ncol=250)
count = rep(0, 1250)
for(i in 1:1250) {
ref=f[i]
for(j in 1:250) {
p[i,j] = f[i + j - 1] / ref-1
if(p[i,j] == "NaN") {
count[i] = count[i]
}
else if(p[i,j] > (0.026)) {
count[i] = (count[i] + 1)
ref = f[i + j - 1]
}
}
}
list(p, count)
}
microbenchmark::microbenchmark(fCpp(f), f1(f), times=10L, unit="relative")
Unit: relative
expr min lq mean median uq max neval
fCpp(f) 1.0000 1.0000 1.0000 1.0000 1.0000 1.0000 10
f1(f) 785.8484 753.7044 734.4243 764.5883 718.0868 644.9022 10
Values returned by fCpp(f) and f1(f) are essentially identical, apart from column 1 of p matrix returned by f1 is filled with 0s.
system.time(a <- f1(f))[3]
#elapsed
# 2.8
system.time(a1 <- fCpp(f))[3]
#elapsed
# 0
all.equal( a[[1]], a1[[1]])
#[1] "Mean relative difference: 0.7019406"
all.equal( a[[2]], a1[[2]])
#[1] TRUE
Here is an implementation using while, although it is taking much longer than nested for loops which is a bit counter intuitive.
f1 <- function() {
n <- 1500
d <- 250
f = runif(n,1,5)
f = embed(f, d)
f = f[-(n-d+1),]
count = rep(0, n-d)
for(i in 1:(n-d)) {
tem <- f[i,]/f[i,1] - 1
ti <- which(t[-d] > 0.026)[1]
while(ti < d & !is.na(ti)) {
ti.plus = ti+1
tem[ti.plus:d] = f[i, ti.plus:d] / tem[ti]
count[i] = count[i] + 1
ti <- ti + which(tem[ti.plus:d-1] > 0.026)[1]
}
f[i] = tem
}
list(f, count)
}
system.time(f1())
#elapsed
#6.365
#ajmartin, your logic was better and reduced the number of iterations I was attempting. Here is the improved version of your code in R:
f1 <- function() {
n <- 1500
d <- 250
f = runif(n,1,5)
count = rep(0, n-d)
for(i in 1:(n-d)) {
tem <- f[i:(i+d-1)] / f[i] - 1
ind = which(tem>0.026)[1]
while(length(which(tem>0.026))){
count[i] = count[i] + 1
tem[ind:d] = f[ind:d] / tem[ind] - 1
ind = ind - 1 + (which(tem[ind:d] > 0.026)[1])
}
}
list(f, count)
}
system.time(f1())[3]
# elapsed
# 0.09
Implementing this in Rcpp will further reduce system-time but I can't install Rtools as my current machine does not have admin rights. Meanwhile this helps.
I am having a very odd problem in R. The question was to make a function for global and semi global allignment. Appropriate algorithms were made which are able to "print out" the correct allignment. However "returning" the alginment seems to be a problem for the semi global algorithm.
Below are the functions for both alignments which both contain two functions: one computing the score matrix and the other outputs the alignment. As you can see, the output function for semi global was inspired by the global one but although it is able to print out values A and B, when returning A and B a value NULL is returned.
It came to my attention that when making defining A and B, they also contain a NULL part which seen by printing the structures of A and B at the end. This is also the case in the global alignment but does not seem to be a problem here.
Global Alignment Algorithm
########### GLOBAL ALLIGNMENT ALGORITHM ############
GA_score = function(v,w,score.gap=-3,score.match=8,score.mismatch=-5){
v = strsplit(v,split="")[[1]]
w = strsplit(w,split="")[[1]]
S = matrix(0,nrow=(length(v)+1),ncol = (length(w)+1) )
S[1,1] = 0
for(j in 2:dim(S)[2]){
S[1,j] = score.gap*(j-1)
}
for(i in 2:dim(S)[1]){
S[i,1] = score.gap*(i-1)
for(j in 2:dim(S)[2]){
if(v[i-1]==w[j-1]){diag = S[i-1,j-1] + score.match} else {diag = S[i-1,j-1] + score.mismatch}
down = S[i-1,j] + score.gap
right = S[i,j-1] + score.gap
S[i,j] = max(diag,down,right)
}
}
return(S)
}
GA_output = function(v,w,S,score.gap=-3,score.match=8,score.mismatch=-5){
v = strsplit(v,split="")[[1]]
w = strsplit(w,split="")[[1]]
A=c()
B=c()
GA_rec = function(A,B,S,i,j,v,w,score.gap,score.match,score.mismatch){
if (i==1 | j==1){
if(i>1){
for(i1 in seq(i-1,1,-1)){
A = c(v[i1],A)
B = c("-",B)
}
}
if(j>1){
for(j1 in seq(j-1,1,-1)){
A = c("-",A)
B = c(w[j1],B)
}
}
return(list(v=A,w=B))
}
if(v[i-1]==w[j-1] ){diag = score.match} else {diag=score.mismatch}
if (S[i,j] == (S[i-1,j-1] + diag)){
A.temp = c(v[i-1],A)
B.temp = c(w[j-1],B)
GA_rec(A.temp,B.temp,S,i-1,j-1,v,w,score.gap,score.match,score.mismatch)
}
else if (S[i,j] == (S[i-1,j] + score.gap)){
A.temp <- c(v[i-1],A)
B.temp <- c("-",B)
GA_rec(A.temp,B.temp,S,i-1,j,v,w,score.gap,score.match,score.mismatch)
}
else {
A.temp = c("-",A)
B.temp = c(w[j-1],B)
GA_rec(A.temp,B.temp,S,i,j-1,v,w,score.gap,score.match,score.mismatch)
}
}
return( GA_rec(A,B,S,length(v)+1,length(w)+1,v,w,score.gap,score.match,score.mismatch))
}
Semi-Global Alignment Algorithm
########### SEMI GLOBAL ALLIGNMENT ALGORITHM ############
SGA_score = function(sequence1,sequence2,score.gap=-1,score.match=1,score.mismatch=-1){
v=sequence2
w=sequence1
v = strsplit(v,split="")[[1]]
w = strsplit(w,split="")[[1]]
S = matrix(0,nrow=length(v)+1,ncol=length(w)+1)
for(i in 1:(length(w)+1)){
for( j in 1:(length(v)+1)){
if (i==1|j==1){S[i,j]=0}
else{
if((i==length(w)+1) | (j==length(v)+1)){
from.top = S[i,j-1]
from.left = S[i-1,j]
}
else{
from.top = max(S[i,j-1]+score.gap) # Max is artifact from max(0,... )
from.left = max(S[i-1,j]+score.gap)
}
if(w[i-1] == v[j-1]){
from.diag = S[i-1,j-1]+score.match
}
else{
from.diag = S[i-1,j-1]+score.mismatch
}
S[i,j] = max(from.top,from.left,from.diag)
}
}
}
return(S)
}
SGA_output = function(v,w,S,score.gap=-1,score.match=1,score.mismatch=-1){
v = strsplit(v,split="")[[1]]
w = strsplit(w,split="")[[1]]
A=c()
B=c()
print(str(A))
print(str(B))
SGA_rec = function(A,B,S,i,j,v,w,score.gap,score.match,score.mismatch){
if (i==1 | j==1){
if(i>1){
for(i1 in seq(i-1,1,-1)){
A = c(v[i1],A)
B = c("-",B)
}
}
if(j>1){
for(j1 in seq(j-1,1,-1)){
A = c("-",A)
B = c(w[j1],B)
}
}
print(A)
print(B)
out = list(v=A,w=B)
#print(out)
print(str(A))
print(str(B))
print(str(out))
return(out)
}
if(v[i-1]==w[j-1] ){diag = score.match} else {diag=score.mismatch}
if (S[i,j] == (S[i-1,j-1] + diag)){
A.temp = c(v[i-1],A)
B.temp = c(w[j-1],B)
SGA_rec(A.temp,B.temp,S,i-1,j-1,v,w,score.gap,score.match,score.mismatch)
}
#####
if ( j==length(w)+1) { # Are we in last row?
score.temp = score.gap
score.gap=0
}
else{score.temp=score.gap}
if(S[i,j] == (S[i-1,j] + score.gap)){
A.temp <- c(v[i-1],A)
B.temp <- c("-",B)
score.gap = score.temp
SGA_rec(A.temp,B.temp,S,i-1,j,v,w,score.gap,score.match,score.mismatch)
}
score.gap=score.temp
####
if(i==length(v)+1){
score.temp=score.gap
score.gap=0
}
else{score.temp=score.gap}
if(S[i,j] == (S[i,j-1] + score.gap)){
A.temp = c("-",A)
B.temp = c(w[j-1],B)
score.gap=score.temp
SGA_rec(A.temp,B.temp,S,i,j-1,v,w,score.gap,score.match,score.mismatch)
}
}
return(SGA_rec(A,B,S,length(v)+1,length(w)+1,v,w,score.gap,score.match,score.mismatch))
}
S1 = SGA_score("ACGTCAT","TCATGCA")
S1
align = SGA_output("ACGTCAT","TCATGCA",S1)
align
I am surpised that the global alignment works but the semi global one doesn't, even tough they both have this NULL part (can someone maybe explain what this is? Has it something to do with internal objects in a function?) and the semi global knows what A and B is.
Any help is greatly appreciated!
SGA_rec seems to be missing a return value. You need an else {return(<something>)) after the last if.
Illustration:
fun <- function() if (FALSE) 1
x <- fun()
x
#NULL
Read help("NULL") to learn what it means.