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 was wondering how to set two or more results from a true ifelse statement.
For example, I would like to set y = 2 and t=3 if x=2. I was thinking the code would look something like this:
x=2
ifelse(x==2,y=2 & t=3, y=0 & t=0)
however this does not work.
You may use if-statement block:
if(x == 2){
y = 2
t = 3
}
else {
y = 0
t = 0
}
Alternatively, you can try:
ifelse(x == 2, {y = 2; t = 3;}, {y = 0; t = 0;})
As answered here: If statement with multiple actions in R, for the block IF statement, the ELSE should be on the same line as the previous curly bracket.
So, instead of
if(x ==2) {
y = 2
t = 3
}
else {
y = 0
t = 0
}
the format should be (the ELSE is on the same line as the previous curly bracket)
if(x ==2) {
y = 2
t = 3
} else {
y = 0
t = 0
}
I am trying to write a very simple function wrapper in R, that will accept f and return g where g returns zero whenever the first argument is negative. I have the following code
wrapper <- function(f) {
function(x, ...) {
if( x <= 0 ) { 0 }
else { f(x, ...) }
}
}
Thge wrapper works as expected, but is there are way to maintain the function signature
> wdnorm <- wrapper(dnorm)
> args(dnorm)
function (x, mean = 0, sd = 1, log = FALSE)
NULL
> args(wdnorm)
function (x, ...)
NULL
I would like to do something like this (but obviously it doesn't work)
args(g) <- args(f)
is this possible in R?
Here is what you want. Tho, do you really need this?
wrapper <- function(f) {
f2 = function(x) {
if (x <= 0) { 0 }
else { do.call(f, as.list( match.call())[-1]) }
}
formals(f2) = formals(f)
f2
}
wdnorm <- wrapper(dnorm)
args(dnorm)
args(wdnorm)
wdnorm(-5)
wdnorm(5)
output
> args(dnorm)
function (x, mean = 0, sd = 1, log = FALSE)
NULL
> args(wdnorm)
function (x, mean = 0, sd = 1, log = FALSE)
NULL
> wdnorm(-5)
[1] 0
> wdnorm(5)
[1] 1.48672e-06
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.
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))
}
}