Achievement Points =
(9 * (([Measure Score (performance)]-[Threshold])/([Benchmark]-[Threshold]))) + 0.5 Improvement Points = (10 * (([Measure Score (performance)]-[Measure Score (baseline)])/([Benchmark]-[Measure Score (baseline)]))) - 0.5 SSI Score = ((HAI-3 Score * HAI-3 Cases)+ (HAI-4 Score * HAI-4 Cases))/(HAI-3 Cases + HAI-4 Cases) Consistency Points = (20 * ((Hospital's HCAHPS Performance Period Score - Floor for that Measure)/(Achievement Threshold for that Measure - Floor for that Measure)) - 0.5 Final Points Earned = MAX([Improvement Points],[Achievement Points]) Domain Unweighted Score = [Total Domain Points Earned]/[Total Domain Score] Total Performance Score = SUM(Unweighted Domain Score * Domain Weight) Measure Impact = Measure Payment - Measure Contribution = [Estimated Total IPPS Operating Payments] * [VBP Contribution Percentage] * [Domain Weight] * [Maximum Measure Points]/[Total Maximum Measure Points in this Domain] * [Linear Payout Function Factor] * ([Final Points Earned]/[Maximum Measure Points]) - [Estimated Total IPPS Operating Payments] * [VBP Contribution Percentage] * [Domain Weight] * [Maximum Measure Points]/[Total Maximum Measure Points in this Domain] Domain Impact = Domain Payment - Domain Contribution = [Domain Unweighted Score] * [Domain Weight] * [Linear Payout Function Factor] * [Estimated Total IPPS Operating Payments] * [VBP Contribution Percentage] - [Estimated Total IPPS Operating Payments] * [VBP Contribution Percentage] * [Domain Weight] VBP Impact = VBP Payment - Contribution = [Total Performance Score] * [Linear Payout Function Factor] * [Estimated Total IPPS Operating Payments] * [VBP Contribution Percentage] - [Estimated Total IPPS Operating Payments] * [VBP Contribution Percentage]
1 Comment
trainx<-read.csv(file.choose(),header=T)
trainy<-read.csv(file.choose(),header=T) trainy[,2] <- as.numeric(factor(trainy[,2], levels = unique(trainy[,2]))) # y = 1,2,3 test<-read.csv(file.choose(),header=T) test$latitude <- -test$latitude # absolute value trainx$latitude <- -trainx$latitude # absolute value vectorize<-function(j){ k <- rep(0,3) k[j] <- 1 # label col = 1 if num == col k } Y <- t(apply(matrix(trainy[,2]),1,vectorize)) #Y <- trainy[,2] for(i in 1:40){ if(is.factor(trainx[,i]) == TRUE) { trainx[,i] <- as.numeric(factor(trainx[,i], levels = unique(trainx[,i]))) } } for(i in 1:40){ if(is.factor(test[,i]) == TRUE) { test[,i] <- as.numeric(factor(test[,i], levels = unique(test[,i]))) } } X<-t(t(trainx)/apply(trainx,2,max)) x_hat <- t(t(test)/apply(test,2,max)) input_layer_size <- 40 output_layer_size <- 3 hidden_layer_size <- 1 sigmoid <- function(z) 1/(1+exp(-z)) cost_optim <- function(w){ # input* hidden + output*hidden + hidden + output W_1 <- matrix(w[1:input_layer_size * hidden_layer_size] - 0.5, nrow = input_layer_size, ncol = hidden_layer_size) W_2 <- matrix(w[(1+input_layer_size*hidden_layer_size):((input_layer_size+output_layer_size)*hidden_layer_size)] - 0.5, nrow = hidden_layer_size, ncol = output_layer_size) B1 <- matrix(w[(((input_layer_size+output_layer_size)*hidden_layer_size)+1):(((input_layer_size+output_layer_size)*hidden_layer_size) + hidden_layer_size)],ncol=1)# runif(hidden_layer_size) B2 <- matrix(w[((((input_layer_size+output_layer_size)*hidden_layer_size) + hidden_layer_size)+1):(((input_layer_size+output_layer_size)*hidden_layer_size)+hidden_layer_size+output_layer_size)],ncol=1) #runif(output_layer_size) Z_2 <- X %*% W_1 A_2 <- sigmoid(Z_2 + t(B1 %*% rep(1,batch_size))) Z_3 <- A_2 %*% W_2 Y_hat <- sigmoid(Z_3 + t(B2 %*% rep(1,batch_size))) train<-read.csv(file.choose(),header=T)
x_test<-read.csv(file.choose(),header=T) x<-train[,c(1,2,3,4,5)] #row = 576, col = 4 Y<-train[,6] #row = 576, col = 1 X<-t(t(x)/apply(x,2,max)) test<-x_test[,c(1,2,3,4,5)] test<-t(t(test)/apply(test,2,max)) input_layer_size <- 5 output_layer_size <- 1 hidden_layer_size <- 1 sigmoid <- function(Z) 1/(1 + exp(-Z)) cost_optim <- function(w){ W_1 <- matrix(w[1:input_layer_size * hidden_layer_size],nrow=input_layer_size,ncol=hidden_layer_size) W_2 <- matrix(w[(1+input_layer_size*hidden_layer_size):((input_layer_size+output_layer_size)*hidden_layer_size)], nrow=hidden_layer_size,ncol=output_layer_size) Z_2 <- X %*% W_1 A_2 <- sigmoid(Z_2) Z_3 <- A_2 %*% W_2 Y_hat <- sigmoid(Z_3) -(sum(Y * log(Y_hat) + (1-Y) * log(1-Y_hat))) /576 #minimize this } set.seed(10) res <- optim(runif(((input_layer_size+output_layer_size)*hidden_layer_size)), fn=cost_optim,method="BFGS",control = list(maxit=100000)) print(res) W_1 <- matrix(res$par[1:input_layer_size * hidden_layer_size],nrow=input_layer_size,ncol=hidden_layer_size) W_2 <- matrix(res$par[(1+input_layer_size*hidden_layer_size):((input_layer_size+output_layer_size)*hidden_layer_size)], nrow=hidden_layer_size,ncol=output_layer_size) Z_2 <- test %*% W_1 A_2 <- sigmoid(Z_2) Z_3 <- A_2 %*% W_2 Y_hat <- sigmoid(Z_3) submission<-cbind(x_test[,1],Y_hat) View(submission) write.csv(submission,"sub.csv") cost_optim <- function(w){ # input* hidden + output*hidden + hidden + output W_1 <- matrix(w[1:input_layer_size * hidden_layer_size] - 0.5, nrow = input_layer_size, ncol = hidden_layer_size) W_2 <- matrix(w[(1+input_layer_size*hidden_layer_size):((input_layer_size+output_layer_size)*hidden_layer_size)] - 0.5, nrow = hidden_layer_size, ncol = output_layer_size) B1 <- matrix(w[(((input_layer_size+output_layer_size)*hidden_layer_size)+1):(((input_layer_size+output_layer_size)*hidden_layer_size) + hidden_layer_size)],ncol=1)# runif(hidden_layer_size) B2 <- matrix(w[((((input_layer_size+output_layer_size)*hidden_layer_size) + hidden_layer_size)+1):(((input_layer_size+output_layer_size)*hidden_layer_size)+hidden_layer_size+output_layer_size)],ncol=1) #runif(output_layer_size) Z_2 <- X %*% W_1 A_2 <- sigmoid(Z_2 + t(B1 %*% rep(1,batch_size))) Z_3 <- A_2 %*% W_2 Y_hat <- sigmoid(Z_3 + t(B2 %*% rep(1,batch_size))) -(sum(Y * log(Y_hat) + (1-Y) * log(1-Y_hat))) /576 } batch_size <- dim(X)[1] set.seed(1) res <- optim(runif( ((input_layer_size+output_layer_size)*hidden_layer_size)+hidden_layer_size+output_layer_size), fn=cost_optim,method="BFGS",control = list(maxit=10000)) print(res) Xt<-test batch_size <- dim(Xt)[1] W_1 <- matrix(res$par[1:input_layer_size * hidden_layer_size] - 0.5,nrow=input_layer_size,ncol=hidden_layer_size) W_2 <- matrix(res$par[(1+input_layer_size*hidden_layer_size):((input_layer_size+output_layer_size)*hidden_layer_size)] - 0.5, nrow=hidden_layer_size,ncol=output_layer_size) B1 <- matrix(res$par[(((input_layer_size+output_layer_size)*hidden_layer_size)+1):(((input_layer_size+output_layer_size)*hidden_layer_size) + hidden_layer_size)],ncol=1)# runif(hidden_layer_size) B2 <- matrix(res$par[((((input_layer_size+output_layer_size)*hidden_layer_size) + hidden_layer_size)+1):(((input_layer_size+output_layer_size)*hidden_layer_size)+hidden_layer_size+output_layer_size)],ncol=1) #runif(output_layer_size) Z_2 <- Xt %*% W_1 A_2 <- sigmoid(Z_2 + t(B1 %*% rep(1,batch_size))) Z_3 <- A_2 %*% W_2 Y_hat <- sigmoid(Z_3 + t(B2 %*% rep(1,batch_size))) submission<-cbind(x_test[,1],Y_hat) View(submission) write.csv(submission,"sub.csv") library(e1071) x<-X;y<-Y dat <- data.frame(x = x, y = as.factor(y)) test.x <- data.frame(x = test) #tune.out=tune(svm, y~., data = dat, kernel ="linear",ranges =list(cost=c(0.1 ,1 ,10 ,100 ) )) #tune.out$best.model #svmfit =svm(y~x, dat = data ,kernel="linear",cost =1) tune.out=tune(svm, y~., data = dat, kernel ="radial",ranges =list(cost=c(0.1 ,1 ,10 ,100),gamma=c(0.5,1,2,3) )) tune.out$best.model svmfit =svm(y~.,data = dat, kernel="radial",gamma =0.5,cost =1) pred.te=predict(svmfit , newdata =test.x) prediction <- matrix(pred.te,ncol=1) submission<-cbind(x_test[,1],prediction) View(submission) write.csv(submission,"sub.csv") dat <- data.frame(x = x[,-4], y = as.factor(y)) glm.fit=glm(y~., data=dat ,family =binomial ) summary (glm.fit ) glm.probs =predict (glm.fit,newdata= test.x,type ="response") prediction <- matrix(glm.probs,ncol=1) submission<-cbind(x_test[,1],prediction) View(submission) write.csv(submission,"sub.csv") sigmoid <- function(z) { g <- 1/(1+exp(-z)) return(g) } cost <- function(theta) { g <- sigmoid(X%*%theta) J <- (1/576)*sum((-Y*log(g)) - ((1-Y)*log(1-g))) return(J) } X<-X[,-c(1,4)] initial_theta <- rep(0,ncol(X)) #Cost at inital theta cost(initial_theta) theta_optim <- optim(par=initial_theta,fn=cost) print(theta_optim) #set theta theta <- theta_optim$par Y_hat <- sigmoid(test[,-c(1,4)]%*%theta) prediction <- matrix(Y_hat,ncol=1) submission<-cbind(x_test[,1],prediction) View(submission) write.csv(submission,"sub.csv") |