Say we have some vector:
someVector = c(1, 3, 4, 6, 3, 9, 2, -5, -2)
I want to get a vector that has the locations in someVector of all the odd elements
so in this case it would look like...
resultVector = c(1, 2, 5, 6, 8)
> which(someVector %% 2 == 1)
[1] 1 2 5 6 8
library(schoolmath)
which(is.odd(someVector))
[1] 1 2 5 6 8
just for fun here the code of the is.odd function :
function (x)
{
start <- 1
end <- length(x) + 1
while (start < end) {
y <- x[start]
if (y == 0) {
cat("Please enter a number > 0")
end
}
test1 <- y/2
test2 <- floor(test1)
if (test1 != test2) {
if (start == 1) {
result = TRUE
}
else {
result <- c(result, TRUE)
}
}
else {
if (start == 1) {
result = FALSE
}
else {
result <- c(result, FALSE)
}
}
start <- start + 1
}
return(result)
}
Definitely , Don't use this function !
Related
I was hoping to create a function with the if statements in the following code:
data <- data.frame(
id = c(1, 5, 6, 11, 15, 21),
intervention = c(2, 2, 2, 1, 1, 1),
death = c(0, 1, 0, 1, 0, 0)
)
test <- c()
for (i in data$id[which(data$intervention == 1)]) {
print(paste0("id = ", i, ": "))
for (j in data$id[which(data$intervention == 2)]) {
if (data$death[data$id == i] < data$death[data$id == j]) {
test <- c(test, -1)
} else if (data$death[data$id == i] > data$death[data$id == j]) {
test <- c(test, 1)
} else if (data$death[data$id == i] == data$death[data$id == j]) {
test <- c(test, 0)
}
}
print(test)
test <- c()
}
I had tried to do it as follows, however the code is not writing the result to the vector. However if I replaced the return with print, it would print it out. Would anyone have any suggestions on what I might be doing wrong? Many thanks!
first <- function () {
if(data$death[data$id == i]<data$death[data$id ==j]){
return (test <- c(test,-1))}
else if(data$death[data$id == i]>data$death[data$id == j]){
return (test <- c(test,1))}
else if(data$death[data$id == i]==data$death[data$id == j]){
return (test <- c(test,0))}
}
for (i in data$id[which(data$intervention == 1)]){
for (j in data$id[which(data$intervention == 2)]){
first()
}
test
}
The following function returns a list of the wanted vectors.
first <- function(data, interv1 = 1, interv2 = 2) {
inx <- which(data[["intervention"]] == interv1)
jnx <- which(data[["intervention"]] == interv2)
out <- lapply(inx, \(i) {
sapply(jnx, \(j) sign(data[["death"]][i] - data[["death"]][j]))
})
setNames(out, data[["id"]][inx])
}
first(data)
#> $`11`
#> [1] 1 0 1
#>
#> $`15`
#> [1] 0 -1 0
#>
#> $`21`
#> [1] 0 -1 0
Created on 2022-11-22 with reprex v2.0.2
You can then access the return values as
test <- first(data)
# any of the following extracts the 1st vector
test[['11']]
#> [1] 1 0 1
# notice the backticks
test$`11`
#> [1] 1 0 1
Created on 2022-11-22 with reprex v2.0.2
Can someone tell me what is wrong with this function in R? The functions can work on a single input, but when I use a vector I get an error:
input_check3 <- function(x){
if (is.finite(x)) {
if (x %% 2 == 0){
print(TRUE)
} else {
print(FALSE)
}
} else {
NA
}
}
data_for_e2 <- c(1, 2, 4, 5, 3)
input_check3(data_for_e2)
#> [1] FALSE
#> Warning messages:
#> 1: In if (is.finite(x)) { : The length of the condition is greater than one, so only its first element can be used
#> 2: In if (x%%2 == 0) { : The length of the condition is greater than one, so only its first element can be used
You could use ifelse, which is a vectorized function:
input_check3 <- function(x){
ifelse(is.finite(x),
x %% 2 == 0, # equiv to ifelse(x %% 2 == 0, TRUE, FALSE), thanks Martin Gal!
NA)
}
Result
[1] FALSE TRUE TRUE FALSE FALSE
In R I would like to produce two different elements, e.g. a and b
until one of these occurs x times (this would be a win for that element)
then based on the result in the first step repeat the procedure until one of the elements has y such wins
For instance, using x=3
result=integer(0)
while(TRUE){
result = c(result, sample(c("a","b"), 1))
if(
length(grep("a",result,value=T))>=3|length(grep("b",result,value=T))>=3)
break
}
table(result)
would lead to
result
a b
3 2
and the win for a. I would like to repeat the procedure so it stops when a or b reaches say three such wins.
Grateful for all the suggestions!
Is this the simulation procedure you need?
simu_proc <- function(agents, x, y) {
wins <- character(0L)
repeat {
res <- character(0L)
repeat {
res <- c(res, sample(agents, 1L))
test_x <- table(res)
won <- test_x >= x
if (any(won)) {
wins <- c(wins, names(test_x)[won])
break
}
}
test_y <- table(wins)
won <- test_y >= y
if (any(won)) {
return(names(test_y)[won])
}
}
}
Some trials as follows:
> simu_proc(c("a", "b"), 3, 3)
[1] "b"
> simu_proc(c("a", "b"), 3, 3)
[1] "b"
> simu_proc(c("a", "b"), 3, 3)
[1] "b"
> simu_proc(c("a", "b"), 3, 3)
[1] "b"
> simu_proc(c("a", "b"), 3, 3)
[1] "a"
> simu_proc(c("a", "b"), 3, 3)
[1] "b"
> simu_proc(c("a", "b"), 3, 3)
[1] "a"
> simu_proc(c("a", "b"), 3, 3)
[1] "b"
I did some further investigations out of curiosity. If you are ok with recursions and/or some functional programming stuff, I think you can generalise this procedure to allow arbitrary numbers of agents (i.e. the elements you try to produce) and cutoffs (i.e. the conditions at different levels). See the code below:
play <- function(game, cutoff) {
results <- character(0L)
repeat {
results <- c(results, game())
scoreboard <- table(results)
won <- scoreboard >= cutoff
if (any(won)) {
return(names(scoreboard)[won])
}
}
}
play_proc <- function(agents, cutoffs) {
recur_play <- function(agents, cutoffs) {
if (length(cutoffs) < 2L) {
return(function() play(function() sample(agents, 1L), cutoffs))
}
function() play(recur_play(agents, cutoffs[-1L]), cutoffs[[1L]])
}
recur_play(agents, rev(cutoffs))()
}
Some trials:
> play_proc(c("a", "b", "c"), c(1, 2, 3, 4))
[1] "b"
> play_proc(c("a", "b", "c"), c(1, 2, 3, 4))
[1] "b"
> play_proc(c("a", "b"), c(3, 3))
[1] "a"
> play_proc(c("a", "b"), c(3, 3))
[1] "b"
Return the result for each step:
simu_proc <- function(agents, x, y) {
wins <- character(0L)
process <- list()
repeat {
res <- character(0L)
repeat {
res <- c(res, sample(agents, 1L))
test_x <- table(res)
won <- test_x >= x
if (any(won)) {
wins <- c(wins, names(test_x)[won])
process <- c(process, list(test_x))
break
}
}
test_y <- table(wins)
won <- test_y >= y
if (any(won)) {
return(c(names(test_y)[won], process, list(test_y)))
}
}
}
Test:
> simu_proc(c("a", "b"), 3, 3)
[[1]]
[1] "b"
[[2]]
res
a b
1 3
[[3]]
res
b
3
[[4]]
res
a b
1 3
[[5]]
wins
b
3
Update
simu_proc <- function(agents, x, y) {
wins <- character(0L)
process <- list()
repeat {
res <- character(0L)
repeat {
res <- c(res, sample(agents, 1L))
test_x <- table(res)
end <- any(test_x >= x) && (length(test_x) < 2L || abs(diff(test_x)) > 1L)
if (end) {
wins <- c(wins, names(test_x)[[which.max(test_x)]])
process <- c(process, list(test_x))
break
}
}
test_y <- table(wins)
end <- any(test_y >= y)
if (end) {
return(c(names(test_y)[[which.max(test_y)]], process, list(test_y)))
}
}
}
I think you have got the logic right. The loop just needs to be rewritten. Here's my take :
cutoff=10
set.seed(1024)
result<- integer()
while(max(table(result)) <cutoff){
result <- c(result, sample(c("a","b"), 1 ,prob = c(0.5,0.5)) )
}
table(result)
I am trying to build a matrix in R with 1s and 0s but the matrix should be generated only if the row sums and column sums condition are satisfied.
for ex:
1 0 1 1
0 1 1 0
1 1 1 1
1 0 1 0
I want to create a matrix with rowsums = c(3, 2, 4, 2) and colsums = c(3, 2, 4, 2).
There probably is a more elegant solution, but this works, doesn't take long to run, and doesn't require any package:
repeat {
repeat {
repeat {
repeat {
repeat {
x <- sample(0:1, 4, replace = T)
if(sum(x) == 3) {
break
}
}
repeat {
y <- sample(0:1, 4, replace = T)
if(sum(y) == 2) {
break
}
}
repeat {
z <- sample(0:1, 4, replace = T)
if(sum(z) == 4) {
break
}
}
repeat {
u <- sample(0:1, 4, replace = T)
if(sum(u) == 2) {
break
}
}
if(sum(x[1], y[1], z[1], u[1]) == 3) {
break
}
}
if(sum(x[2], y[2], z[2], u[2]) == 2) {
break
}
}
if(sum(x[3], y[3], z[3], u[3]) == 4) {
break
}
}
if(sum(x[4], y[4], z[4], u[4]) == 2) {
print(matrix(c(x, y, z, u), 4, 4, byrow = T))
break
}
}
Approaching this as a lp problem which phiver also alludes to in the link provided by Stephane Laurent in the comment:
library(lpSolve)
library(data.table)
nr <- 4
nc <- 4
ne <- nr * nr
v <- vector("integer", ne)
colvec <- replace(v, seq_along(v) <= nr, 1L)
rowvec <- replace(v, seq_along(v) %% nc == 1, 1L)
colconstr <- c(3, 2, 4, 2)
rowconstr <- c(3, 2, 4, 2)
const.mat <- do.call(rbind, c(
data.table::shift(colvec, seq(0L, ne - nc, nc), fill=0L),
data.table::shift(rowvec, 0L:(nr-1L), fill=0L)))
const.rhs <- c(colconstr, rowconstr)
s <- lpSolve::lp("min", runif(ne), const.mat,
rep("==", nrow(const.mat)), const.rhs, all.bin=TRUE)$solution
matrix(s, nrow=nr)
sample output:
[,1] [,2] [,3] [,4]
[1,] 1 0 1 1
[2,] 1 0 1 0
[3,] 1 1 1 1
[4,] 0 1 1 0
I'd like to apply a function to each row in R that "scores" each value of a row, x. It seems like i'd use the 'apply' function in R to do this, but not sure how to do it. I'd like to input a dataframe with a column of values of integers and have a vector output with the score. The code I have now is as follows:
ScoreFn <- function(x){
score <- 0
if(x<1) {
score <- 0
} else if(x==1) {
score <- 5
} else if(x==2) {
score <- 10
} else if(x==3) {
score <- 20
} else if(x >= 4 && x <= 10) {
score <- 30
} else if(x >= 11 && x <= 20) {
score <- 40
} else if(x >= 21) {
score <- 50
}
return(score)
}
apply(df$x, 1, ScoreFn())
Also, I am getting this message. Not sure the best way to do this function.
1: In if (x < 1) { :
the condition has length > 1 and only the first element will be used
2: In if (x == 1) { :
the condition has length > 1 and only the first element will be used
3: In if (x == 2) { :
the condition has length > 1 and only the first element will be used
4: In if (x == 3) { :
the condition has length > 1 and only the first element will be used
...
You can make a vectorised function, using cut, so you don't have to use apply at all:
scorefun <- function(x){
as.numeric(as.character(cut(x, breaks = c(0, 1, 2, 3, 4, 11, 21, Inf),
labels = c(0,5,10,20,30,40, 50), right = FALSE)))
}
df <- data.frame(x = 0:10)
scorefun(df$x)
[1] 0 5 10 20 30 30 30 30 30 30 30
This also has the bonus that cut does the heavy lifting of typing the if/elses, as well as being about 10x faster than the non-vectorised version.
It works by cutting the given vector (in this case df$x) into factors by slices, given by breaks. We then label them with your scores, and then get out the numbers again by using as.character and as.numeric.
If your input is just a column of data.frame, you don't need to use apply. You can use sapply instead.
ScoreFn <- function(x){
score <- 0
if(x<1) {
score <- 0
} else if(x==1) {
score <- 5
} else if(x==2) {
score <- 10
} else if(x==3) {
score <- 20
} else if(x >= 4 && x <= 10) {
score <- 30
} else if(x >= 11 && x <= 20) {
score <- 40
} else if(x >= 21) {
score <- 50
}
return(score)
}
# Return a list of scores
sapply(df$x, ScoreFn)