server.R

shinyServer(function(input, output) {

  myData <- reactive({
  read.csv(input$file$datapath)
    })

  output$summary <- renderPrint({
     if (is.null(input$file)) {

      return(cat('File not uploaded'))
    }
    dataset <- myData()

macrophyte.IBI<-function(survey,location=T)

{

all.sp<-c('A','AA','AC','AG','AI','AL','ALG','ALS','AM','AS','AT','B','BA','BB','BC','BGA','BRS',
  'BS','BUB','BW','C','CA','CAC','CAH','CAL','CALA','CAN','CAP','CAS','CAW','CB','CC','CD','CE',
  'CEE','CH','CHC','CM','COMP','COS','CP','CRES','CS','CV','CY','CYP','D','DA','DV','E','EA','EC',
  'EF','ELAS','ELM','ELNE','ELOD','ELS','ELSP','ELT','EM','EN','EP','EQS','ERI','ES','EUM','EUP',
  'EV','F','FA','FF','G','GAL','GB','GG','GL','H','HA','HD','HE','HJ','HV','HYS','HYV','I','IE',
  'IM','IMA','IMS','IP','IRV','IS','IV','J','JB','JE','JEWL','JF','JN','LA','LAB','LC','LD','LG',
  'LM','LO','LS','LT','LU','LYS','LYT','M','MA','MB','MEA','MF','MG','MH','MR','MS','MT','MV','MVO',
  'MYH','MYS','MYT','N','NAG','NF','NG','NL','NM','NO','NS','NUL','NUR','NUS','NV','NX','NX','NYL',
  'NYS','P','PA','PC','PD','PE','PF','PFL','PG','PHA','PHAU','PI','PL','PLA','PN','PO','POA','POAL',
  'POB','POC','POF','POFR','PON','PONF','POO','POP','POPA','POPU','POR','POS','POSB','POSN','POV',
  'PP','PPUL','PR','PS','PV','PZ','R','RAF','RF','RG','RIF','RL','RM','RO','RS','RT','RU','RUO','S',
  'SA','SAC','SAL','SAS','SB','SC','SCA','SCC','SCE','SCF','SCH','SCP','SCS','SCT','SCTS','SCU',
  'SE','SEME','SF','SFLO','SG','SIS','SL','SM','SO','SP','SPA','SPAG','SPAM','SPC','SPG','SPGL',
  'SPI','SPM','SPNG','SPP','SPPE','SPT','SR','SS','SUA','SV','SX','TA','TG','TL','TS','TSNL','UC',
  'UG','UI','UM','UP','UR','UV','V','VA','VEA','VES','VM','VS','WC','WM','WS','ZIP','ZP')

nonrooted<-c('BGA','D','EMT','FA','GA','PLA','SPAG','SPM','SPNG','WM')

submersed.sp<-c('BW','C','CAH','CAS','CD','CEE','CF','CH','CV','EC','ELAS','ELM','ELOD','ELT','EN',
  'ES','FS','H','HD','HV','I','IE','IM','IMA','LD','LU','M','MA','MB','MF','MH','MS','MV','MYH',
  'MYS','MYT','N','NAG','NF','NG','NM','NS','PA','PAN','PB','PC','PD','PE','PF','PG','PI','PN','PO',
  'POAL','POB','POC','POF','POFR','POH','PON','PONF','POO','POP','POPU','POR','POS','POSB','POSN',
  'POV','PP','PPUL','PR','PS','PTO','PV','PZ','R','RAF','RF','RG','RL','RO','RS','RSU','RT','SS',
  'SUA','UC','UG','UI','UM','UP','UR','UV','VA','X','ZP')

sensitive.sp<-c('AG','CP','CH','CAH','CEE','CHC','DA','ELM','ELT','ES','ERI','GB','HV','HA','HE',
  'I','IE','IM','IMA','LG','LU','LD','MB','MT','MG','MA','MF','MYT','MV','NAG','NG','NL', 'NYL',
  'POC','POAL','POB', 'PD','PE','POF','POFR','POO','PO','PR','POS','PS','POV','SB','SAC','SH','SS',
  'SCT','SPAM','SPA','SPF','SN','PV','SUA','TM','UC','UG','UI','UM','UP','UR','VM','VO','X','ZAQ',
  'ZIP')

tolerant.sp<-c('AC','AS','BUB','CAT','CB','CD','CE','EM','HJ','IP','IMS','JEWL','LS','MYH','MYS',
  'PC','PHA','PHAU','RM','TA','TG','TL','TS','TSNL')

exotic.sp<-c('AC','BUB','CE','IP','LS','MYH','MYS','PC','PHA','TA','TG','TSNL')

data.prep<-{
  all.pts<-{
    if(location==T){
      if(strsplit(survey,'.',fixed=T)[[1]][2] == '.csv') lake.data<-read.csv(survey,header=T)
      else lake.data<-read.table(survey,header=T,sep=',')
      }
    if(location==F) lake.data<-survey
    lake.data[is.na(lake.data)]<-0
    match.test<-match(names(lake.data),nonrooted,nomatch=0)
    rooted<-{
      sp.names<-subset(cbind(names(lake.data),match.test),match.test==0)[,1]
      subset(lake.data,select=sp.names)
      }
    Sum<-ifelse(as.matrix(rowSums(rooted)-rooted[,1])>0,1,0)
    cbind(rooted,Sum)[order(cbind(rooted,Sum)$AQPNT_Depth),]
    }
  ADPG<-max((subset(all.pts,Sum==1)$AQPNT_Depth))
  Cumsum<-cumsum(subset(all.pts,(AQPNT_Depth<ADPG|AQPNT_Depth==ADPG))$Sum)
  Freq<-round(Cumsum/max(Cumsum),2)
  cbind(subset(all.pts,(AQPNT_Depth<ADPG|AQPNT_Depth==ADPG)),Cumsum,Freq)
  }

sp.freq<-round(colSums(rooted[,1:ncol(rooted)])[2:ncol(rooted)]/nrow(data.prep),4)

if(sum(is.na(match(names(sp.freq),all.sp)))>0){
  unknown<<-names(sp.freq)[which(is.na(match(names(sp.freq),all.sp))==TRUE)]
  stop("unknown species, type 'unknown' for identification")
  }
if(sum(as.numeric(colSums(data.prep[,2:ncol(data.prep)]))==0)>0){
  unsampled<<-names(sp.freq)[which(as.numeric(colSums(data.prep[,2:ncol(data.prep)]))==0)]
  stop("unsampled species, type 'unsampled' for identification")
  }
if(ncol(lake.data)-sum(names(lake.data)=='PC')==1){
  stop('curly-leaf pondweed surveys not used for IBI')
  }

boxcox<-function(x,lambda,geometric.mean){
  ((1+x)^lambda-1)/(lambda*geometric.mean^(lambda-1))
  }

pos.scale<-function(x,quan,min){
  if(x>quan|x==quan){10}
	else{10*(x-min)/(quan-min)}
  }
neg.scale<-function(x,quan,max){
	if(x<quan|x==quan){10}
	else{10-(10*(x-quan)/(max-quan))}
  }

MAXD<-{
  MAXD.raw<-max(subset(data.prep, Freq<0.95|Freq==0.95)$AQPNT_Depth)
  if(MAXD.raw<1.75){
    warning('questionable value for MAXD, verify survey accuracy')
    }
  round(pos.scale(MAXD.raw,18.2,1.75),2)
  }
LITT<-{
  LITT.raw<-{
    littoral.zone<-subset(data.prep, Freq<0.95|Freq==0.95)
    length(subset(littoral.zone,Sum==1)$Sum)/length(littoral.zone$AQPNT_Depth)
    }
  if(LITT.raw<0){
    warning('questionable value for LITT, verify survey accuracy')
    }
  round(pos.scale(LITT.raw,1,0),2)
  }
OVER<-{
  OVER.raw<-sum(ifelse(sp.freq>0.1|sp.freq==0.1,1,0))
  if(OVER.raw<0){
    warning('questionable value for OVER, verify survey accuracy')
    }
  round(pos.scale(OVER.raw,12.2,0),2)
  }
SUBM<-{
  SUBM.raw<-sum(sp.freq[(names(sp.freq) %in% submersed.sp)]/sum(sp.freq))
  if(boxcox(SUBM.raw,6.042163,1.776386)>0.5926954){
    warning('questionable value for SUBM, verify survey accuracy')
    }
  round(neg.scale(boxcox(SUBM.raw,6.042163,1.776386),0.07707069,0.5926954),2)
  }
SENS<-{
  SENS.raw<-sum(sp.freq[(names(sp.freq) %in% sensitive.sp)]/sum(sp.freq))
  if(SENS.raw<0){
    warning('questionable value for SENS, verify survey accuracy')
    }
  round(pos.scale(SENS.raw,0.2328255,0),2)
  }
TOLR<-{
  TOLR.raw<-sum(sp.freq[(names(sp.freq) %in% tolerant.sp)]/sum(sp.freq))
  if(TOLR.raw>0.9426771){
    warning('questionable value for TOLR, verify survey accuracy')
    }
  round(neg.scale(TOLR.raw,0,0.9426771),2)
  }
TAXA<-{
  TAXA.raw<-(ncol(rooted)-1)-length(names(rooted)[names(rooted) %in% exotic.sp])
  if(TAXA.raw<1){
    warning('questionable value for TAXA, verify survey accuracy')
    }
  round(pos.scale(TAXA.raw,31.6,1),2)
  }
IBIscore<-round(10*(MAXD+LITT+OVER+SUBM+SENS+TOLR+TAXA)/7,2)

Raw<<-as.data.frame(formatC(rbind(MAXD.raw,LITT.raw,OVER.raw,SUBM.raw,SENS.raw,TOLR.raw,TAXA.raw),
  digits=2,format='f'))
names(Raw)<<-'Scores'

score.table<-as.data.frame(rbind(MAXD,LITT,OVER,SUBM,SENS,TOLR,TAXA,IBIscore))
names(score.table)<-'Scores'

cat('\nMN macrophyte IBI v1.5.4, milfoil hybrid addition\n')
cat('\nPrepared by M. Beck, Jan. 2011\n')
cat('\nnote: version includes milfoil hybrid which is not in DNR vegetation database\n')
if(location==T){
  surv=strsplit(survey,'/')[[1]][length(strsplit(survey,'/')[[1]])]
  cat(paste('\nIBI and metric scores for file',surv,sep=" "),'\n\n')
  }
if(location==F) cat('\nIBI and metric scores\n\n')

print(score.table)

cat("\nMetric values are scaled from 0-10 \nType 'Raw' for unscaled metrics \n\n")

}


  macrophyte.IBI(dataset,location=F)
  })

  output$view<-renderTable({
     if (is.null(input$file)) {

      return(cat(''))
    }
    head(myData())
  })

})

ui.R

shinyUI(pageWithSidebar(
  headerPanel("Load macrophyte survey"),
  sidebarPanel(
    fileInput("file", "File data", multiple=FALSE)
  ),
  mainPanel(
    verbatimTextOutput("summary"),
    tableOutput("view")
  )

))