I am trying to make a table from a while loop. Basically, I want to make a while loop where the value of r increases by 1 and repeats this until the inequality is met. But in addition to that, I want to combine these values into a table with three columns: the value of r, the value of w, and the value of rhs (rounded to 3 decimal places).
```{r}
al = 0.10; n = 30; a = 3; b = 5; r = 2; int = 8; h = (int/2); msE = 19.19
table = function(MSE, V, H, alpha = al, r = 2){
rhs = h^2*r/((V-1)*MSE)
w = qf(alpha, V-1, V*(r-1), lower.tail = FALSE)
g = data.frame(r, round(w, 3), round(rhs, 3))
while(w > rhs){
r = r+1
rhs = h^2*r/((V-1)*MSE)
w = qf(alpha, V-1, V*(r-1), lower.tail = FALSE)
g = data.frame(r, round(w, 3), round(rhs, 3))
}
rbind(g)
}
table(MSE = msE, V = a*b, H = h)
```
I figured it would go something like this, but this only prints out the last value of r before the loop ends (it ends at 26), which results in a "table" that only has one row. I would like a table with 24 rows (since it starts at r = 2).
Any help would be appreciated!
Perhaps this might help:
al = 0.10; n = 30; a = 3; b = 5; r = 2; int = 8; h = (int/2); msE = 19.19
table = function(MSE, V, H, alpha = al, r = 2){
rhs = h^2*r/((V-1)*MSE)
w = qf(alpha, V-1, V*(r-1), lower.tail = FALSE)
g = data.frame(r, round(w, 3), round(rhs, 3))
gn = data.frame(r, round(w, 3), round(rhs, 3))
while(w > rhs){
r = r+1
rhs = h^2*r/((V-1)*MSE)
w = qf(alpha, V-1, V*(r-1), lower.tail = FALSE)
g = data.frame(r, round(w, 3), round(rhs, 3))
gn <- rbind(gn,g)
}
return(gn)
}
table(MSE = msE, V = a*b, H = h)
A slightly different approach, eliminating the need for an interim data frame and for rbind(). Commented in the code.
# your parameters
al <- 0.10; n <- 30; a <- 3; b <- 5; int <- 8; h <- (int/2); msE <- 19.19
# your function definition (name changed to avoid confusion / conflict with existing R function)
tabula <- function(MSE, V, H, alpha = al, r = 2)
{
g <- data.frame( N = 0, W = 1, RHS = 0 ) # initiate data frame, values set
# so that the while condition is met
# the while function populates the data frame cell by cell,
# eliminating the need for an interim data.frame and rbind()
while( g[ r - 1, "W" ] > g[ r - 1, "RHS" ] ) # check condition in the last data frame row
{ # write values in a new row
g[ r, "N" ] <- r
g[ r, "W" ] <- round( qf( alpha, V - 1, V * ( r - 1 ), lower.tail = FALSE ), 3 )
g[ r, "RHS" ] <- round( h^2 * r / ( ( V - 1 ) * MSE ), 3 )
r <- r + 1 # increment row counter
}
return( g[ -1, ] ) # return the data frame, removing the initial row
}
tabula( MSE = msE, V = a * b, H = h )
Hi I want to convert a matrix of genotypes, encoded as triples to a matrix encoded as 0, 1, 2, i.e.
c(0,0,1) <-> 0; c(0,1,0) <-> 1; c(0,0,1) <-> 2
First here is some code to generate the matrix that needs to be reduced.
# generate genotypes
expand.G = function(n,p){
probs = runif(n = p)
G012.rows = matrix(rbinom(2,prob = probs,n=n*p),nrow = p)
colnames(G012.rows) = paste('s',1:n,sep = '')
rownames(G012.rows) = paste('g',1:p, sep = '')
G012.cols = t(G012.rows)
expand.geno = function(g){
if(g == 0){return(c(1,0,0))}
if(g == 1){return(c(0,1,0))}
if(g == 2){return(c(0,0,1))}
}
gtype = c()
for(i in 1:length(c(G012.cols))){
gtype = c(
gtype,
expand.geno(c(G012.cols)[i])
)
}
length(gtype)
G = matrix(gtype,byrow = T, nrow = p)
colnames(G) = paste('s',rep(1:n,each = 3),c('1','2','3'),sep = '')
rownames(G) = paste('g',1:p, sep = '')
print(G[1:10,1:15])
print(G012.rows[1:10,1:5])
return(G)
}
The output has 3n columns and p rows, where n is sample size and p is number of genotypes. Now we can reduce the matrix back to 0,1,2 coding with the following functions
reduce012 = function(x){
if(identical(x, c(1,0,0))){
return(0)
} else if(identical(x, c(0,1,0))){
return(1)
} else if(identical(x, c(0,0,1))){
return(2)
} else {
return(NA)
}
}
reduce.G = function(G.gen){
G.vec =
mapply(function(i,j) reduce012(as.numeric(G.gen[i,(3*j-2):(3*j)])),
i=expand.grid(1:(ncol(G.gen)/3),1:nrow(G.gen))[,2],
j=expand.grid(1:(ncol(G.gen)/3),1:nrow(G.gen))[,1]
)
G = matrix(G.vec, nrow = ncol(G.gen)/3, ncol = nrow(G.gen))
colnames(G) = rownames(G.gen)
return(G)
}
reduce.G.loop = function(G.gen){
G = matrix(NA,nrow = ncol(G.gen)/3, ncol = nrow(G.gen))
for(i in 1:nrow(G.gen)){
for(j in 1:(ncol(G.gen)/3)){
G[j,i] = reduce012(as.numeric(G.gen[i,(3*j-2):(3*j)]))
}
}
colnames(G) = rownames(G.gen)
return(G)
}
The output is n rows by p columns. It is incidental, but intentional, that the matrix encoded as 0,1,2 is the transpose of the matrix encoded as triples.
The code is not particularly fast. What is bothering me is that the the timing goes with n^2. Can you explain or supply more efficient code?
G = expand.G(1000,20)
system.time(reduce.G(G))
system.time(reduce.G.loop(G))
G = expand.G(2000,20)
system.time(reduce.G(G))
system.time(reduce.G.loop(G))
G = expand.G(4000,20)
system.time(reduce.G(G))
system.time(reduce.G.loop(G))
You can simply make an accessor lookup table:
decode <- array(dim = c(3, 3, 3))
decode[cbind(1, 0, 0) + 1] <- 0
decode[cbind(0, 1, 0) + 1] <- 1
decode[cbind(0, 0, 1) + 1] <- 2
And then, just do:
matrix(decode[matrix(t(G + 1), ncol = 3, byrow = TRUE)], ncol = nrow(G))
This full vectorized R version will give you the same matrix, without dimnames and super fast.
Yet, if you have much larger matrices, you should really use Rcpp for both memory and timing issues.
This seems to be a about three times faster than your version (renamed reduce.G.orig):
reduce.G <- function(G) {
varmap = c("100"=0, "010"=1, "001"=2)
result <- do.call(rbind, lapply(1:(ncol(G)/3)-1, function(val)
varmap[paste(G[,3*val+1], G[,3*val+2], G[,3*val+3], sep="")]))
colnames(result) <- rownames(G)
result
}
system.time(reduce.G(G))
# user system elapsed
# 0.156 0.000 0.155
system.time(reduce.G.orig(G))
# user system elapsed
# 0.444 0.000 0.441
identical(reduce.G(G), reduce.G.orig(G))
# [1] TRUE
Starting with some sample data:
sample_data <- data.frame(id = 1:3,
x = c(128, 113, 126),
n = c(347, 344, 347),
m = c(335, 334, 347),
index = c(11, 9, -1))
theta <- matrix(c(0.5 ,0.5, 2, 2), nrow=2, ncol=2)
lhs <- function(a, b, g, d, dat){
beta(a + dat$x, b + dat$n - dat$x) / beta(a, b) * beta(g, d + dat$n) / beta(g, d)
}
The function lhs returns a vector of the same number of rows as the argument dat.
rhs <- function(dat, ...){
n = dat$n
m = dat$m
x = dat$x
index = dat$x
temp <- data.frame(i = 0:index,
n = rep(n, index + 1) ,
m = rep(m, index + 1) ,
x = rep(x, index + 1))
sum(beta(a + temp$x, b + temp$m - temp$x + temp$i) / beta(a,b) * beta(g + 1, d + temp$m + temp$i) / beta(g, d))
}
The function rhs works only on a single row because each observation has a different value for index (the index for the sum inside rhs). The intent is to return one value per row in dat. I've tried to do this with apply in the function LL (below).
LL <- function(theta, dat){
a <- theta[1,1]
b <- theta[2,1]
g <- theta[1,2]
d <- theta[2,2]
.lhs <- lhs(a, b, g, d, dat)
.rhs <- ifelse(index > -1, apply(dat, 1, rhs), 0)
sum(log(.lhs+log.rhs))
}
It seems like I need to be able to pass the value of index, n, m, and x to rhs from a given row. That is, not a vector of length(data$n), but the value of n at that row being passed through apply in the function LL.
Is this the correct approach? How can I do such a thing?
Thanks.
Edit
I've clean things up a bit and made a slight modification to the sample data. The correct return value -I think! - can be arrived at by (explicitly passing a,b,g, and d)
sum(lhs(a = theta[1,1],
b = theta[2,1],
g = theta[1,2],
d = theta[2,2],
sample_data)) +
rhs(sample_data[1,]) +
rhs(sample_data[2,]) +
rhs(sample_data[3,])
I have a set of 3D-Bodies. Each Body is defined by 8 points with three coordinates each. All of the bodies are cubical or approximately cubical. I would like to "fill" the cubes with a systematic point raster. The coordinates are stored in simple data.frames.
I developed the following code that does what I want for cubical bodies:
# libraries
library(rgl)
# define example cube with 8 points
excube <- data.frame(
x = c(1,1,1,1,5,5,5,5),
y = c(1,1,4,4,1,1,4,4),
z = c(4,8,4,8,4,8,4,8)
)
# cubeconst: fill cube (defined by 8 corner points) with a 3D-point-raster
cubeconst <- function(x, y, z, res) {
cube <- data.frame()
xvec = seq(min(x), max(x), res)
yvec = seq(min(y), max(y), res)
zvec = seq(min(z), max(z), res)
for (xpoint in 1:length(xvec)) {
for (ypoint in 1:length(yvec)) {
for (zpoint in 1:length(zvec)) {
cube <- rbind(cube, c(xvec[xpoint], yvec[ypoint], zvec[zpoint]))
}
}
}
colnames(cube) <- c("x", "y", "z")
return(cube)
}
# apply cubeconst to excube
fcube <- cubeconst(x = excube$x, y = excube$y, z = excube$z, res = 0.5)
# plot result
plot3d(
fcube$x,
fcube$y,
fcube$z,
type = "p",
xlab = "x",
ylab = "y",
zlab = "z"
)
Now I'm searching for a solution to "fill" approximately cubical bodies like for example the following body:
# badcube
badcube <- data.frame(
x = c(1,1,1,1,5,5,5,5),
y = c(1,1,4,4,1,1,4,4),
z = c(4,10,4,12,4,8,4,8)
)
# plot badcube
plot3d(
badcube$x,
badcube$y,
badcube$z,
col = "red",
size = 10,
type = "p",
xlab = "x",
ylab = "y",
zlab = "z"
)
Maybe you can point me in the right direction.
You need to transform the hexahedron (wonky cube) to a unit cube. The following image shows what I mean, and gives us a numbering scheme for the vertices of the hexa. Vertex 2 is hidden behind the cube.
The transformation is from real space x,y,z, to a new coordinate system u,v,w, in which the hexa is a unit cube. The typical function used for hexa looks like this.
x = A + B*u + C*v + D*w + E*u*v + F*u*w + G*v*w + H*u*v*w
Transformations for y and z coordinates are of the same form. You have 8 corners to your cube, so you can substitute these in to solve for coefficients A,B,.... The unit coordinates u,v,w are either 0 or 1 at every vertex, so this simplifies things a lot.
x0 = A // everything = zero
x1 = A + B // u = 1, others = zero
x2 = A + C // v = 1, ...
x4 = A + D // w = 1
x3 = A + B + C + E // u = v = 1
x5 = A + B + D + F // u = w = 1
x6 = A + C + D + G // v = w = 1
x7 = A + B + C + D + E + F + G + H // everything = 1
You then have to solve for A,B,.... This is easy because you just forward substitute. A equals x0. B equals x1 - A, etc... You have to do this for y and z also, but if your language supports vector operations, this can probably be done in the same step as for x.
Once you have the coefficients, you can convert a point u,v,w to x,y,z. Now, if you have a point generation scheme which works on a 1x1x1 cube, you can transform the result to the origonal hex. You could retain the same triple-loop structure in your posted code, and vary u,v,w between 0 and 1 to create a grid of points within the hex.
I'm afraid I don't know r, so I can't give you any example code in that language. Here's a quick python3 example, though, just to prove it works.
import matplotlib.pyplot as pp
import numpy as np
from mpl_toolkits.mplot3d import Axes3D
np.random.seed(0)
cube = np.array([
[0.0, 0.0, 0.0], [1.0, 0.0, 0.0], [0.0, 1.0, 0.0], [1.0, 1.0, 0.0],
[0.0, 0.0, 1.0], [1.0, 0.0, 1.0], [0.0, 1.0, 1.0], [1.0, 1.0, 1.0]])
hexa = cube + 0.5*np.random.random(cube.shape)
edges = np.array([
[0, 1], [0, 2], [1, 3], [2, 3],
[0, 4], [1, 5], [2, 6], [3, 7],
[4, 5], [4, 6], [5, 7], [6, 7]])
def cubeToHexa(hexa, u, v, w):
A = hexa[0]
B = hexa[1] - A
C = hexa[2] - A
D = hexa[4] - A
E = hexa[3] - A - B - C
F = hexa[5] - A - B - D
G = hexa[6] - A - C - D
H = hexa[7] - A - B - C - D - E - F - G
xyz = (
A +
B*u[...,np.newaxis] +
C*v[...,np.newaxis] +
D*w[...,np.newaxis] +
E*u[...,np.newaxis]*v[...,np.newaxis] +
F*u[...,np.newaxis]*w[...,np.newaxis] +
G*v[...,np.newaxis]*w[...,np.newaxis] +
H*u[...,np.newaxis]*v[...,np.newaxis]*w[...,np.newaxis])
return xyz[...,0], xyz[...,1], xyz[...,2]
fg = pp.figure()
ax = fg.add_subplot(111, projection='3d')
temp = np.reshape(np.append(hexa[edges], np.nan*np.ones((12,1,3)), axis=1), (36,3))
ax.plot(temp[:,0], temp[:,1], temp[:,2], 'o-')
u, v, w = np.meshgrid(*[np.linspace(0, 1, 6)]*3)
x, y, z = cubeToHexa(hexa, u, v, w)
ax.plot(x.flatten(), y.flatten(), z.flatten(), 'o')
pp.show()
I can't recall the exact justificiation for this form of the transformation. It's certainly easy to solve, and it has no squared terms, so lines in the directions of the u,v,w axes map to straight lines in x,y,z. This means your cube edges and faces are guaranteed to conform, as well as the corners. I lack the maths to prove it, though, and I couldn't find any googleable information either. My knowledge comes from a distant memory of textbooks on Finite Element Methods, where these sort of transformations are common. If you need more information, I suggest you start looking there.
Thanks to Bills explanation and examples I was able to come up with the following solution in R:
# libraries
library(rgl)
# create heavily distorted cube - hexahedron
hexatest <- data.frame(
x = c(0,1,0,4,5,5,5,5),
y = c(1,1,4,4,1,1,4,4),
z = c(4,8,4,9,4,8,4,6)
)
# cubetohexa: Fills hexahedrons with a systematic point raster
cubetohexa <- function(hexa, res){
# create new coordinate system (u,v,w)
resvec <- seq(0, 1, res)
lres <- length(resvec)
u <- c()
for (p1 in 1:lres) {
u2 <- c()
for (p2 in 1:lres) {
u2 <- c(u2, rep(resvec[p2], lres))
}
u <- c(u,u2)
}
v <- c()
for (p1 in 1:lres) {
v <- c(v, rep(resvec[p1], lres^2))
}
w <- rep(resvec, lres^2)
# transformation
A <- as.numeric(hexa[1,])
B <- as.numeric(hexa[2,]) - A
C <- as.numeric(hexa[3,]) - A
D <- as.numeric(hexa[5,]) - A
E <- as.numeric(hexa[4,]) - A - B - C
F <- as.numeric(hexa[6,]) - A - B - D
G <- as.numeric(hexa[7,]) - A - C - D
H <- as.numeric(hexa[8,]) - A - B - C - D - E - F - G
A <- matrix(A, ncol = 3, nrow = lres^3, byrow = TRUE)
B <- matrix(B, ncol = 3, nrow = lres^3, byrow = TRUE)
C <- matrix(C, ncol = 3, nrow = lres^3, byrow = TRUE)
D <- matrix(D, ncol = 3, nrow = lres^3, byrow = TRUE)
E <- matrix(E, ncol = 3, nrow = lres^3, byrow = TRUE)
F <- matrix(F, ncol = 3, nrow = lres^3, byrow = TRUE)
G <- matrix(G, ncol = 3, nrow = lres^3, byrow = TRUE)
H <- matrix(H, ncol = 3, nrow = lres^3, byrow = TRUE)
for (i in 1:(lres^3)) {
B[i,] <- B[i,] * u[i]
C[i,] <- C[i,] * v[i]
D[i,] <- D[i,] * w[i]
E[i,] <- E[i,] * u[i] * v[i]
F[i,] <- F[i,] * u[i] * w[i]
G[i,] <- G[i,] * v[i] * w[i]
H[i,] <- H[i,] * u[i] * v[i] * w[i]
}
m <- data.frame(A+B+C+D+E+F+G+H)
colnames(m) <- c("x", "y", "z")
# output
return(m)
}
# apply cubetohexa to hexatest
cx <- cubetohexa(hexatest, 0.1)
# plot result
plot3d(
cx$x,
cx$y,
cx$z,
type = "p",
xlab = "x",
ylab = "y",
zlab = "z"
)
Edit:
This function is now implemented with Rcpp in my R package recexcavAAR.