In ZJ107/JiangZhihangTools: Tools for STAT 3701 homework 3

Info

This is package is built for quiz3 and homework3, which inclde all functions in pervious homeworks and quizs. It includes three data set and 14 functions. The package can be used to calculate mean, variance and standard deviation. Also it can calcuat MLE for most of distribution and there is an efficient way for gamma distribution. Then it is very useful for matrix calculation.

data

there are 3 data set in the package

data2007 <- read.csv("http://users.stat.umn.edu/~almquist/3811_examples/gapminder2007ex.csv")
d <- read.table(url("http://www.stat.umn.edu/geyer/3701/data/q1p4.txt"),header = TRUE)
m<-url("http://www.stat.umn.edu/geyer/3701/data/q2p3.rda")

functions

function1

it can calculate Mean, Variance, SD

func1 <- function(x){
  a = sum(x)/length(x)
  b = sum((x-a)^2)/length(x)
  c = sqrt(b)
  return(list(mean=a,var=b,sd=c))
}
func1(rnorm(10))

function2

It also calculate Mean,Variance,SD and it can check the input data

func2 <- function(x){
  stopifnot(is.numeric(x))
  stopifnot(length(x)!=0)
  stopifnot(is.finite(x))
  stopifnot(!is.na(x))
  stopifnot(!is.nan(x))

  a = sum(x)/length(x)
  b = sum((x-a)^2)/length(x)
  c = sqrt(b)
  return(list(mean=a,var=b,sd=c))
}
func2(rnorm(10))

function3

This function3 computes the liklihood of a gamma distribution

func3 <- function(x){
  alpha <- pi
  log <- function(alpha)
    sum(dgamma(x, shape = alpha, log = TRUE))
  interval <- mean(x) + c(-1,1) * 3 * sd(x)
  interval <- pmax(mean(x) / 1e3, interval)

  oout<- optimize(log, maximum = TRUE, interval)
  return (oout$maximum)
}
x <- scan(url("http://www.stat.umn.edu/geyer/3701/data/q1p3.txt"))
func3(x)

function4

function4 calculates weigthed Mean,Variance,SD

func4 <- function(d){

  a = sum(d$x * d$p)
  b = sum(((d$x - a)^2) * d$p)
  c = sqrt(b)
  return(list(mean=a,var=b,sd=c))

}

func4(d)

function5

function5 calculates Mean,Variance,SD with checking the input data

func5 <- function(d){

  stopifnot(is.numeric(d$x))
  stopifnot(is.numeric(d$p))

  stopifnot(length(d$x)!=0)
  stopifnot(length(d$p)!=0)

  stopifnot(is.finite(d$x))
  stopifnot(is.finite(d$p))

  stopifnot(!is.na(d$x))
  stopifnot(!is.na(d$p))

  stopifnot(!is.nan(d$x))
  stopifnot(!is.nan(d$p))

  stopifnot(all.equal(sum(d$p),1))

  a = sum(d$x * d$p)
  b = sum(((d$x - a)^2) * d$p)
  c = sqrt(b)
  return(list(mean=a,var=b,sd=c))

}
a<-read.table(url("http://www.stat.umn.edu/geyer/3701/data/q1p4.txt"),
    header = TRUE)
func5(a)

function6

function6 calculates weighted Mean,Variance,SD with checking the input data

func6<-function(x,y)
{
  if(!length(y)>0){
    print("length of the second input is not positive")
  }else if(!length(x)>0){
    print("the length of first input is not positive")
  }else if(!is.numeric(x)){
    print("the first input is not numeric")
  }else if(!is.numeric(y)){
    print("the second input is not numeric")
  }else if(sum(is.finite(x))!=length(x)){
    print("the first input has infinite elements")
  }else if(sum(is.finite(y))!=length(y)){
    print("the second input has infinite elements")
  }else if(length(y)!=length(x)){
    print("the lenghs of two input are not equal")
  }else if(!isTRUE(all.equal(sum(y),1))){
    print("the sum of second input is not equal to 1")
  }else if(sum(y>0)!=length(y)){
    print("second input have negative elements")
  }else{
    mu<-sum((x)*y)
    si<-sum(((x-mu)^2)*y)
    data.frame(mean = mu,variance = si, sd = sqrt(si))
  }
}
func6(1,Inf)
func6(1,"a")
func6(double(0),1)
func6(c(1,2,3),c(0,2,1))

function7

Computes the liklihood of a given distribution for data x

func7 <- function(x, func, interval){

  f7 <- function(theta, x)
  {sum(func(theta, x))}

  oout<- optimize(f7, maximum = TRUE, interval, x=x)
  return(oout$maximum)
} 
x1=rgamma(100,3)
f = function(theta, x) dgamma(x, shape = theta, log = TRUE)
func7(x1,f,c(0,3))

function8

function8 calculates matrix multiplcation $x^T A^{-1} x$

func8<-function(a,x){
  stopifnot(is.matrix(a))
  stopifnot(is.vector(x))
  stopifnot(is.numeric(x))
  stopifnot(is.numeric(a))
  stopifnot(is.finite(x))
  stopifnot(is.finite(a))
  stopifnot(nrow(a)==ncol(a))
  stopifnot(nrow(a)==length(x))
  m=solve(a,x)
  sum(x*m)
}
load(url("http://www.stat.umn.edu/geyer/3701/data/q2p1.rda"))
func8(a,x)

function9

function9 calculates matrix multiplcation $x^T A^{-1} x$ as a binary operator

"%func9%" <-function(a,x){
  stopifnot(is.matrix(a))
  stopifnot(is.vector(x))
  stopifnot(is.numeric(x))
  stopifnot(is.numeric(a))
  stopifnot(is.finite(x))
  stopifnot(is.finite(a))
  stopifnot(nrow(a)==ncol(a))
  stopifnot(nrow(a)==length(x))
  m=solve(a,x)
  sum(x*m)
}
load(url("http://www.stat.umn.edu/geyer/3701/data/q2p1.rda"))
a%func9%x

function10

function10 standardizes matrix

func10<-function(x){
  stopifnot(nrow(x)>1)
  stopifnot(is.matrix(x))
  stopifnot(is.numeric(x))
  stopifnot(is.finite(x))
  for(i in 1:ncol(x)){
    x[,i]=(x[,i]-mean(x[,i]))/sd(x[,i])
  }
  x
}
load(url("http://www.stat.umn.edu/geyer/3701/data/q2p3.rda"))
func10(a)

function11

function11 standardizes matrix without loop

func11<-function(x){
  stopifnot(is.matrix(x))
  stopifnot(is.numeric(x))
  stopifnot(is.finite(x))
  FUN<-function(x)
  {
    x<-(x-mean(x))/sd(x)
  }
  apply(x,2,FUN)    
}
load(url("http://www.stat.umn.edu/geyer/3701/data/q2p3.rda"))
func11(a)

myapply

It is similar with apply function

myapply <- function(x,MARGIN,FUN,...)
{
  if(length(dim(x))!=2)
  {
    stop("matrix is not 2d")
  }
  if(!(MARGIN %in% c(1,2)))
  {
    stop("margin is not in 1 or 2")
  }
  R=dim(x)[1]
  C=dim(x)[2]
  f= match.fun(FUN)
  if(MARGIN==1)
  {
    result=list()
    for(i in 1:R)
    {
      result[[i]]=f(x[i,],...)
    }
  }else if(MARGIN==2)
  {
    result=list()
    for(j in 1:C)
    {
      result[[j]]=f(x[,j],...)
    }
  }
  return(simplify2array(result))
}
fred=matrix(1:6,nrow = 3)
rownames(fred)=c("red","white","blue")
colnames(fred)=c("car","truck")
myapply(fred, 1, mean)

MLEfunc

It is same as function7

MLEfunc<-function(x,f,interval){
  logl<-function(theta){
  sum(f(theta,x))
  }
  oout<-optimize(logl,maximum=TRUE,interval)
  oout$maximum
}
x1=rgamma(100,3)
f = function(theta, x) dgamma(x, shape = theta, log = TRUE)
MLEfunc(x1,f,c(0,3))

plot function

Wrapper function for ggplot2 for data d

plotMyData<-function(x){
  library(magrittr)
  x%>% ggplot2::ggplot()+ggplot2::aes(x=x, y=p)+ggplot2::geom_point()
}
plotMyData(d)

select function

selectmydata<-function(x){
  library(magrittr)
  library(tidyverse)
  library(dplyr)
  xa<-data2007%>%
select(gdpPercap, pop) %>% 
mutate(gdp = pop * gdpPercap)
  return(xa)
}
selectmydata(data2007)

more example

It is for making up Quiz 3

ggplot2::ggplot(d)+ggplot2::aes(x=x, y=p)+ggplot2::geom_point()
ggplot2::ggplot(d)+ggplot2::aes(x=x, y=p)+ggplot2::geom_line()
ggplot2::ggplot(d)+ggplot2::aes(x=x, y=p)+ggplot2::geom_area()

ZJ107/JiangZhihangTools documentation built on May 25, 2019, 2:23 p.m.