I have a vector (length 8) and change one element randomly in the vector each time the for loop run. I want to check my new generated vector with a fixed vector (Destination) and save the valid case in a counting variable (Time_to_Destination). However, when I use identical() function, there was no saved recorded in Time_to_Destination. Is there anything wrong with my code?
I tried identical(), all.equal()
If I commented out if(identical()), the variable Time_to_Destination was counted
rm(list = ls())
library(igraph)
#Plot the graph
graph_MC <- graph(edge = c(1,2,1,3,2,3,2,4,3,4), n = 4, directed = F)
plot(graph_MC)
#Initial position
X_0 <- c(1,2,3,1)
Destination <- c(3,1,2,3)
X <- X_0
Time_to_destination <- 0
#I would like to see how many time I arrive to the Destination, which have a valid set of color
for(i in 1:10000){
#Generate a random node
a <- as.integer(runif(1,1,4))
#Generate a random color of the node
q <- as.integer(runif(1,1,3))
test_vector <- X
test_vector[a] = q
#Check if the new set of color is valid
if (a == 1) {
if ((q != test_vector[2]) & (q != test_vector[3])) {
X = test_vector
if (identical(X, Destination)){
Time_to_destination = Time_to_destination + 1
}
}
}
if (a == 2) {
if ((q != test_vector[1]) & (q != test_vector[3]) & (q != test_vector[4])) {
X = test_vector
if (identical(X, Destination)){
Time_to_destination = Time_to_destination + 1
}
}
}
if (a == 3) {
if ((q != test_vector[1]) & (q != test_vector[2]) & (q != test_vector[4])) {
X = test_vector
if (identical(X, Destination)){
Time_to_destination = Time_to_destination + 1
}
}
}
if (a == 4) {
if ((q != test_vector[3]) & (q != test_vector[2])) {
X = test_vector
if (identical(X, Destination)){
Time_to_destination = Time_to_destination + 1
}
}
}
}
Time_to_destination
Related
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))
}
I am trying to build a function that takes 2 arguments and uses those 2 arguments inside a replicate funtion
SPM <- function(bilhetes, N){
total_bilhetes <- 12012000
total_bilhetes_premios <- 3526450
premios <- c(0,5,10,15,20,25,50,100,300,1000,27000,108000,288000)
premios_bilhetes <- c(8485550,1895000,496800*2,88800*3,55200*4,16800*4,7920*6,5030*6,950*5,950,30,10,10)
probs <- premios_bilhetes/total_bilhetes
vector_ganhos <- c()
ganho <- 0
replicate(N, function(bilhetes) {
total_bilhetes1 <- total_bilhetes
premios_bilhetes1 <- premios_bilhetes
probs1 <- probs
for (i in c(1:bilhetes)) {
A <- sample(x = premios,replace = T,size = 1, prob = probs1)
ganho <- ganho - 5 + A
if (A == 0) {
premios_bilhetes1[1] <- premios_bilhetes1[1] - 1
} else if (A == 5) {
premios_bilhetes1[2] <- premios_bilhetes1[2] - 1
} else if (A == 10) {
premios_bilhetes1[3] <- premios_bilhetes1[3] - 1
} else if (A == 15) {
premios_bilhetes1[4] <- premios_bilhetes1[4] - 1
} else if (A == 20) {
premios_bilhetes1[5] <- premios_bilhetes1[5] - 1
} else if (A == 25) {
premios_bilhetes1[6] <- premios_bilhetes1[6] - 1
} else if (A == 50) {
premios_bilhetes1[7] <- premios_bilhetes1[7] - 1
} else if (A == 100) {
premios_bilhetes1[8] <- premios_bilhetes1[8] - 1
} else if (A == 300) {
premios_bilhetes1[9] <- premios_bilhetes1[9] - 1
} else if (A == 1000) {
premios_bilhetes1[10] <- premios_bilhetes1[10] - 1
} else if (A == 27000) {
premios_bilhetes1[11] <- premios_bilhetes1[11] - 1
} else if (A == 108000) {
premios_bilhetes1[12] <- premios_bilhetes1[12] - 1
} else {
premios_bilhetes1[13] <- premios_bilhetes1[13] - 1
}
total_bilhetes1 <- total_bilhetes1 - 1
probs1 <- premios_bilhetes1/(total_bilhetes1)
}
vector_ganhos[length(vector_ganhos)+1] = ganho
})
return(vector_ganhos)
}
when I try to run it, e.g., SPM(bilhetes = 5, N = 100) I get:
Error in SPM(bilhetes = 5, N = 100) : could not find function "SPM"
I looked in another question and someone mentioned "sourcing" the function. I tried it, and this was the output:
> source("SPM")
Error in file(filename, "r", encoding = encoding) :
cannot open the connection
In addition: Warning message:
In file(filename, "r", encoding = encoding) :
I'm rather new to R, so I'm probably making a dumb mistake.
Can someone help?
I'm trying to create a mergeSort algorithm in R. While I think I have the method down, the first time I create the vector e, I end up with a vector of length 4 instead of 2. This causes the error below:
"Error in if (a[2] < a[1]) { : missing value where TRUE/FALSE needed"
For some reason, R is adding an extra 2 elements to what should be a two-element vector. If anyone has an explanation for this, that would be wonderful. (Please limit advice to solving this error. I want to figure out how to do the rest on my own.)
Code:
addLeftOver <- function(buffer, array, index) {
j <- length(buffer)
for(i in array[index:length(array)]) {
buffer[j] = i
print(i)
j <- j+1
}
return(buffer)
}
mergeSort <- function(a) {
len <- length(a)
print(a)
print(len)
browser()
if(len<=2) { #base case
if(len==1) {
return(a)
}
if(a[2]<a[1]) {
return(c(a[2],a[1]))
}
return(a)
}
print(len/2)
b <- mergeSort(a[1:(len/2)]) #recursion
e <- mergeSort(a[(len/2)+1:len]) #recursion
indexB <- 1
indexE <- 1
buffer
for(i in 1:len) {
if(e[indexC]<b[indexB]) {
buffer[index] <- e[indexE]
index <- index + 1
indexE <- indexE + 1
} else {
buffer[index] <- b[indexB]
index <- index + 1
indexB <- indexB + 1
}
if(indexB==len/2) {
buffer = addLeftover(buffer, e, indexE)
return(buffer)
}
if(indexE==len/2) {
buffer = addLeftover(buffer, b, indexB)
return(buffer)
}
}
}
sumArray <- c(6,4,2,7,8,1,3,5)
print(mergeSort(sumArray))
The addLeftOver() function's purpose is to copy the remnants of one of the two vectors (b or e) to the buffer when the end of the other has been reached.
Main error can be fixed with parenthesis. e <- mergeSort(a[(len/2)+1:len]) should be e <- mergeSort(a[((len/2)+1:len])
That and some other bugs were fixed.
Working code:
addLeftOver <- function(buffer, array, index)
{
j <- length(buffer)+1
for(i in array[index:length(array)]) {
buffer[j] = i
j <- j+1
}
return(buffer)
}
mergeSort <- function(a)
{
len <- length(a)
if(len<=2)
{
if(len==1)
{
return(a)
}
if(a[2]<a[1])
{
return(c(a[2],a[1]))
}
return(a)
}
half <- as.integer(len/2)
b <- mergeSort(a[1:(half)])
e <- mergeSort(a[((half)+1):len])
index <- 1
indexB <- 1
indexE <- 1
buffer <- c(0)
for(i in 1:len)
{
if(e[indexE]<b[indexB])
{
buffer[index] <- e[indexE]
index <- index + 1
indexE <- indexE + 1
}
else
{
buffer[index] <- b[indexB]
index <- index + 1
indexB <- indexB + 1
}
if(indexB==(length(b))+1)
{
buffer = addLeftover(buffer, e, indexE)
return(buffer)
}
if(indexE==(length(e))+1)
{
buffer = addLeftover(buffer, b, indexB)
return(buffer)
}
}
}
I was asked to implement function that calculates n-dimensional matrix determinant using Laplace expansion. This involves recursion. I developed this:
minor<-function(A,i,j) {
return(A[c(1:(i-1),(i+1):dim(A)[1]),c(1:(j-1),(j+1):dim(A)[2])])
}
determinantRec<-function(X,k) {
if (dim(X)[1] == 1 && dim(X)[2] == 1) return(X[1][1])
else {
s = 0
for (i in 1:dim(X)[2]) {
s = s + X[k][i]*(-1)^(k+i)*determinantRec(minor(X,k,i),k)
}
return(s)
}
}
where k in determinantRec(X,k) function indicates which row I want to use Laplace expansion along of.
My problem is when I run determinantRec(matrix(c(1,2,3,4),nrow = 2,ncol = 2),1) this error appears:
C stack usage 7970628 is too close to the limit
What is wrong with my code?
#julia, there is one simple type in your code. Just remove the '*' at the end of the definition of 's'. And don't indent the recursion.
determinantRek<-function(X,k) {
if (dim(X)[1] == 1 && dim(X)[2] == 1)
return(X[1,1])
if (dim(X)[1] == 2 && dim(X)[2] == 2)
return(X[1,1]*X[2,2]-X[1,2]*X[2,1])
else
s = 0
for (i in 1:dim(X)[2]) {
s = s + X[k,i]*(-1)^(k+i)
determinantRek(X[-k,-i],k)
}
return(s)
}
I did this way and works just fine, although it is super slow, compared to the det function in base R
laplace_expansion <- function(mat){
det1 <- function(mat){
mat[1]*mat[4]-mat[2]*mat[3]
}
determinant <- 0
for(j in 1:ncol(mat)){
mat1 <- mat[-1,-j]
if(nrow(mat1) == 2){
determinant <- determinant+mat[1,j]*(-1)^(1+j)*det1(mat1)
}else{
val <- mat[1,j]*(-1)^(1+j)
if(val != 0){
determinant <- determinant+val*laplace_expansion(mat1)
}
}
}
return(determinant)
}
This is my approach, I think it's cleaner.
deter <- function(X) {
stopifnot(is.matrix(X))
stopifnot(identical(ncol(X), nrow(X)))
if (all(dim(X) == c(1, 1))) return(as.numeric(X))
i <- 1:nrow(X)
out <- purrr::map_dbl(i, function(i){
X[i, 1] * (-1)^(i + 1) * deter(X[-i, -1, drop = FALSE])
})
return(sum(out))
}
Thank you #ArtemSokolov and #MrFlick for pointing the problem cause, it was it. I also discovered that this code does not calculate properly the determinant of 2x2 matrix. After all it looks like that:
determinantRek<-function(X,k) {
if (dim(X)[1] == 1 && dim(X)[2] == 1)
return(X[1,1])
if (dim(X)[1] == 2 && dim(X)[2] == 2)
return(X[1,1]*X[2,2]-X[1,2]*X[2,1])
else
s = 0
for (i in 1:dim(X)[2]) {
s = s + X[k,i]*(-1)^(k+i)*
determinantRek(X[-k,-i],k)
}
return(s)
}
Debuging with browser() was also helpful :)
Using:
mean (x, trim=0.05)
Removes 2.5% from each side of the distribution, which is fine for symmetrical two-tailed data. But if I have one tailed or highly asymmetric data I would like to be able to remove just one side of the distribution. Is there a function for this or do I have write myself a new one? If so, how?
Just create a modified mean.default. First look at mean.default:
mean.default
Then modify it to accept a new argument:
mean.default <-
function (x, trim = 0, na.rm = FALSE, ..., side="both")
{
if (!is.numeric(x) && !is.complex(x) && !is.logical(x)) {
warning("argument is not numeric or logical: returning NA")
return(NA_real_)
}
if (na.rm)
x <- x[!is.na(x)]
if (!is.numeric(trim) || length(trim) != 1L)
stop("'trim' must be numeric of length one")
n <- length(x)
if (trim > 0 && n) {
if (is.complex(x))
stop("trimmed means are not defined for complex data")
if (any(is.na(x)))
return(NA_real_)
if (trim >= 0.5)
return(stats::median(x, na.rm = FALSE))
lo <- if( side=="both" || side=="right" ){ floor(n * trim) + 1 }else{1}
hi <- if( side=="both" || side=="left" ){ n + 1 - (floor(n * trim) + 1 ) }else{ n}
x <- sort.int(x, partial = unique(c(lo, hi)))[lo:hi]
cat(c(length(x), lo , hi) )
}
.Internal(mean(x))
}
I don't know of a function. Something like the following would trim off the upper tail of the distribution before taking the mean.
upper.trim.mean <- function(x,trim) {
x <- sort(x)
mean(x[1:floor(length(x)*(1-trim))])
}
This should account for either side, or both sides for trimming.
trim.side.mean <- function(x, trim, type="both"){
if (type == "both") {
mean(x,trim)}
else if (type == "right") {
x <- sort(x)
mean(x[1:floor(length(x)*(1-trim))])}
else if (type == "left"){
x <- sort(x)
mean(x[max(1,floor(length(x)*trim)):length(x)])}}
one.sided.trim.mean <- function(x, trim, upper=T) {
if(upper) trim = 1-trim
data <- mean(x[x<quantile(x, trim)])
}
I found that all the answers posted do not match when checked manually. So I created one of my own. Its long but simple enough to understand
get_trim <- function(x,trim,type)
{
x <- sort(x)
ans<-0
if (type=="both")
{
for (i in (trim+1):(length(x)-trim))
{
ans=ans+x[i];
}
print(ans/(length(x)-(2*trim)))
}
else if(type=="left")
{
for (i in (trim+1):(length(x)))
{
ans=ans+x[i];
}
print(ans/(length(x)-trim))
}
else if (type=="right")
{
for (i in 1:(length(x)-trim))
{
ans=ans+x[i];
}
print(ans/(length(x)-trim))
}
}