I don't know what is different between two codes. When I use ml.norm(iris[1:4], mode="uv",na.rm=FALSE) and dh.norm(iris[1:4], mode="uv",na.rm=FALSE), the results are different..`
ml.norm <- function(x, mode="uv", na.rm=FALSE){
if(class(x)=="data.frame"){
x <- as.matrix(x)
}
else{
return (apply(x,2,ml.norm, mode=mode, na.rm=na.rm))
}
if (mode =="uv"){
x = x/sd(x, na.rm=na.rm)
}
else if (mode =="z"){
x = (x-mean(x))/sd(x, na.rm=na.rm)
}
else{stop(paste("unknow mode", mode))}
return(x)
}
dh.norm <- function (x,mode="uv",na.rm=FALSE) {
# need to check if x is a matrix
if (is.data.frame(x)) {
x=as.matrix(x)
}
if (is.matrix(x)) {
return(apply(x,2,dh.norm,mode=mode,na.rm=na.rm))
}
if (mode == "uv") {
x = x/sd(x,na.rm=na.rm)
} else if (mode == "z") {
# your code here
x = (x - mean(x))/sd(x,na.rm=na.rm)
} else {
stop(paste("unknown mode",mode))
}
return(x)
}
ml.norm
IF x IS data.frame DO convert it into a matrix. THEN check mode and DO stuff.
dh.norm
IF x IS a data.frame DO convert it into a matrix. THEN check if x is a matrix and apply dh.norm on the columns. THEN check the mode and DO stuff.
So ml.norm is missing the return(apply(x,2,[YOUR FUNCTION],mode=mode,na.rm=na.rm)) part if you run it on a data.frame.
Related
Let's suppose the next function:
demo_function <- function(x){
if(is.na(x)){
return(NA)
} else if(1 < x < 2){
return("something")
} else {
return("Nothing")
}
}
The idea is that when the argument x is between 1 and 2, say x=0.001, then the function returns something.
However when trying to run the above function, the next error arises:
Error: no function to go from, jumping to a higher level
How could I adjust the function in order to get "something" for the specified argument?
The issue is in the else if i.e. the syntax in R is different than the mathematical notation - multiple expressions are connected by logical operators
else if(1 < x && x < 2)
i.e.
demo_function <- function(x){
if(is.na(x)){
return(NA)
} else if(1 < x && x < 2){
return("something")
} else {
return("Nothing")
}
}
> demo_function(0.01)
[1] "Nothing"
> demo_function(1.5)
[1] "something"
> demo_function(NA)
[1] NA
I need to have a function where if a number entered is a prime number, it must round it up to the next prime number and if it is not to round it down to the previous prime number.
I have this code to identify whether it is a prime number:
prime <- function(x) {
if (x == 2) {
print(3)
} else if (any(x %% 2:(x-1) == 0)) {
FALSE
} else {
TRUE
}
}
I want to add a while loop to the true and false where if the function is false, it must minus one until it is true and if it is true, it must add one until it is true again but I am not sure how to do this.
Using your prime checker,
prime <- function(x) {
if (x == 2) {
print(3)
} else if (any(x %% 2:(x-1) == 0)) {
FALSE
} else {
TRUE
}
}
We build the new function, we first check if our number is a prime, if so, add 1 until we reach the next prime. If it is not a prime, we minus 1 until it is.
new <- function(x){
if (isTRUE(prime(x))){
x = x+1
while(prime(x) == FALSE){
x = x+1
}
return(x)
} else {
while(prime(x) == FALSE){
x = x-1
}
return(x)
}
}
we get
> new(7)
[1] 11
> new(10)
[1] 7
This question already has answers here:
if/else constructs inside and outside functions
(2 answers)
Closed 5 years ago.
I constructed the function, but the R gives me the error. But I does not know what I did wrongly.
Error: unexpected '}' in "}"
Vect_fun=function(x,a) {
if(a=1)
{
y= mean(x,na.rm=TRUE)
}
else{
if(a=2)
{
y= na.aggregate(x)
}
else {
y=x[!is.na(x)]
}
}
y
}
Use double equal sign to comparing.
Vect_fun = function(x, a) {
if (a == 1) {
y = mean(x, na.rm = TRUE)
}
else {
if (a == 2) {
y = na.aggregate(x)
}
else {
y = x[!is.na(x)]
}
}
y
}
Your formatting is off in addition to needing to use the proper == operator, and else if
You should indent at each level so it's easier to read, and you need to use == for logical operators. Also, else{ if(){ }} is messy. Use else if{ }
Vect_fun <- function(x,a) {
if (a == 1) {
y = mean(x, na.rm = TRUE)
} else if (a == 2) {
y = na.aggregate(x)
return(y)
} else {
y = x[!is.na(x)]
}
return(y)
}
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))
}
}